[gcc r17-2496] cobol: Filename-as-device; normalize special registers.
Robert Dubner via Gcc-cvs <[email protected]>
| Newsgroups | gmane.comp.gcc.cvs |
|---|---|
| Message-ID | <[email protected]> |
https://gcc.gnu.org/g:b84ff621504a435d5ff4c416c10b178b6018ed76 commit r17-2496-gb84ff621504a435d5ff4c416c10b178b6018ed76 Author: Robert Dubner <[email protected]> Date: Fri Jul 17 08:19:51 2026 -0400 cobol: Filename-as-device; normalize special registers. The compiler now parses a new feature where a filename can be established using the device syntax. It awaits implementation in the code generator. The variables "literally_zero" and "literally_zero" are now established as global constants in libgcobol instead of as constructed temporary variables. The initialization of "special registers", and the necessary coordination between their compile-time cbl_field_t and run-time cblc_field_t counterparts has been normalized. gcc/cobol/ChangeLog: * genapi.cc (parser_file_open): New filename-as-device feature awaiting implementation. * lexio.h (struct filespan_t): Variable name change. * parse.y: Filename-as-device. * parse_ante.h (field_find): Likewise. (data_division_ready): _literally_zero and _literally_one global constants. * scan.l: Require separate space after '<', '>' and '=' comparison operators. * scan_ante.h (update_location): Change debug message text. * symbols.cc (constq): Eliminate #define in favor of explicit (constant_e | quoted_e). (label_cmp): Formatting: eliminate trailing space. (symbol_elem_cmp): Filename-as-device. (enum protoreq_t): Formatting: eliminate trailing space. (cbl_field_t::clear_attr): Likewise. (symbols_dump): Likewise. (cbl_field_t::attr_str): Likewise. (field_str): Likewise. (symbols_update): Use _literally_zero and _literally_one. (endian_bit): Compact access to cobol_target_big_endian(). (symbol_table_init): Normalize initialization of "special registers". (symbol_registers_add): Likewise. (cbl_perform_tgt_t::recurses): Formatting: eliminate trailing space. (symbol_literalA): Replace constq. (cbl_alphabet_t::reencode): Eliminate trailing space. (symbol_temporary_alphanumerics): Likewise. (new_literal_add): Likewise. (new_temporary_clone): Ensure FldLiteralBin5 has the endian attribute of the target architecture. (iconv_cd): Formatting: eliminate trailing space. (cbl_field_t::encode): Likewise. (cbl_field_t::set_capacity): Formatting: eliminate trailing space. (cbl_label_t::str): Likewise. (cbl_file_t::special_index): New function supporting filename-as-device. (cbl_file_t::filename_of): Likewise. * symbols.h (struct cbl_special_name_t): Support filename as device. (struct cbl_file_t): Likewise. (symbol_typedef): Likewise. (symbol_special_index): Likewise. libgcobol/ChangeLog: * charmaps.h (ebcdic_newline): Use just SPACES instead of both SPACE and SPACES. * constants.cc (INTEGER_CONSTANT1): Eliminate. (struct cblc_field_t): Eliminate __gg__data_space. (INTEGER_CONSTANT2): Eliminate. (endian): Adjust the initialization of __ggsr__spaces and the various DEBUG-ITEM components. * libgcobol.cc (alpha_to_alpha_move_from_location): Correct a comment. (__gg__codeset_figurative_constants): Normalize using SPACES when SPACE is specified. (__gg__get_figconst_data): Likewise. gcc/testsuite/ChangeLog: * cobol.dg/group2/INITIALIZE_with_-defaultbyte__ASCII_.cob: Use "VALUE '-'" instead of "VALUE'-'". * cobol.dg/group2/INITIALIZE_with_-defaultbyte__EBCDIC_.cob: Likewise. * cobol.dg/group2/PR59_RT3586_-_Code_format_heuristic_fails.cob: Removed. * cobol.dg/group2/RT3609_Unexpected_PROCESS.cob: Removed. * cobol.dg/group2/DEBUG-ITEM_using_mh_identical.cob: New test. * cobol.dg/group2/DEBUG-ITEM_using_mh_identical.out: New test. Diff: --- gcc/cobol/genapi.cc | 24 ++ gcc/cobol/lexio.h | 4 +- gcc/cobol/parse.y | 95 +++----- gcc/cobol/parse_ante.h | 12 +- gcc/cobol/scan.l | 29 ++- gcc/cobol/scan_ante.h | 2 +- gcc/cobol/symbols.cc | 267 +++++++++++++-------- gcc/cobol/symbols.h | 15 +- .../group2/DEBUG-ITEM_using_mh_identical.cob | 52 ++++ .../group2/DEBUG-ITEM_using_mh_identical.out | 15 ++ .../INITIALIZE_with_-defaultbyte__ASCII_.cob | 4 +- .../INITIALIZE_with_-defaultbyte__EBCDIC_.cob | 4 +- .../PR59_RT3586_-_Code_format_heuristic_fails.cob | 7 - .../cobol.dg/group2/RT3609_Unexpected_PROCESS.cob | 9 - libgcobol/charmaps.h | 2 +- libgcobol/constants.cc | 160 ++++++------ libgcobol/libgcobol.cc | 6 +- 17 files changed, 407 insertions(+), 300 deletions(-) diff --git a/gcc/cobol/genapi.cc b/gcc/cobol/genapi.cc index e95c912fca7c..46e2fc743d36 100644 --- a/gcc/cobol/genapi.cc +++ b/gcc/cobol/genapi.cc @@ -9112,6 +9112,30 @@ parser_file_open( struct cbl_file_t *file, int mode_char ) TRACE1_END } + +//#pragma message "parser_file_open: consult cbl_file_t::filename_of and cbl_file_t::device" + + /* + * The filename of a cbl_file_t may be found in three places: + * 1. As before, in the cbl_field_t indexed by cbl_file_t::filename. + * 2. Now, in the cbl_special_name_t indexed by cbl_file_t::device. + * 3. As ever, in neither, from the environment. + * + * If both filename and device are nonzero and not FldForward, the filename + * supersedes. The syntax was + * SELECT fd-name ASSIGN TO device-name USING filename + * That just creates in the parser an alias of device-name to fd-name. It's + * still the same file and does *not* change the device characteristics. + * + * If filename is FldForward (or 0) and device is nonzero, the OS filename is + * taken from cbl_special_name_t::os_filename. It is tiny, hard-coded name + * in /dev. + * + * Upon implementation please feel free to delete this message. + * --jkl + */ + + tree pszFilename = gg_define_char_star(); cbl_field_t *field_of_name = symbol_field_forward(file->filename); if( field_of_name->type == FldForward ) diff --git a/gcc/cobol/lexio.h b/gcc/cobol/lexio.h index b648997b35c4..222a831fe6d4 100644 --- a/gcc/cobol/lexio.h +++ b/gcc/cobol/lexio.h @@ -168,9 +168,9 @@ struct filespan_t : public bytespan_t { if( nul != eol ) { if( std::any_of( nul, eodata, []( char ch ) { return ch != '\0'; } ) ) { - int icol2 = nul - cur; + int icol = nul - cur; fprintf(stderr, "%s:%d:%d: error: NUL character detected in input\n%*s\n", - cobol_filename(), int(iline + 1), ++icol2, + cobol_filename(), int(iline + 1), ++icol, int(eol - cur), cur); parse_error_inc(); std::replace(nul, eol, '\0', SPACE); diff --git a/gcc/cobol/parse.y b/gcc/cobol/parse.y index 7ad7fa3d4803..05ce448f7036 100644 --- a/gcc/cobol/parse.y +++ b/gcc/cobol/parse.y @@ -789,7 +789,7 @@ class locale_tgt_t { %type <field> data_descr data_descr1 write_what file_record %type <field> name88 %type <refer> advancing advance_by -%type <refer> alphaval alpha_val numeref scalar scalar88 +%type <refer> alphaval alpha_val numeref scalar scalar88 scalar_any %type <refer> tableref tableish %type <refer> varg varg1 varg1a start_after start_pos %type <refer> expr expr_term compute_expr free_tgt by_value_arg @@ -2367,15 +2367,19 @@ assign_clause: ASSIGN to selected_name[selected] { $$.file = new cbl_file_t(protofile); $$.file->filename = field_index($selected->field); } - | ASSIGN to device_name USING name { + | ASSIGN to device_name[dev] USING name { $$.clause = assign_clause_e; - cbl_unimplemented("ASSIGN TO DEVICE"); - YYERROR; + $$.file = new cbl_file_t(protofile); + $$.file->assign($dev.id); + $$.file->filename = field_index($name); } - | ASSIGN to device_name { + | ASSIGN to device_name[dev] { $$.clause = assign_clause_e; - cbl_unimplemented("ASSIGN TO DEVICE"); - YYERROR; + $$.file = new cbl_file_t(protofile); + $$.file->assign($dev.id); + if( $$.file->org == file_disorganized_e ) { + $$.file->org = file_sequential_e; + } } | ASSIGN USING name { $$.clause = assign_clause_e; @@ -3047,26 +3051,6 @@ dev_mnemonic: device_name is NAME cbl_special_name_t special = { $1.token, $1.id }; if( !namcpy(@NAME, special.name, $NAME) ) YYERROR; - const char *filename; - - switch( special.id ) { - case STDIN_e: case SYSIN_e: case SYSIPT_e: - filename = "/dev/stdin"; - break; - case STDOUT_e: case SYSOUT_e: - case SYSLIST_e: case SYSLST_e: case CONSOLE_e: - filename ="/dev/stdout"; - break; - case STDERR_e: case SYSPUNCH_e: case SYSPCH_e: case SYSERR_e: - filename ="/dev/stderr"; - break; - default: - filename ="/dev/null"; - break; - } - - special.filename = symbol_index(symbol_literalA(0, filename)); - symbol_special_add(PROGRAM, &special); } | NAME[device] is NAME[name] @@ -7352,7 +7336,17 @@ true_false: TRUE_kw { $$ = TRUE_kw; } | FALSE_kw { $$ = FALSE_kw; } ; -scalar: tableref { +scalar: scalar_any { + if( was_fd_name($1->field) ) { + if( dialect_ok(@1, IbmCallFd, "CALL USING FD unimplemented") ) { + // No other COBOL compiler interprets the FD as a buffer. This feature + // requires further development. + warn_msg(@1, "CALL USING FD passes file buffer, not handle"); + } + } + } + ; +scalar_any: tableref { // Check for missing subscript; others already checked. if( $1->nsubscript() == 0 && 0 < dimensions($1->field) ) { subscript_dimension_error(@1, 0, $$); @@ -8879,33 +8873,29 @@ read_file: READ read_body { } ; -read_body: NAME read_next read_into read_key +read_body: filename[file] read_next read_into read_key { statement_begin(@$, READ); - struct symbol_elem_t *e = symbol_file(PROGRAM, $NAME); - if( !e ) { - error_msg(@1, "invalid file name '%s'", $NAME); - YYERROR; - } - $$ = cbl_file_of(e); + $$ = $file; struct cbl_field_t *record = symbol_file_record($$); if( !record ) { - error_msg(@1, "syntax error? invalid file record name"); + error_msg(@file, "syntax error? invalid file record name"); YYERROR; } + if( $read_key->field && is_sequential($$) ) { - error_msg(@1, "SEQUENTIAL file %s has no KEY", $$->name); + error_msg(@file, "SEQUENTIAL file %s has no KEY", $$->name); YYERROR; } if( $$->org == file_line_sequential_e && $read_next == -2 ) { - error_msg(@1, "LINE SEQUENTIAL file %s cannot READ PREVIOUS", + error_msg(@file, "LINE SEQUENTIAL file %s cannot READ PREVIOUS", $$->name); YYERROR; } if( $read_key->field && $read_next < 0 ) { - error_msg(@1, "cannot read NEXT with KEY %qs", $$->name); + error_msg(@file, "cannot read NEXT with KEY %qs", $$->name); YYERROR; } @@ -10123,8 +10113,6 @@ filename: NAME | device_name[dev] { auto dev = symbol_special($dev.id); - error_msg(@dev, "invalid device %qs: FD name required", dev->name); - YYERROR; auto e = symbol_file(PROGRAM, dev->name); if( ! e ) { error_msg(@dev, "no FD selected for device '%s'", dev->name); @@ -10752,8 +10740,8 @@ ffi_by_val: by_value_arg } ; -scalar_arg: scalar - | scalar AS FIXED LENGTH %prec NAME +scalar_arg: scalar_any + | scalar_any AS FIXED LENGTH %prec NAME ; call_excepts: call_excepts[a] call_except[b] statements %prec CALL @@ -13102,12 +13090,13 @@ verify_figconst( enum cbl_figconst_t figconst , size_t pos ) { static size_t constant_index( int token ) { switch(token) { + // These tokens refer to constants at fixed positions in the symbol table. case SPACES : return 0; - case LOW_VALUES : return verify_figconst(low_value_e, 2); - case ZERO : return verify_figconst(zero_value_e, 3); - case HIGH_VALUES : return verify_figconst(high_value_e, 4); - case QUOTES : return 5; - case NULLS : return 6; + case LOW_VALUES : return verify_figconst(low_value_e, 1); + case ZERO : return verify_figconst(zero_value_e, 2); + case HIGH_VALUES : return verify_figconst(high_value_e, 3); + case QUOTES : return 4; + case NULLS : return 5; } cbl_errx( "%s:%d: no such constant %d", __func__, __LINE__, token); return (size_t)-1; @@ -14630,16 +14619,6 @@ void parser_add_declaratives( size_t n, cbl_declarative_t *declaratives) { cbl_field_t * new_literal( const cbl_loc_t loc, const literal_t& lit, enum cbl_field_attr_t attr ) { - bool zstring = lit.prefix[0] == 'Z'; - if( !zstring && lit.data[lit.len] != '\0' ) { - dbgmsg("%s:%d: line %d, no NUL terminator '%-*.*s'{" - HOST_SIZE_T_PRINT_UNSIGNED "/" HOST_SIZE_T_PRINT_UNSIGNED "}", - __func__, __LINE__, yylineno, - int(lit.len), int(lit.len), - lit.data, (fmt_size_t)strlen(lit.data), (fmt_size_t)lit.len); - } - assert(zstring || lit.data[lit.len] == '\0'); - size_t attrs(attr); attrs |= constant_e; attrs |= literal_attr(lit.prefix); diff --git a/gcc/cobol/parse_ante.h b/gcc/cobol/parse_ante.h index 492acb677dc2..097d8f621731 100644 --- a/gcc/cobol/parse_ante.h +++ b/gcc/cobol/parse_ante.h @@ -2896,13 +2896,6 @@ field_find( cbl_loc_t loc, const std::list<const char *>& names ) { } } symbol_elem_t *e = symbol_find(names); - if( e && SymField == e->type && was_fd_name(cbl_field_of(e)) ) { - if( dialect_ok(loc, IbmCallFd, "CALL USING FD unimplemented") ) { - // No other COBOL compiler interprets the FD as a buffer. This feature - // requires further development. - warn_msg(loc, "CALL USING FD passes file buffer, not handle"); - } - } return e? cbl_field_of(e) : NULL; } @@ -3606,9 +3599,8 @@ data_division_ready() { if( (nsymbol = symbols_update(nsymbol, nparse_error == 0)) > 0 ) { if( ! mode_syntax_only() ) { if( ! literally_one ) { - // Use strdup so cbl_field_t::internalize can free them if need be. - literally_one = new_constant(xstrdup("1")); - literally_zero = new_constant(xstrdup("0")); + literally_one = register_find("_literally_one"); + literally_zero = register_find("_literally_zero"); } } else { nsymbol = again; diff --git a/gcc/cobol/scan.l b/gcc/cobol/scan.l index 551b1e962098..fedb85e502c4 100644 --- a/gcc/cobol/scan.l +++ b/gcc/cobol/scan.l @@ -322,14 +322,14 @@ PROCEDURE{SPC}DIVISION { yy_push_state(procedure_div); (IS{SPC})?">=" { return GE; } (IS{SPC})?">" { return '>'; } - {LESS_THAN} { return '<'; } + {LESS_THAN}/[[:space:]] { return '<'; } {LESS_THAN}{SPC}{OR_EQUAL}/[[:space:]] { return LE; } (IS{SPC})?EQUALS?({SPC}TO)?/[[:space:]] { static char eq[] = "EQUAL"; ydflval.string = yylval.string = eq; return EQ; } {GREATER_THAN}{SPC}{OR_EQUAL}/[[:space:]] { return GE; } - {GREATER_THAN} { return '>'; } + {GREATER_THAN}/[[:space:]] { return '>'; } {ISNT}{OSPC}">=" { verify_ws(yytext[yyleng - 3]); return '<'; } {ISNT}{OSPC}">" { verify_ws(yytext[yyleng - 2]); return LE; } @@ -337,11 +337,11 @@ PROCEDURE{SPC}DIVISION { yy_push_state(procedure_div); {ISNT}{OSPC}"<" { verify_ws(yytext[yyleng - 2]); return GE; } {ISNT}{OSPC}"<=" { verify_ws(yytext[yyleng - 3]); return '>'; } - {ISNT}{SPC}GREATER{SPC}(THAN)?{SPC}{OR_EQUAL}/[[:space:]] { return '<'; } - {ISNT}{SPC}GREATER{SPC}(THAN)? { return LE; } - {ISNT}{SPC}EQUALS?{SPC}(TO)? { return NE; } - {ISNT}{SPC}LESS{SPC}(THAN)? { return GE; } - {ISNT}{SPC}LESS{SPC}(THAN)?{SPC}{OR_EQUAL}/[[:space:]] { return '>'; } + {ISNT}{SPC}GREATER({SPC}THAN)?{SPC}{OR_EQUAL}/[[:space:]] { return '<'; } + {ISNT}{SPC}GREATER({SPC}THAN)?/[[:space:]] { return LE; } + {ISNT}{SPC}EQUALS?({SPC}TO)?/[[:space:]] { return NE; } + {ISNT}{SPC}LESS({SPC}THAN)?/[[:space:]] { return GE; } + {ISNT}{SPC}LESS({SPC}THAN)?{SPC}{OR_EQUAL}/[[:space:]] { return '>'; } [*]{2} { return POW; } @@ -791,7 +791,7 @@ GROUP { return GROUP; } GOBACK { return GOBACK; } BEAT-FEET { return GOBACK; } -GO({SPC}TO)? { return GOTO; } +GO({SPC}TO)?/[[:space:]] { return GOTO; } GLOBAL { return GLOBAL; } GIVING { return GIVING; } @@ -1115,11 +1115,11 @@ USE({SPC}FOR)? { return USE; } NULLS? { return NULLS; } OF { return OF; } - VALUE({SPC}IS)? { return VALUE; } - VALUES({SPC}ARE)? { return VALUE; } + VALUE({SPC}IS)?/[[:space:]] { return VALUE; } + VALUES({SPC}ARE)?/[[:space:]] { return VALUE; } THRU|THROUGH { return THRU; } - VALUES?({SPC}(IS|ARE))?{SPC}NULLS? { return NULLPTR; } + VALUES?({SPC}(IS|ARE))?{SPC}NULLS? { return NULLPTR; } VALUES?({SPC}(IS|ARE))?/{SPC}[+-]?{dfc} { yy_push_state(numeric_state); return VALUE; } @@ -1688,7 +1688,7 @@ USE({SPC}FOR)? { return USE; } SORT { return SORT; } SORT-MERGE { return SORT_MERGE; } SOURCE { return SOURCE; } - SPACE { return SPACE; } + SPACE { return SPACES; } SPACES { return SPACES; } SPECIAL-NAMES { return SPECIAL_NAMES; } STANDARD { return STANDARD; } @@ -2279,6 +2279,11 @@ USE({SPC}FOR)? { return USE; } yylval.string = name; pop_return NAME; } + {PREFIX}?[''] { yylval.literal.set_prefix(yytext, yyleng-1); + BEGIN(quoted1); } + {PREFIX}?[""] { yylval.literal.set_prefix(yytext, yyleng-1); + BEGIN(quoted2); } + } /* diff --git a/gcc/cobol/scan_ante.h b/gcc/cobol/scan_ante.h index 2a17a8102b33..c3f466070881 100644 --- a/gcc/cobol/scan_ante.h +++ b/gcc/cobol/scan_ante.h @@ -462,7 +462,7 @@ update_location( const cbl_loc_t *ploc = nullptr ) { ydflloc = yylloc = loc; - dbgmsg(" SC: %s location (%d,%d) to (%d,%d)", + dbgmsg(" SC: <%s> (%d,%d) to (%d,%d)", start_condition_is(), yylloc.first_line, yylloc.first_column, yylloc.last_line, yylloc.last_column); diff --git a/gcc/cobol/symbols.cc b/gcc/cobol/symbols.cc index da0ca7448ea5..e9a0e2bb0a01 100644 --- a/gcc/cobol/symbols.cc +++ b/gcc/cobol/symbols.cc @@ -97,7 +97,7 @@ static struct symbol_table_t { size_t file_status, linage_counter, exception_condition, very_true, very_false; registers_t() { - file_status = linage_counter = + file_status = linage_counter = exception_condition = very_true = very_false = 0; } } registers; @@ -308,8 +308,6 @@ class group_size_t { size_t capacity() const { return size; } }; -#define constq (constant_e | quoted_e) - static symbol_elem_t elementize( const cbl_field_t& field ) { symbol_elem_t sym (SymField); @@ -442,15 +440,15 @@ static bool label_cmp( const cbl_label_t& key, case LblParagraph: switch( elem.type ) { case LblNone: - // dbgmsg("%s:%d: para %s: key parent %zu, LblNone elem parent %zu", __func__, __LINE__, + // dbgmsg("%s:%d: para %s: key parent %zu, LblNone elem parent %zu", __func__, __LINE__, // key.name, key.parent, elem.parent); // Undefined label element with matching parent or no parent. - if( key.parent == elem.parent || elem.parent == 0 ) { + if( key.parent == elem.parent || elem.parent == 0 ) { return key.line == 0 || elem.line == 0 || key.line == elem.line; } break; case LblParagraph: - // dbgmsg("%s:%d: para %s: key parent %zu, elem parent %zu", __func__, __LINE__, + // dbgmsg("%s:%d: para %s: key parent %zu, elem parent %zu", __func__, __LINE__, // key.name, key.parent, elem.parent); if( key.parent == 0 || key.parent == elem.parent ) { // explicit or implicit return key.line == 0 || elem.line == 0 || key.line == elem.line; @@ -546,8 +544,16 @@ symbol_elem_cmp( const void *K, const void *E ) if( (cbl_file_of(k)->attr & global_e) == global_e && (cbl_file_of(e)->attr & global_e) != global_e ) { return 1; + } else { + if( 0 == strcasecmp(k->elem.file.name, e->elem.file.name) ) return 0; + // User may refer to a Device name (e.g. SYSIN) aliased to the FD name via SELECT. + auto file = cbl_file_of(e); + if( file->device != 0 ) { + auto dev = cbl_special_name_of(symbol_at(file->device)); + return strcasecmp(k->elem.file.name, dev->name); + } + return 1; } - return strcasecmp(k->elem.file.name, e->elem.file.name); break; } assert(k->type == SymField); @@ -648,7 +654,7 @@ symbols_dump( size_t first, bool header ); enum protoreq_t { proto_required_e, proto_allowed_e, - proto_disallowed_e, + proto_disallowed_e, }; static struct symbol_elem_t * @@ -844,7 +850,7 @@ cbl_field_t::clear_attr( cbl_field_attr_t attr ) { } // Test various ways a Numeric Edited picture can describe a signed value. -uint64_t +uint64_t cbl_field_t::set_signable() { gcc_assert(type == FldNumericEdited); gcc_assert(data.picture); @@ -1144,8 +1150,8 @@ symbols_dump( size_t first, bool header ) { auto p = prototype_args(L.name); unsigned long narg = p.second? p.first.size() : 0; char *base = s; - s = xasprintf("%s (%s%zu args)", base, - L.prototype? "prototype, " : "", + s = xasprintf("%s (%s%zu args)", base, + L.prototype? "prototype, " : "", narg); free(base); } @@ -1536,7 +1542,7 @@ cbl_field_t::attr_str( const std::vector<cbl_field_attr_t>& attrs ) const const char *sep = ""; char *out = NULL; uint64_t mask = cbl_field_attr_t(-1); - + for( auto attr_l : attrs ) { char *part = out; if( has_attr(attr_l) && (attr_l & mask) == attr_l) { @@ -1641,7 +1647,7 @@ field_str( const cbl_field_t *field ) { if( field->attr & local_e ) storage_type = 'w'; // because 'l' hard to read static const std::vector<cbl_field_attr_t> attrs { - strongdef_e, typedef_e, + strongdef_e, typedef_e, figconst_1_e, figconst_2_e, figconst_4_e, rjust_e, ljust_e, zeros_e, signable_e, constant_e, function_e, quoted_e, filler_e, intermediate_e, embiggened_e, all_alpha_e, all_x_e, @@ -1649,7 +1655,7 @@ field_str( const cbl_field_t *field ) { /* global_e, external_e, */ blank_zero_e, /* linkage_e, local_e, */ leading_e, separate_e, envar_e, encoded_e, bool_encoded_e, hex_encoded_e, depends_on_e, /* initialized_e, */ has_value_e, ieeedec_e, big_endian_e, - same_as_e, record_key_e, + same_as_e, record_key_e, }; pend += snprintf(pend, string + sizeof(string) - pend, @@ -1992,7 +1998,7 @@ symbols_update( size_t first, bool parsed_ok ) { } // This test is a little too broad, but avoids a special attribute bit for - // things like the XML registers. The tests are only internal checks anyway. + // things like the XML registers. The tests are only internal checks anyway. if( ! (is_numeric(field) || field->has_attr(register_e) || field->has_attr(global_e)) ) { @@ -2337,6 +2343,33 @@ add_token( symbol_elem_t sym ) { const std::list<cbl_field_t> cdf_literalize(); +static +cbl_field_attr_t endian_bit() + { + cbl_field_attr_t retval; + if( cobol_target_big_endian() ) // cppcheck-suppress knownConditionTrueFalse + { + retval = big_endian_e; + } + else + { + volatile int always_one = 1; + /* This tortured construction prevents cppcheck from pointing out that + endian_bit() always returns zero on a little-endian machine, which is + redundant in a "register_e | endian_bit()" expression. */ + if( always_one ) + { + retval = none_e; + } + else + { + gcc_unreachable(); + retval = big_endian_e; + } + } + return retval; + } + /* * When adding special registers, be sure to create the actual cblc_field_t * in libgcobol/constants.cc. @@ -2358,25 +2391,27 @@ symbol_table_init(void) { // These should match the definitions in libgcobol/constants.cc static cbl_field_t constants[] = { - { FldAlphanumeric, SPACE_VALUE_E | constq | register_e, - {1,1,0,0, " \0\xFF"}, 0, "SPACE", cp1252 }, - { FldAlphanumeric, SPACE_VALUE_E | constq | register_e, + { FldAlphanumeric, quoted_e | constant_e | register_e | space_value_e, {1,1,0,0, " \0\xFF"}, 0, "SPACES", cp1252 }, - { FldAlphanumeric, LOW_VALUE_E | constq | register_e, + { FldAlphanumeric, quoted_e | constant_e | register_e | low_value_e, {1,1,0,0, "L\0\xFF"}, 0, "LOW_VALUES", cp1252 }, - { FldAlphanumeric, ZERO_VALUE_E | constq | register_e, + { FldAlphanumeric, quoted_e | constant_e | register_e | zero_value_e, {1,1,0,0, "0"}, 0, "ZEROS", cp1252 }, // Don't change "ZEROS"; there are // things that depend on it. - { FldAlphanumeric, HIGH_VALUE_E | constq | register_e, + { FldAlphanumeric, quoted_e | constant_e | register_e | high_value_e, {1,1,0,0, "H\0\xFF"}, 0, "HIGH_VALUES", cp1252 }, // IBM standard: QUOTE is a double-quote unless APOST compiler option - { FldAlphanumeric, QUOTE_VALUE_E | constq | register_e , + { FldAlphanumeric, quoted_e | constant_e | register_e | quote_value_e , {1,1,0,0, "\"\0\xFF"}, 0, "QUOTES", cp1252 }, - { FldPointer, constq | register_e , + { FldPointer, constant_e | register_e | null_value_e , {8,8,0,0, zeroes_for_null_pointer}, 0, "NULLS", cp1252 }, // 01 ARGI is the current index into the argv array - { FldNumericBin5, signable_e | register_e, - {16, 16, MAX_FIXED_POINT_DIGITS, 0, NULL}, 0, "_ARGI", cp1252 }, + { FldNumericBin5, signable_e | register_e | endian_bit(), + {4, 4, 0, 0, NULL}, 0, "_ARGI", cp1252 }, + { FldNumericBin5, constant_e | register_e | endian_bit(), + {4, 4, 0, 0, NULL}, 0, "_literally_zero", cp1252 }, + { FldNumericBin5, constant_e | register_e | endian_bit(), + {4, 4, 0, 0, NULL}, 0, "_literally_one", cp1252 }, // These last two don't require actual storage; they get BOOL var_decl_node // in parser_symbol_add() @@ -2396,41 +2431,41 @@ symbol_table_init(void) { } static symbol_elem_t environs[] = { - { symbol_elem_t{ 0, cbl_special_name_t{0, CONSOLE_e, "CONSOLE", 0, "/dev/stdout"}} }, // stdout in DISPLAY; stdin in ACCEPT - - { symbol_elem_t{ 0, cbl_special_name_t{0, STDIN_e, "STDIN", 0, "/dev/stdin"}} }, - { symbol_elem_t{ 0, cbl_special_name_t{0, SYSIN_e, "SYSIN", 0, "/dev/stdin"}} }, - { symbol_elem_t{ 0, cbl_special_name_t{0, SYSIPT_e, "SYSIPT", 0, "/dev/stdin"}} }, - - { symbol_elem_t{ 0, cbl_special_name_t{0, STDOUT_e, "STDOUT", 0, "/dev/stdout"}} }, - { symbol_elem_t{ 0, cbl_special_name_t{0, SYSOUT_e, "SYSOUT", 0, "/dev/stdout"}} }, - { symbol_elem_t{ 0, cbl_special_name_t{0, SYSLIST_e, "SYSLIST", 0, "/dev/stdout"}} }, - { symbol_elem_t{ 0, cbl_special_name_t{0, SYSLST_e, "SYSLST", 0, "/dev/stdout"}} }, - - { symbol_elem_t{ 0, cbl_special_name_t{0, SYSPUNCH_e, "SYSPUNCH", 0, "/dev/stderr"}} }, - { symbol_elem_t{ 0, cbl_special_name_t{0, SYSPCH_e, "SYSPCH", 0, "/dev/stderr"}} }, - { symbol_elem_t{ 0, cbl_special_name_t{0, STDERR_e, "STDERR", 0, "/dev/stderr"}} }, - { symbol_elem_t{ 0, cbl_special_name_t{0, SYSERR_e, "SYSERR", 0, "/dev/stderr"}} }, - - { symbol_elem_t{ 0, cbl_special_name_t{0, C01_e, "C01", 0, "/dev/null"}} }, - { symbol_elem_t{ 0, cbl_special_name_t{0, C02_e, "C02", 0, "/dev/null"}} }, - { symbol_elem_t{ 0, cbl_special_name_t{0, C03_e, "C03", 0, "/dev/null"}} }, - { symbol_elem_t{ 0, cbl_special_name_t{0, C04_e, "C04", 0, "/dev/null"}} }, - { symbol_elem_t{ 0, cbl_special_name_t{0, C05_e, "C05", 0, "/dev/null"}} }, - { symbol_elem_t{ 0, cbl_special_name_t{0, C06_e, "C06", 0, "/dev/null"}} }, - { symbol_elem_t{ 0, cbl_special_name_t{0, C07_e, "C07", 0, "/dev/null"}} }, - { symbol_elem_t{ 0, cbl_special_name_t{0, C08_e, "C08", 0, "/dev/null"}} }, - { symbol_elem_t{ 0, cbl_special_name_t{0, C09_e, "C09", 0, "/dev/null"}} }, - { symbol_elem_t{ 0, cbl_special_name_t{0, C10_e, "C10", 0, "/dev/null"}} }, - { symbol_elem_t{ 0, cbl_special_name_t{0, C11_e, "C11", 0, "/dev/null"}} }, - { symbol_elem_t{ 0, cbl_special_name_t{0, C12_e, "C12", 0, "/dev/null"}} }, - { symbol_elem_t{ 0, cbl_special_name_t{0, CSP_e, "CSP", 0, "/dev/null"}} }, - { symbol_elem_t{ 0, cbl_special_name_t{0, S01_e, "S01", 0, "/dev/null"}} }, - { symbol_elem_t{ 0, cbl_special_name_t{0, S02_e, "S02", 0, "/dev/null"}} }, - { symbol_elem_t{ 0, cbl_special_name_t{0, S03_e, "S03", 0, "/dev/null"}} }, - { symbol_elem_t{ 0, cbl_special_name_t{0, S04_e, "S04", 0, "/dev/null"}} }, - { symbol_elem_t{ 0, cbl_special_name_t{0, S05_e, "S05", 0, "/dev/null"}} }, - { symbol_elem_t{ 0, cbl_special_name_t{0, AFP_5A_e, "AFP-5A", 0, "/dev/null"}} }, + { symbol_elem_t{ 0, cbl_special_name_t{0, CONSOLE_e, "CONSOLE", "/dev/stdout"}} }, // stdout in DISPLAY; stdin in ACCEPT + + { symbol_elem_t{ 0, cbl_special_name_t{0, STDIN_e, "STDIN", "/dev/stdin"}} }, + { symbol_elem_t{ 0, cbl_special_name_t{0, SYSIN_e, "SYSIN", "/dev/stdin"}} }, + { symbol_elem_t{ 0, cbl_special_name_t{0, SYSIPT_e, "SYSIPT", "/dev/stdin"}} }, + + { symbol_elem_t{ 0, cbl_special_name_t{0, STDOUT_e, "STDOUT", "/dev/stdout"}} }, + { symbol_elem_t{ 0, cbl_special_name_t{0, SYSOUT_e, "SYSOUT", "/dev/stdout"}} }, + { symbol_elem_t{ 0, cbl_special_name_t{0, SYSLIST_e, "SYSLIST", "/dev/stdout"}} }, + { symbol_elem_t{ 0, cbl_special_name_t{0, SYSLST_e, "SYSLST", "/dev/stdout"}} }, + + { symbol_elem_t{ 0, cbl_special_name_t{0, SYSPUNCH_e, "SYSPUNCH", "/dev/stderr"}} }, + { symbol_elem_t{ 0, cbl_special_name_t{0, SYSPCH_e, "SYSPCH", "/dev/stderr"}} }, + { symbol_elem_t{ 0, cbl_special_name_t{0, STDERR_e, "STDERR", "/dev/stderr"}} }, + { symbol_elem_t{ 0, cbl_special_name_t{0, SYSERR_e, "SYSERR", "/dev/stderr"}} }, + + { symbol_elem_t{ 0, cbl_special_name_t{0, C01_e, "C01", "/dev/null"}} }, + { symbol_elem_t{ 0, cbl_special_name_t{0, C02_e, "C02", "/dev/null"}} }, + { symbol_elem_t{ 0, cbl_special_name_t{0, C03_e, "C03", "/dev/null"}} }, + { symbol_elem_t{ 0, cbl_special_name_t{0, C04_e, "C04", "/dev/null"}} }, + { symbol_elem_t{ 0, cbl_special_name_t{0, C05_e, "C05", "/dev/null"}} }, + { symbol_elem_t{ 0, cbl_special_name_t{0, C06_e, "C06", "/dev/null"}} }, + { symbol_elem_t{ 0, cbl_special_name_t{0, C07_e, "C07", "/dev/null"}} }, + { symbol_elem_t{ 0, cbl_special_name_t{0, C08_e, "C08", "/dev/null"}} }, + { symbol_elem_t{ 0, cbl_special_name_t{0, C09_e, "C09", "/dev/null"}} }, + { symbol_elem_t{ 0, cbl_special_name_t{0, C10_e, "C10", "/dev/null"}} }, + { symbol_elem_t{ 0, cbl_special_name_t{0, C11_e, "C11", "/dev/null"}} }, + { symbol_elem_t{ 0, cbl_special_name_t{0, C12_e, "C12", "/dev/null"}} }, + { symbol_elem_t{ 0, cbl_special_name_t{0, CSP_e, "CSP", "/dev/null"}} }, + { symbol_elem_t{ 0, cbl_special_name_t{0, S01_e, "S01", "/dev/null"}} }, + { symbol_elem_t{ 0, cbl_special_name_t{0, S02_e, "S02", "/dev/null"}} }, + { symbol_elem_t{ 0, cbl_special_name_t{0, S03_e, "S03", "/dev/null"}} }, + { symbol_elem_t{ 0, cbl_special_name_t{0, S04_e, "S04", "/dev/null"}} }, + { symbol_elem_t{ 0, cbl_special_name_t{0, S05_e, "S05", "/dev/null"}} }, + { symbol_elem_t{ 0, cbl_special_name_t{0, AFP_5A_e, "AFP-5A", "/dev/null"}} }, }; struct symbol_elem_t *p = table.elems + table.nelem; @@ -2501,13 +2536,20 @@ symbol_table_init(void) { // special registers static cbl_field_t special_registers[] = { - { FldNumericDisplay, register_e, {2,2,2,0, NULL}, 0, "_FILE_STATUS", cp1252 }, - { FldNumericBin5, register_e, {2,2,4,0, NULL}, 0, "UPSI-0", cp1252 }, - { FldNumericBin5, global_e, {2,2,4,0, NULL}, 0, "LINAGE-COUNTER", cp1252 }, - { FldLiteralA, register_e, {0,0,0,0, "/dev/stdin"}, 0, "_dev_stdin", cp1252 }, - { FldLiteralA, constq|register_e, {0,0,0,0, "/dev/stdout"}, 0, "_dev_stdout", cp1252 }, - { FldLiteralA, constq|register_e, {0,0,0,0, "/dev/stderr"}, 0, "_dev_stderr", cp1252 }, - { FldLiteralA, constq|register_e, {0,0,0,0, "/dev/null"}, 0, "_dev_null", cp1252 }, + { FldNumericDisplay, register_e, + {2,2,2,0, NULL}, 0, "_FILE_STATUS", cp1252 }, + { FldNumericBin5, register_e | endian_bit(), + {2,2,4,0, NULL}, 0, "UPSI-0", cp1252 }, + { FldNumericBin5, global_e | endian_bit(), + {2,2,4,0, NULL}, 0, "LINAGE-COUNTER", cp1252 }, + { FldLiteralA, constant_e|quoted_e|register_e, + {0,0,0,0, "/dev/stdin"}, 0, "_dev_stdin", cp1252 }, + { FldLiteralA, constant_e|quoted_e|register_e, + {0,0,0,0, "/dev/stdout"}, 0, "_dev_stdout", cp1252 }, + { FldLiteralA, constant_e|quoted_e|register_e, + {0,0,0,0, "/dev/stderr"}, 0, "_dev_stderr", cp1252 }, + { FldLiteralA, constant_e|quoted_e|register_e, + {0,0,0,0, "/dev/null"}, 0, "_dev_null", cp1252 }, }; assert(table.nelem + COUNT_OF(special_registers) < table.capacity); @@ -2519,7 +2561,7 @@ symbol_table_init(void) { table.nelem = p - table.elems; assert(table.nelem < table.capacity); - // Add any CDF values defined on the command line. + // Add any CDF values defined on the command line. // After symbols are ready, the CDF adds them directly. const std::list<cbl_field_t> cdf_values = cdf_literalize(); auto icdf = table.nelem; @@ -2540,7 +2582,7 @@ symbol_table_init(void) { f.set_initial(cbl_loc_t()); } } - + for( auto e = symbols.elems; e < symbols.elems + symbols.nelem; e++ ) { if( e->type == SymField ) { update_symbol_map2(e); @@ -2602,6 +2644,8 @@ symbol_registers_add() { const static cbl_field_t::codeset_t cp1252(CP1252_e); const static auto based_any = cbl_field_attr_t(global_e | based_e | any_length_e); const static auto glosig = cbl_field_attr_t(global_e | signable_e); + const static auto native = glosig | endian_bit(); + // The data.initial of these fields is used verbatim by parser_symbol_add. const static char zero[4] = {0}; static char spc[160] = " "; @@ -2609,7 +2653,7 @@ symbol_registers_add() { if( spc[1] != 0x20 ) { std::fill( spc, spc + sizeof(spc), 0x20 ); } - + /* In the following table, the FldNumericBin5 initial values are strings with NUL characters in them. That's because this table bypasses the encode_numeric function and the values are passed directly to parser_symbol_add(), which @@ -2617,24 +2661,24 @@ symbol_registers_add() { memory representation of the run-time variable. */ static const cbl_field_t ibm_registers[] = { -#if COBOL_JSON_READY - { FldNumericBin5, glosig, {4,4,5,0, zero }, 0, "JSON-CODE", cp1252 }, - { FldNumericBin5, glosig, {4,4,5,0, zero }, 0, "JSON-STATUS", cp1252 }, +#if COBOL_JSON_READY + { FldNumericBin5, native, {4,4,5,0, zero }, 0, "JSON-CODE", cp1252 }, + { FldNumericBin5, native, {4,4,5,0, zero }, 0, "JSON-STATUS", cp1252 }, #endif - { FldNumericBin5, glosig, {2,2,4,0, zero }, 0, "RETURN-CODE", cp1252 }, + { FldNumericBin5, native, {2,2,4,0, zero }, 0, "RETURN-CODE", cp1252 }, { FldAlphanumeric, glosig, {160,160,0,0, spc }, 0, "SORT-CONTROL", cp1252 }, - { FldNumericBin5, glosig, {4,4,5,0, zero }, 0, "SORT-CORE-SIZE", cp1252 }, - { FldNumericBin5, glosig, {4,4,5,0, zero }, 0, "SORT-FILE-SIZE", cp1252 }, + { FldNumericBin5, native, {4,4,5,0, zero }, 0, "SORT-CORE-SIZE", cp1252 }, + { FldNumericBin5, native, {4,4,5,0, zero }, 0, "SORT-FILE-SIZE", cp1252 }, { FldAlphanumeric, global_e, {8,8,0,0, spc }, 0, "SORT-MESSAGE", cp1252 }, - { FldNumericBin5, glosig, {4,4,5,0, zero }, 0, "SORT-MODE-SIZE", cp1252 }, - { FldNumericBin5, glosig, {4,4,5,0, zero }, 0, "SORT-RETURN", cp1252 }, + { FldNumericBin5, native, {4,4,5,0, zero }, 0, "SORT-MODE-SIZE", cp1252 }, + { FldNumericBin5, native, {4,4,5,0, zero }, 0, "SORT-RETURN", cp1252 }, // 01 TALLY GLOBAL PICTURE 9(5) USAGE BINARY VALUE ZERO. { FldNumericBin5, global_e, {4,4,5,0, zero }, 0, "_TALLY", cp1252 }, { FldAlphanumeric, global_e, {16,16,0,0, spc }, 0, "WHEN-COMPILED", cp1252 }, // xml registers - { FldNumericBin5, glosig, {4,4,9,0, zero }, 0, "XML-CODE", cp1252 }, + { FldNumericBin5, native, {4,4,9,0, zero }, 0, "XML-CODE", cp1252 }, { FldAlphanumeric, global_e, {30,30,0,0, spc }, 0, "XML-EVENT", cp1252 }, - { FldNumericBin5, glosig, {4,4,9,0, zero }, 0, "XML-INFORMATION", cp1252 }, + { FldNumericBin5, native, {4,4,9,0, zero }, 0, "XML-INFORMATION", cp1252 }, { FldAlphanumeric, based_any, {1,1,0,0, nullptr }, 0, "XML-NAMESPACE", cp1252 }, { FldAlphanumeric, based_any, {1,1,0,0, nullptr }, 0, "XML-NNAMESPACE", cp1252 }, { FldAlphanumeric, based_any, {1,1,0,0, nullptr }, 0, "XML-NAMESPACE-PREFIX", cp1252 }, @@ -2657,7 +2701,7 @@ symbol_registers_add() { const cbl_label_t * cbl_perform_tgt_t::recurses( const cbl_label_t *para __attribute__ ((unused)), - const cbl_label_t *sect __attribute__ ((unused)) ) const + const cbl_label_t *sect __attribute__ ((unused)) ) const { // Mon Jul 6 11:14:12 2026 // Decided not to enforce until we enforce EC-FLOW-IMP-RECURSION or @@ -3007,7 +3051,7 @@ symbol_literalA( size_t program, const char name[] ) cbl_field_t field = {}; field.type = FldLiteralA; field.data.initial = name; - field.attr = constq; + field.attr = constant_e | quoted_e; struct symbol_elem_t key { program, field }; @@ -3519,7 +3563,7 @@ cbl_alphabet_t::reencode( const cbl_loc_t& loc ) { UTF-32/LE/BE. What collation means in those environments is unknown to me at this time. So, for now I am simply assuming that whatever we are doing here fits into a single byte. - + So, for SBC or little-endian character sets, we just pick up the value at pos[0]. For big-endian character sets, we find the low-order byte. */ @@ -3620,7 +3664,7 @@ symbol_temporary_alphanumerics() { symbol_temporaries_t output; std::copy_if( program_temporaries.begin(), program_temporaries.end(), - std::back_inserter(output), + std::back_inserter(output), []( auto f ) { switch(f->type) { case FldAlphaEdited: @@ -3758,7 +3802,7 @@ new_literal_add( const char initial[], uint32_t len, field->attr |= attr; char *orig = static_cast<char *>(xmalloc(len+4)); - + auto p = initial? std::copy(initial, initial + len, orig) : orig; std::fill(p, p+4, 0); field->data.original(orig); @@ -4070,6 +4114,9 @@ new_temporary_clone( const cbl_field_t *orig) { if( field->type == FldNumericBin5 ) { field->type = orig->type; field->codeset = orig->codeset; + field->attr &= ~big_endian_e; + field->attr |= endian_bit(); + } field->attr = intermediate_e; @@ -4196,12 +4243,12 @@ iconv_cd( cbl_encoding_t tgt ) { iconv_key_t key(tgt, src); auto p = cds.find(key); iconv_t cd; - + if( p == cds.end() ) { const char *fromcode = __gg__encoding_iconv_name(src); - const char *tocode = __gg__encoding_iconv_name(tgt); + const char *tocode = __gg__encoding_iconv_name(tgt); gcc_assert(fromcode && tocode); - + if( (cd = helpful_iconv_open(tocode, fromcode)) == iconv_t(-1) ) { return cd; } @@ -4234,7 +4281,7 @@ cbl_field_t::encode( size_t srclen, cbl_loc_t loc ) { } extern cbl_loc_t yylloc; - + const char *bad_boy = data.original(); if( 0 == loc.first_line ) loc = level == 0 ? cbl_loc_t(yylloc) : symbol_field_location(field_index(this)); @@ -4255,13 +4302,13 @@ cbl_field_t::encode( size_t srclen, cbl_loc_t loc ) { const_cast<char*>(data.initial)); return nullptr; // may return "truncated success" with error. } - + auto figconst = cbl_figconst_of(data.original()); if( normal_value_e != figconst ) { - blank_initial( char_capacity(), figconst ); + blank_initial( char_capacity(), figconst ); return nullptr; } - + for( auto src = codeset.default_encodings.current_source_encoding(); src; src = codeset.default_encodings.next_source_encoding() ) { @@ -4279,9 +4326,9 @@ cbl_field_t::encode( size_t srclen, cbl_loc_t loc ) { xstrerror(errno)); continue; } - + /* - * If conversion succeeds, return NULL. + * If conversion succeeds, return NULL. * If it fails, try the next potential encoding. */ size_t inbytesleft = srclen, outbytesleft = data.capacity(); @@ -4299,7 +4346,7 @@ cbl_field_t::encode( size_t srclen, cbl_loc_t loc ) { // Tolerate trailing zeros for P-values if( data.rdigits < 0 ) { if( inbytesleft <= size_t(data.rdigits * -1) ) { - bool all_zeros = std::all_of(reinterpret_cast<const char*>(inbuf), + bool all_zeros = std::all_of(reinterpret_cast<const char*>(inbuf), data.original() + srclen, [](char ch) { return '0' == ch; @@ -4308,13 +4355,13 @@ cbl_field_t::encode( size_t srclen, cbl_loc_t loc ) { } } } - error_msg( loc, + error_msg( loc, "VALUE %qs is too long to initialize %qs, discarded %qs", data.original(), name, inbuf); return nullptr; // success-ish } dbgmsg("'%c' of '%s'[%lu] could not be converted from %s to %s: %s", - *inbuf, data.original(), inbuf - data.original(), + *inbuf, data.original(), inbuf - data.original(), cbl_encoding_str( codeset.default_encodings.current_source_encoding()->type), cbl_encoding_str(codeset.encoding), @@ -4370,7 +4417,7 @@ cbl_field_t::set_capacity(size_t nchar) { } else { data.capacity( capacity_cast(nchar) * codeset.stride() ); } - + } else { cbl_internal_error("%s: %s %s has invalid encoding", __func__, cbl_field_type_str(type), name); @@ -4408,7 +4455,7 @@ cbl_label_t::str() const { char *buf; switch(type) { case LblParagraph: - buf = xasprintf("%-12s %s OF #%ld %s, line %d", type_str() + 3, name, parent, + buf = xasprintf("%-12s %s OF #%ld %s, line %d", type_str() + 3, name, parent, parent? cbl_label_of(symbol_at(parent))->name : "", line); break; case LblProgram: @@ -5434,6 +5481,28 @@ cbl_file_t::keys_str() const { return xasprintf("%s", names.c_str()); } +size_t +cbl_file_t::special_index( special_name_t id ) { + cbl_special_name_t special = { 0, id }; + struct symbol_elem_t key { 0, special }, *e; + + e = static_cast<struct symbol_elem_t *>(lfind( &key, symbols.elems, + &symbols.nelem, sizeof(key), + symbol_elem_cmp ) ); + assert(e); + return symbol_index(e); +} + +const char * +cbl_file_t::filename_of() const { + if( filename != 0 ) { return cbl_field_of(symbol_at(filename))->name; } + if( device != 0 ) { + auto dev = cbl_special_name_of(symbol_at(device)); + if( dev->os_filename[0] != '\0' ) return dev->os_filename; + } + return nullptr; +} + /* * _FILE_STATUS symbols */ diff --git a/gcc/cobol/symbols.h b/gcc/cobol/symbols.h index 3bb84a11d354..2d8c9cee4585 100644 --- a/gcc/cobol/symbols.h +++ b/gcc/cobol/symbols.h @@ -1843,11 +1843,14 @@ struct cbl_locale_t { } }; +/* + * If SELECT name ASSIGN TO DEVICE is used, the index of the special name is + * assigned to cbl_file_t::device. The device itself never changes. + */ struct cbl_special_name_t { int token; enum special_name_t id; cbl_name_t name; - size_t filename; char os_filename[16]; // short because always in /dev }; @@ -2122,7 +2125,7 @@ struct cbl_file_t { // "The RECORD DELIMITER clause is syntax checked, but has no effect // on the execution of the program." enum cbl_file_access_t access; - size_t filename; // + size_t filename, device; size_t default_record; size_t nkey; // 1st key is primary & unique cbl_file_key_t *keys; // indexes into symbol table for key field(s) @@ -2156,7 +2159,7 @@ struct cbl_file_t { , optional(false) , varying_size{ false, 0, 0 } , access(file_access_seq_e) - , filename(0) + , filename(0), device(0) , default_record(0) , nkey(0) , keys(nullptr) @@ -2169,6 +2172,7 @@ struct cbl_file_t { } bool varies() const { return varying_size.min != varying_size.max; } + void assign( special_name_t device ) { this->device = special_index(device); } bool validate() const; void deforward(); cbl_file_key_t * keys_update( cbl_file_key_t * keys ) { @@ -2188,9 +2192,11 @@ struct cbl_file_t { return org == file_indexed_e && access == file_access_seq_e; } void consider_for_default( const cbl_field_t *record ); + const char * filename_of() const; protected: bool validate_forward( size_t isym ) const; bool validate_key( const cbl_file_key_t& key ) const; + static size_t special_index( special_name_t device ); }; static inline bool @@ -2856,7 +2862,6 @@ cbl_namelist_t teed_up_names(); size_t end_of_group( size_t igroup ); -symbol_elem_t * symbol_typedef( size_t program, std::list<const char *> names ); symbol_elem_t * symbol_typedef( size_t program, const char name[] ); symbol_elem_t * symbol_field( size_t program, size_t parent, const char name[] ); cbl_label_t * symbol_label( size_t program, cbl_label_type_t type, @@ -2872,6 +2877,8 @@ symbol_elem_t * symbol_literalA( size_t program, const char name[] ); cbl_special_name_t * symbol_special( special_name_t id ); symbol_elem_t * symbol_special( size_t program, const char name[] ); +size_t symbol_special_index( special_name_t device ); + symbol_elem_t * symbol_locale( size_t program, const char name[] ); symbol_elem_t * symbol_alphabet( size_t program, const char name[] ); diff --git a/gcc/testsuite/cobol.dg/group2/DEBUG-ITEM_using_mh_identical.cob b/gcc/testsuite/cobol.dg/group2/DEBUG-ITEM_using_mh_identical.cob new file mode 100644 index 000000000000..574edc93d2ff --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/DEBUG-ITEM_using_mh_identical.cob @@ -0,0 +1,52 @@ + *> { dg-do run } + *> { dg-output-file "group2/DEBUG-ITEM_using_mh_identical.out" } + identification division. + program-id. dbgline. + data division. + working-storage section. + 01 var picture is x(3). + 01 var2 picture is x(6). + 01 ws-debug-item. + 02 ws-debug-line picture is x(6) value "burp". + 02 filler picture is x value space. + 02 ws-debug-name picture is x(30). + 02 filler picture is x value space. + 02 ws-debug-sub-1 picture is s9999 + sign is leading separate character. + 02 filler picture is x value space. + 02 ws-debug-sub-2 picture is s9999 + sign is leading separate character. + 02 filler picture is x value space. + 02 ws-debug-sub-3 picture is s9999 + sign is leading separate character. + 02 filler picture is x value space. + 02 ws-debug-contents picture is x(76). + procedure division. + display "defaults" + display """" debug-line """" + display """" debug-name """" + display debug-sub-1 + display debug-sub-2 + display debug-sub-3 + display """" debug-contents """" + move "aaLINE" to ws-debug-line + move "bbNAME" to ws-debug-name + move 1234 to ws-debug-sub-1 + move -2345 to ws-debug-sub-2 + move 3456 to ws-debug-sub-3 + move "ccDebugging contents" to ws-debug-contents + move ws-debug-line to debug-line + move ws-debug-name to debug-name + move ws-debug-sub-1 to debug-sub-1 + move ws-debug-sub-2 to debug-sub-2 + move ws-debug-sub-3 to debug-sub-3 + move ws-debug-contents to debug-contents + display "after the moves" + display """" debug-line """" + display """" debug-name """" + display debug-sub-1 + display debug-sub-2 + display debug-sub-3 + display """" debug-contents """" + stop run. + diff --git a/gcc/testsuite/cobol.dg/group2/DEBUG-ITEM_using_mh_identical.out b/gcc/testsuite/cobol.dg/group2/DEBUG-ITEM_using_mh_identical.out new file mode 100644 index 000000000000..b6e305944766 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/DEBUG-ITEM_using_mh_identical.out @@ -0,0 +1,15 @@ +defaults +" " +" " ++0000 ++0000 ++0000 +" " +after the moves +"aaLINE" +"bbNAME " ++1234 +-2345 ++3456 +"ccDebugging contents " + diff --git a/gcc/testsuite/cobol.dg/group2/INITIALIZE_with_-defaultbyte__ASCII_.cob b/gcc/testsuite/cobol.dg/group2/INITIALIZE_with_-defaultbyte__ASCII_.cob index 66d3a65c99b3..09e5c8f2373a 100644 --- a/gcc/testsuite/cobol.dg/group2/INITIALIZE_with_-defaultbyte__ASCII_.cob +++ b/gcc/testsuite/cobol.dg/group2/INITIALIZE_with_-defaultbyte__ASCII_.cob @@ -19,9 +19,9 @@ 02 PHONE-NUMBER. 03 NAME PIC A(30). 03 AREA-CODE PIC 999. - 03 DASH PIC X VALUE'-'. + 03 DASH PIC X VALUE '-'. 03 PREFIX PIC 999. - 03 DASH PIC X VALUE'-'. + 03 DASH PIC X VALUE '-'. 03 LOCAL PIC 999. 77 WHO-AM-I PIC X(12). PROCEDURE DIVISION. diff --git a/gcc/testsuite/cobol.dg/group2/INITIALIZE_with_-defaultbyte__EBCDIC_.cob b/gcc/testsuite/cobol.dg/group2/INITIALIZE_with_-defaultbyte__EBCDIC_.cob index 7859b16ff3c8..e8a0cab31f84 100644 --- a/gcc/testsuite/cobol.dg/group2/INITIALIZE_with_-defaultbyte__EBCDIC_.cob +++ b/gcc/testsuite/cobol.dg/group2/INITIALIZE_with_-defaultbyte__EBCDIC_.cob @@ -19,9 +19,9 @@ 02 PHONE-NUMBER. 03 NAME PIC A(30). 03 AREA-CODE PIC 999. - 03 DASH PIC X VALUE'-'. + 03 DASH PIC X VALUE '-'. 03 PREFIX PIC 999. - 03 DASH PIC X VALUE'-'. + 03 DASH PIC X VALUE '-'. 03 LOCAL PIC 999. 77 WHO-AM-I PIC X(12). PROCEDURE DIVISION. diff --git a/gcc/testsuite/cobol.dg/group2/PR59_RT3586_-_Code_format_heuristic_fails.cob b/gcc/testsuite/cobol.dg/group2/PR59_RT3586_-_Code_format_heuristic_fails.cob deleted file mode 100644 index c43edb201ed1..000000000000 --- a/gcc/testsuite/cobol.dg/group2/PR59_RT3586_-_Code_format_heuristic_fails.cob +++ /dev/null @@ -1,7 +0,0 @@ - *> { dg-do compile } - -00002 PROGRAM-ID. PROG. RJD0002 -00003 PROCEDURE DIVISION. RJD0003 -00004 GOBACK. RJD0004 -00005 END PROGRAM PROG. RJD0005 - diff --git a/gcc/testsuite/cobol.dg/group2/RT3609_Unexpected_PROCESS.cob b/gcc/testsuite/cobol.dg/group2/RT3609_Unexpected_PROCESS.cob deleted file mode 100644 index 39b37c674000..000000000000 --- a/gcc/testsuite/cobol.dg/group2/RT3609_Unexpected_PROCESS.cob +++ /dev/null @@ -1,9 +0,0 @@ - *> { dg-do run } - *> { dg-options "-O0 -Wno-ibm-cdf -I copybooks -Wno-recording-mode -ffixed-form -dialect ibm -fno-static-call -fexec-charset=CP037 -fexec-national-charset=CP037" } - -00001 PROCESS FLAG(I,W) FDUMP -00002 IDENTIFICATION DIVISION. -00003 PROGRAM-ID. prog. -00004 PROCEDURE DIVISION. -00005 DISPLAY "OK". - diff --git a/libgcobol/charmaps.h b/libgcobol/charmaps.h index ac0ebd63f02a..3f212ac93bc1 100644 --- a/libgcobol/charmaps.h +++ b/libgcobol/charmaps.h @@ -280,7 +280,7 @@ enum #define ebcdic_minus ((uint8_t)(0x60)) #define ebcdic_newline ((uint8_t)(0x25)) -extern unsigned char __gg__data_space[1] ; +extern unsigned char __gg__data_spaces[1] ; extern unsigned char __gg__data_low_values[1] ; extern unsigned char __gg__data_zeros[1] ; extern unsigned char __gg__data_high_values[1] ; diff --git a/libgcobol/constants.cc b/libgcobol/constants.cc index 68d9e091bae0..51cd5bdfff05 100644 --- a/libgcobol/constants.cc +++ b/libgcobol/constants.cc @@ -48,6 +48,7 @@ #include "io.h" #include "common-defs.h" #include "gcobolio.h" +#include "cobol-endian.h" #pragma GCC diagnostic push #pragma GCC diagnostic ignored "-Wwrite-strings" @@ -58,84 +59,18 @@ // initialization happens just once. int __gg__globals_are_initialized = 0; -// We have a number of integer constants. We need two macros, one for 1-digit -// names and a second for 2-digit names in order to match our mangling -// convention for variable names that start with a numeric: - -// 4 becomes _1_4 -// _ indicates this is a mangled name -// 1 means it is one character long -// _ terminates the 1 -// 4 is the one-character name - -#define INTEGER_CONSTANT1(a) \ -unsigned char __gg__data_##a[1] = {(a)}; \ -struct cblc_field_t __ggsr___1_##a = { \ - .data = __gg__data_##a , \ - .capacity = 1 , \ - .allocated = 1 , \ - .offset = 0 , \ - .name = #a , \ - .picture = "" , \ - .initial = #a , \ - .parent = NULL, \ - .occurs_lower = 0 , \ - .occurs_upper = 0 , \ - .attr = global_e | constant_e , \ - .type = FldLiteralN , \ - .level = 0 , \ - .digits = 0 , \ - .rdigits = 0 , \ - .dummy = 0 , \ - }; - -#define INTEGER_CONSTANT2(a) \ -unsigned char __gg__data_##a[1] = {(a)}; \ -struct cblc_field_t __ggsr___2_##a = { \ - .data = __gg__data_##a , \ - .capacity = 1 , \ - .allocate = 1 , \ - .offset = 0 , \ - .name = #a , \ - .picture = "" , \ - .initial = #a , \ - .parent = NULL, \ - .occurs_lower = 0 , \ - .occurs_upper = 0 , \ - .attr = global_e | constant_e , \ - .type = FldLiteralN , \ - .level = 0 , \ - .digits = 0 , \ - .rdigits = 0 , \ - .encoding = iconv_CP1252_e \ - .alphabet = 0 \ - }; -unsigned char __gg__data_space[1] = {' '}; -struct cblc_field_t __ggsr__space = { - .data = __gg__data_space , - .capacity = sizeof(__gg__data_space) , - .allocated = sizeof(__gg__data_space) , - .offset = 0 , - .name = "SPACE" , - .picture = "" , - .initial = (char *)space_value_e , - .parent = NULL, - .occurs_lower = 0 , - .occurs_upper = 0 , - .attr = quoted_e | constant_e | space_value_e , - .type = FldAlphanumeric , - .level = 0 , - .digits = 0 , - .rdigits = 0 , - .encoding = iconv_CP1252_e , - .alphabet = 0 , - }; +#if COBOL_BIG_ENDIAN +#define endian big_endian_e +#else +#define endian none_e +#endif +unsigned char __gg__data_spaces[1] = {' '}; struct cblc_field_t __ggsr__spaces = { - .data = __gg__data_space , - .capacity = sizeof(__gg__data_space) , - .allocated = sizeof(__gg__data_space) , + .data = __gg__data_spaces , + .capacity = 1 , + .allocated = 1 , .offset = 0 , .name = "SPACES" , .picture = "" , @@ -143,7 +78,7 @@ struct cblc_field_t __ggsr__spaces = { .parent = NULL, .occurs_lower = 0 , .occurs_upper = 0 , - .attr = quoted_e | constant_e | space_value_e , + .attr = quoted_e | constant_e | register_e | space_value_e, .type = FldAlphanumeric , .level = 0 , .digits = 0 , @@ -164,7 +99,7 @@ struct cblc_field_t __ggsr__low_values = { .parent = NULL, .occurs_lower = 0 , .occurs_upper = 0 , - .attr = 0x281 , + .attr = quoted_e | constant_e | register_e | low_value_e , .type = FldAlphanumeric , .level = 0 , .digits = 0 , @@ -185,7 +120,7 @@ struct cblc_field_t __ggsr__zeros = { .parent = NULL , .occurs_lower = 0 , .occurs_upper = 0 , - .attr = 0x83 , + .attr = quoted_e | constant_e | register_e | zero_value_e , .type = FldAlphanumeric , .level = 0 , .digits = 0 , @@ -206,7 +141,7 @@ struct cblc_field_t __ggsr__high_values = { .parent = NULL, .occurs_lower = 0 , .occurs_upper = 0 , - .attr = 0x286 , + .attr = quoted_e | constant_e | register_e | high_value_e , .type = FldAlphanumeric , .level = 0 , .digits = 0 , @@ -227,7 +162,7 @@ struct cblc_field_t __ggsr__quotes = { .parent = NULL, .occurs_lower = 0 , .occurs_upper = 0 , - .attr = 0x285 , + .attr = quoted_e | constant_e | register_e | quote_value_e , .type = FldAlphanumeric , .level = 0 , .digits = 0 , @@ -248,7 +183,7 @@ struct cblc_field_t __ggsr__nulls = { .parent = NULL, .occurs_lower = 0 , .occurs_upper = 0 , - .attr = quoted_e | constant_e , + .attr = constant_e | register_e | null_value_e , .type = FldPointer , .level = 0 , .digits = 0 , @@ -269,7 +204,7 @@ struct cblc_field_t __ggsr___file_status = { .parent = NULL, .occurs_lower = 0 , .occurs_upper = 0 , - .attr = 0x0 , + .attr = register_e , .type = FldNumericDisplay , .level = 0 , .digits = 2 , @@ -291,7 +226,7 @@ struct cblc_field_t __ggsr__upsi_0 = { .parent = NULL, .occurs_lower = 0 , .occurs_upper = 0 , - .attr = 0x0 , + .attr = register_e | endian, .type = FldNumericBin5 , .level = 0 , .digits = 4 , @@ -312,7 +247,7 @@ struct cblc_field_t __ggsr___dev_stdin = { .parent = NULL, .occurs_lower = 0 , .occurs_upper = 0 , - .attr = 0x0 , + .attr = constant_e | quoted_e | register_e , .type = FldLiteralA , .level = 0 , .digits = 0 , @@ -333,7 +268,7 @@ struct cblc_field_t __ggsr___dev_stdout = { .parent = NULL, .occurs_lower = 0 , .occurs_upper = 0 , - .attr = 0x0 , + .attr = constant_e | quoted_e | register_e , .type = FldLiteralA , .level = 0 , .digits = 0 , @@ -354,7 +289,7 @@ struct cblc_field_t __ggsr___dev_stderr = { .parent = NULL, .occurs_lower = 0 , .occurs_upper = 0 , - .attr = 0x0 , + .attr = constant_e | quoted_e | register_e , .type = FldLiteralA , .level = 0 , .digits = 0 , @@ -375,7 +310,7 @@ struct cblc_field_t __ggsr___dev_null = { .parent = NULL, .occurs_lower = 0 , .occurs_upper = 0 , - .attr = 0x0 , + .attr = constant_e | quoted_e | register_e , .type = FldLiteralA , .level = 0 , .digits = 0 , @@ -384,7 +319,7 @@ struct cblc_field_t __ggsr___dev_null = { .alphabet = 0 , }; -unsigned char __gg__data_argi[] = {0,0}; +unsigned char __gg__data_argi[] = {0,0,0,0}; struct cblc_field_t __ggsr__argi = { .data = __gg__data_argi , .capacity = 4 , @@ -396,15 +331,60 @@ struct cblc_field_t __ggsr__argi = { .parent = NULL, .occurs_lower = 0 , .occurs_upper = 0 , - .attr = global_e , + .attr = global_e | endian, .type = FldNumericBin5 , .level = 0 , - .digits = 5 , + .digits = 0 , .rdigits = 0 , .encoding = iconv_CP1252_e , .alphabet = 0 , }; +unsigned char __gg__data__literally_zero[] = {0,0,0,0}; +struct cblc_field_t __ggsr___literally_zero = { + .data = __gg__data__literally_zero , + .capacity = 4 , + .allocated = 4 , + .offset = 0 , + .name = "_literally_zero" , + .picture = "" , + .initial = "" , + .parent = NULL, + .occurs_lower = 0 , + .occurs_upper = 0 , + .attr = register_e | endian, + .type = FldNumericBin5 , + .level = 0 , + .digits = 0 , + .rdigits = 0 , + .encoding = iconv_CP1252_e , + .alphabet = 0 , + }; + +#if COBOL_BIG_ENDIAN +unsigned char __gg__data__literally_one[] = {0,0,0,1}; +#else +unsigned char __gg__data__literally_one[] = {1,0,0,0}; +#endif +struct cblc_field_t __ggsr__literally_one = { + .data = __gg__data__literally_one , + .capacity = 4 , + .allocated = 4 , + .offset = 0 , + .name = "_literally_one" , + .picture = "" , + .initial = "" , + .parent = NULL, + .occurs_lower = 0 , + .occurs_upper = 0 , + .attr = register_e | endian, + .type = FldNumericBin5 , + .level = 0 , + .digits = 0 , + .rdigits = 0 , + .encoding = iconv_CP1252_e , + .alphabet = 0 , + }; /* The following defines storage for the global DEBUG-ITEM: diff --git a/libgcobol/libgcobol.cc b/libgcobol/libgcobol.cc index 391d84ea40de..a4a88238002e 100644 --- a/libgcobol/libgcobol.cc +++ b/libgcobol/libgcobol.cc @@ -6250,7 +6250,7 @@ alpha_to_alpha_move_from_location(cblc_field_t *field, } else { - // Destination is right-justified, so we + // Destination is left-justified, so we // discard the trailing source characters: memmove(to, from, @@ -11466,7 +11466,7 @@ __gg__codeset_figurative_constants() { // This routine gets called after the codeset has been changed - // __gg__data_space and __gg__data_zeros don't change because they are + // __gg__data_spaces and __gg__data_zeros don't change because they are // permanently encoded as iconv_CP1252_e. These other three can be changed // as either compiler options or ALPHABET clauses. *__gg__data_low_values = __gg__low_value_character; @@ -11489,7 +11489,7 @@ __gg__get_figconst_data(const cblc_field_t *field) retval = __gg__data_zeros; break; case space_value_e : - retval = __gg__data_space; + retval = __gg__data_spaces; break; case quote_value_e : retval = __gg__data_quotes;