aboutsummaryrefslogtreecommitdiff
path: root/gcc/cobol
diff options
context:
space:
mode:
Diffstat (limited to 'gcc/cobol')
-rw-r--r--gcc/cobol/ChangeLog165
-rw-r--r--gcc/cobol/Make-lang.in9
-rw-r--r--gcc/cobol/cbldiag.h20
-rw-r--r--gcc/cobol/cdf.y2
-rw-r--r--gcc/cobol/gcobolspec.cc13
-rw-r--r--gcc/cobol/genapi.cc341
-rw-r--r--gcc/cobol/genapi.h43
-rw-r--r--gcc/cobol/gengen.cc101
-rw-r--r--gcc/cobol/gengen.h10
-rw-r--r--gcc/cobol/genmath.cc2
-rw-r--r--gcc/cobol/genutil.cc20
-rw-r--r--gcc/cobol/genutil.h8
-rw-r--r--gcc/cobol/parse.y24
-rw-r--r--gcc/cobol/parse_ante.h10
-rw-r--r--gcc/cobol/scan.l19
-rw-r--r--gcc/cobol/scan_ante.h381
-rw-r--r--gcc/cobol/symbols.cc5
-rw-r--r--gcc/cobol/symbols.h2
-rw-r--r--gcc/cobol/util.cc89
-rw-r--r--gcc/cobol/util.h2
20 files changed, 1011 insertions, 255 deletions
diff --git a/gcc/cobol/ChangeLog b/gcc/cobol/ChangeLog
index f594331..b286f5d 100644
--- a/gcc/cobol/ChangeLog
+++ b/gcc/cobol/ChangeLog
@@ -1,3 +1,168 @@
+2025-07-25 David Malcolm <dmalcolm@redhat.com>
+
+ * util.cc: Update for diagnostic_t becoming
+ enum class diagnostics::kind.
+
+2025-07-25 David Malcolm <dmalcolm@redhat.com>
+
+ * util.cc: Update for renaming of diagnostic_option_id to
+ diagnostics::option_id.
+
+2025-07-25 David Malcolm <dmalcolm@redhat.com>
+
+ * util.cc: Remove redundant #includes
+
+2025-07-24 Robert Dubner <rdubner@symas.com>
+
+ PR cobol/119231
+ * gcobolspec.cc: (lang_specific_driver): Pass OPT_static through.
+ Handle -static and -static-libgcobol properly.
+
+2025-07-23 Robert Dubner <rdubner@symas.com>
+
+ * genapi.cc (leave_procedure): Adjust location_t for PERFORM.
+ (parser_perform_times): Likewise.
+ (internal_perform_through_times): Likewise.
+ (perform_outofline_before_until): Likewise.
+ (perform_outofline_after_until): Likewise.
+ (perform_outofline_testafter_varying): Likewise.
+ (perform_outofline_before_varying): Likewise.
+
+2025-07-21 Robert Dubner <rdubner@symas.com>
+ James K. Lowden <jklowden@cobolworx.com>
+
+ PR cobol/120402
+ * Make-lang.in: Elminate commented-out scripting.
+ * cbldiag.h (_CBLDIAG_H): Change #if 0 to #if GCOBOL_GETENV
+ (warn_msg): Add printf attributes.
+ (location_dump): Add debugging message.
+ * cdf.y: Improved linemap tracking.
+ * genapi.cc (treeplet_fill_source): const attribute for formal parameter.
+ (insert_nop): Created to consolidate var_decl_nop writes.
+ (build_main_that_calls_something): Move generation to the end of executable.
+ (level_88_helper): Formatting.
+ (parser_call_targets_dump): Formatting.
+ (function_pointer_from_name): const attribute for formal parameter.
+ (parser_initialize_programs): const attribute for formal parameter.
+ (parser_statement_begin): Improved linemap handling.
+ (section_label): Improved linemap handling.
+ (paragraph_label): Improved linemap handling.
+ (pseudo_return_pop): Improved linemap handling.
+ (leave_procedure): Formatting.
+ (parser_enter_section): Improved linemap handling.
+ (parser_enter_paragraph): Improved linemap handling.
+ (parser_perform): Formatting.
+ (parser_leave_file): Move creation of main() to this routine.
+ (parser_enter_program): Move creation of main from here to leave_file.
+ (parser_accept): Formatting. const attribute for formal parameter.
+ (parser_accept_command_line): const attribute for formal parameter.
+ (parser_accept_command_line_count): const attribute for formal parameter.
+ (parser_accept_envar): Likewise.
+ (parser_set_envar): Likewise.
+ (parser_display): Likewise.
+ (get_exhibit_name): Implement EXHIBIT verb.
+ (parser_exhibit): Likewise.
+ (parser_sleep): const attribute for formal parameter.
+ (parser_division): Improved linemap handling.
+ (parser_classify): const attribute for formal parameter.
+ (create_iline_address_pairs): Improved linemap handling.
+ (parser_perform_start): Likewise.
+ (perform_inline_until): Likewise.
+ (perform_inline_testbefore_varying): Likewise.
+ (parser_perform_until): Likewise.
+ (parser_perform_inline_times): Likewise.
+ (parser_intrinsic_subst): const attribute for formal parameter.
+ (parser_file_merge): Formatting.
+ (create_and_call): Improved linemap handling.
+ (mh_identical): const attribute for formal parameter.
+ (mh_numeric_display): const attribute for formal parameter.
+ (mh_little_endian): Likewise.
+ (mh_source_is_group): Likewise.
+ (psa_FldLiteralA): Formatting.
+ * genapi.h (parser_accept): const attribute for formal parameter.
+ (parser_accept_envar): Likewise.
+ (parser_set_envar): Likewise.
+ (parser_accept_command_line): Likewise.
+ (parser_accept_command_line_count): Likewise.
+ (parser_add): Likewise.
+ (parser_classify): Likewise.
+ (parser_sleep): Likewise.
+ (parser_exhibit): Likewise.
+ (parser_display): Likewise.
+ (parser_initialize_programs): Likewise.
+ (parser_intrinsic_subst): Likewise.
+ * gengen.cc (gg_assign): Improved linemap handling.
+ (gg_add_field_to_structure): Likewise.
+ (gg_define_from_declaration): Likewise.
+ (gg_build_relational_expression): Likewise.
+ (gg_goto_label_decl): Likewise.
+ (gg_goto): Likewise.
+ (gg_printf): Likewise.
+ (gg_fprintf): Likewise.
+ (gg_memset): Likewise.
+ (gg_memchr): Likewise.
+ (gg_memcpy): Likewise.
+ (gg_memmove): Likewise.
+ (gg_strcpy): Likewise.
+ (gg_strcmp): Likewise.
+ (gg_strncmp): Likewise.
+ (gg_return): Likewise.
+ (chain_parameter_to_function): Likewise.
+ (gg_define_function): Likewise.
+ (gg_get_function_decl): Likewise.
+ (gg_call_expr): Likewise.
+ (gg_call): Likewise.
+ (gg_call_expr_list): Likewise.
+ (gg_exit): Likewise.
+ (gg_abort): Likewise.
+ (gg_strlen): Likewise.
+ (gg_strdup): Likewise.
+ (gg_malloc): Likewise.
+ (gg_realloc): Likewise.
+ (gg_free): Likewise.
+ (gg_set_current_line_number): Likewise.
+ (gg_get_current_line_number): Likewise.
+ (gg_insert_into_assembler): Likewise.
+ (token_location_override): Likewise.
+ (gg_token_location): Likewise.
+ * gengen.h (location_from_lineno): Likewise.
+ (gg_set_current_line_number): Likewise.
+ (gg_get_current_line_number): Likewise.
+ (gg_token_location): Likewise.
+ (current_token_location): Likewise.
+ (current_location_minus_one): Likewise.
+ (current_location_minus_one_clear): Likewise.
+ (token_location_override): Likewise.
+ * genmath.cc (fast_divide): const attribute for formal parameter.
+ * genutil.cc (get_and_check_refstart_and_reflen): Likewise.
+ (get_data_offset): Likewise.
+ (refer_refmod_length): Likewise.
+ (refer_offset): Likewise.
+ (refer_size): Likewise.
+ (refer_size_dest): Likewise.
+ (refer_size_source): Likewise.
+ (qualified_data_location): Likewise.
+ * genutil.h (refer_offset): Likewise.
+ (refer_size_source): Likewise.
+ (refer_size_dest): Likewise.
+ (qualified_data_location): Likewise.
+ * parse.y: EVALUATE token; Implement EXHIBIT verb;
+ Improved linemap handling.
+ * parse_ante.h (input_file_status_notify): Improved linemap handling.
+ (location_set): Likewise.
+ * scan.l: PICTURE string validation.
+ * scan_ante.h (class picture_t): PICTURE string validation.
+ (validate_picture): Likewise.
+ * symbols.cc (symbol_currency): Revised default currency handling.
+ * symbols.h (symbol_currency): Likewise.
+ * util.cc (location_from_lineno): Improved linemap handling.
+ (current_token_location): Improved linemap handling.
+ (current_location_minus_one): Improved linemap handling.
+ (current_location_minus_one_clear): Improved linemap handling.
+ (gcc_location_set_impl): Improved linemap handling.
+ (warn_msg): Improved linemap handling.
+ * util.h (cobol_lineno): Improved linemap handling.
+
2025-07-15 Jakub Jelinek <jakub@redhat.com>
Jason Merrill <jason@redhat.com>
diff --git a/gcc/cobol/Make-lang.in b/gcc/cobol/Make-lang.in
index 22de3b1..0e2a773 100644
--- a/gcc/cobol/Make-lang.in
+++ b/gcc/cobol/Make-lang.in
@@ -385,12 +385,3 @@ selftest-cobol:
lang_checks += check-cobol
-###
-### Note that the process environment variable CXXFLAGS_FOR_COBOL is applied to
-### gcc/cobol compilations. This is not a configuration-level variable.
-###
-##
-##cobol/%.o: cobol/%.cc
-## @echo $(COMPILE) $(CXXFLAGS_FOR_COBOL) $<
-## $(COMPILE) $(CXXFLAGS_FOR_COBOL) $<
-## $(POSTCOMPILE)
diff --git a/gcc/cobol/cbldiag.h b/gcc/cobol/cbldiag.h
index 49dc44b..39f1369 100644
--- a/gcc/cobol/cbldiag.h
+++ b/gcc/cobol/cbldiag.h
@@ -33,7 +33,7 @@
#else
#define _CBLDIAG_H
-#if 0
+#if GCOBOL_GETENV
#define gcobol_getenv(x) getenv(x)
#else
#define gcobol_getenv(x) ((char *)nullptr)
@@ -78,10 +78,15 @@ struct YDFLTYPE
#endif
+// Diagnostic format specifiers are documented in gcc/pretty-print.cc
// an error at a location, called from the parser for semantic errors
void error_msg( const YYLTYPE& loc, const char gmsgid[], ... )
ATTRIBUTE_GCOBOL_DIAG(2, 3);
+bool
+warn_msg( const YYLTYPE& loc, const char gmsgid[], ... )
+ ATTRIBUTE_GCOBOL_DIAG(2, 3);
+
// an error that uses token_location, not yylloc
void error_msg_direct( const char gmsgid[], ... )
ATTRIBUTE_GCOBOL_DIAG(1, 2);
@@ -116,11 +121,14 @@ template <typename LOC>
static void
location_dump( const char func[], int line, const char tag[], const LOC& loc) {
extern int yy_flex_debug; // cppcheck-suppress shadowVariable
- if( yy_flex_debug && gcobol_getenv("update_location") ) {
- fprintf(stderr, "%s:%d: %s location (%d,%d) to (%d,%d)\n",
- func, line, tag,
- loc.first_line, loc.first_column, loc.last_line, loc.last_column);
- gcc_location_dump();
+ if( yy_flex_debug ) {
+ const char *detail = gcobol_getenv("update_location");
+ if( detail ) {
+ fprintf(stderr, "%s:%d: %s location (%d,%d) to (%d,%d)\n",
+ func, line, tag,
+ loc.first_line, loc.first_column, loc.last_line, loc.last_column);
+ if( *detail == '2' ) gcc_location_dump();
+ }
}
}
#endif // defined(yy_flex_debug)
diff --git a/gcc/cobol/cdf.y b/gcc/cobol/cdf.y
index 840eb50..53fea5d 100644
--- a/gcc/cobol/cdf.y
+++ b/gcc/cobol/cdf.y
@@ -95,7 +95,7 @@ void input_file_status_notify();
} \
location_dump("cdf.c", __LINE__, "current", (Current)); \
input_file_status_notify(); \
- gcc_location_set( location_set(Current) ); \
+ location_set(Current); \
} while (0)
%}
diff --git a/gcc/cobol/gcobolspec.cc b/gcc/cobol/gcobolspec.cc
index 038aaec..1f1b463 100644
--- a/gcc/cobol/gcobolspec.cc
+++ b/gcc/cobol/gcobolspec.cc
@@ -470,7 +470,10 @@ lang_specific_driver (struct cl_decoded_option **in_decoded_options,
//// break;
////#endif
case OPT_static:
+#if defined (HAVE_LD_STATIC_DYNAMIC)
+ append_arg(decoded_options[i]);
static_in_general = true;
+#endif
break;
default:
@@ -498,17 +501,23 @@ lang_specific_driver (struct cl_decoded_option **in_decoded_options,
need_libgcobol = false;
}
+ if( static_in_general )
+ {
+ // These two options interfere with each other.
+ static_libgcobol = false;
+ }
+
if( need_libgcobol )
{
add_arg_lib(COBOL_LIBRARY, static_libgcobol);
}
if( need_libdl )
{
- add_arg_lib(DL_LIBRARY, static_in_general);
+ add_arg_lib(DL_LIBRARY, false);
}
if( need_libstdc )
{
- add_arg_lib(STDCPP_LIBRARY, static_in_general);
+ add_arg_lib(STDCPP_LIBRARY, false);
}
if( prior_main )
diff --git a/gcc/cobol/genapi.cc b/gcc/cobol/genapi.cc
index a293912..666802e 100644
--- a/gcc/cobol/genapi.cc
+++ b/gcc/cobol/genapi.cc
@@ -118,7 +118,7 @@ typedef struct TREEPLET
static
void
-treeplet_fill_source(TREEPLET &treeplet, cbl_refer_t &refer)
+treeplet_fill_source(TREEPLET &treeplet, const cbl_refer_t &refer)
{
treeplet.pfield = gg_get_address_of(refer.field->var_decl_node);
treeplet.offset = refer_offset(refer);
@@ -233,6 +233,13 @@ trace1_init()
}
}
+static
+void
+insert_nop(int n)
+ {
+ gg_assign(var_decl_nop, build_int_cst_type(INT, n));
+ }
+
static void
create_cblc_string_variable(const char *var_name, const char *var_contents)
{
@@ -270,8 +277,6 @@ build_main_that_calls_something(const char *something)
SHOW_PARSE_END
}
- gg_set_current_line_number(DEFAULT_LINE_NUMBER);
-
tree function_decl = gg_define_function( INT,
"main",
"main",
@@ -325,7 +330,6 @@ build_main_that_calls_something(const char *something)
argc,
argv,
NULL_TREE)));
- strncpy(ach_cobol_entry_point, psz, sizeof(ach_cobol_entry_point)-1);
free(psz);
gg_finalize_function();
}
@@ -369,7 +373,7 @@ level_88_helper(size_t parent_capacity,
gcc_assert(retval);
char *builder = static_cast<char *>(xmalloc(parent_capacity + 64));
gcc_assert(builder);
-
+
size_t nbuild = 0;
cbl_figconst_t figconst = cbl_figconst_of( elem.name());
@@ -788,7 +792,7 @@ parser_call_targets_dump()
}
fprintf(stderr, " ]\n");
}
-#endif
+#endif
}
size_t
@@ -816,8 +820,8 @@ parser_call_target_update( size_t caller,
}
static tree
-function_pointer_from_name(cbl_refer_t &name,
- tree function_return_type)
+function_pointer_from_name(const cbl_refer_t &name,
+ tree function_return_type)
{
Analyze();
@@ -893,7 +897,8 @@ function_pointer_from_name(cbl_refer_t &name,
}
void
-parser_initialize_programs(size_t nprogs, struct cbl_refer_t *progs)
+parser_initialize_programs( size_t nprogs,
+ const struct cbl_refer_t *progs)
{
Analyze();
SHOW_PARSE
@@ -1178,14 +1183,6 @@ parser_statement_begin( const cbl_name_t statement_name,
exception_processing = file_ops.find(statement_name) != file_ops.end();
}
- if( gg_get_current_line_number() == DEFAULT_LINE_NUMBER )
- {
- // This code is intended to prevert GDB anomalies when the first line of a
- // program is a PERFORM <proc> ... TEST AFTER ... UNTIL ...
- gg_set_current_line_number(CURRENT_LINE_NUMBER-1);
- gg_assign(var_decl_nop, build_int_cst_type(INT, 106));
- }
-
// At this point, if any exception is enabled, we store the location stuff.
// Each file I-O routine calls store_location_stuff explicitly, because
// those exceptions can't be defeated.
@@ -1195,8 +1192,6 @@ parser_statement_begin( const cbl_name_t statement_name,
store_location_stuff(statement_name);
}
- gg_set_current_line_number(CURRENT_LINE_NUMBER);
-
if( exception_processing )
{
set_exception_environment(ecs, dcls);
@@ -2666,8 +2661,6 @@ section_label(struct cbl_proc_t *procedure)
// With nested programs, you can have multiple program/section pairs with the
// the same names; we use a deconflictor to avoid collisions
- gg_set_current_line_number(CURRENT_LINE_NUMBER);
-
size_t deconflictor = symbol_label_id(procedure->label);
cbl_label_t *label = procedure->label;
@@ -2692,7 +2685,7 @@ section_label(struct cbl_proc_t *procedure)
}
assembler_label(psz2);
free(psz2);
- gg_assign(var_decl_nop, build_int_cst_type(INT, 108));
+ insert_nop(108);
}
static void
@@ -2707,8 +2700,6 @@ paragraph_label(struct cbl_proc_t *procedure)
// are not referenced by the program. We provide a deconflictor to
// separate such labels.
- gg_set_current_line_number(CURRENT_LINE_NUMBER);
-
cbl_label_t *paragraph = procedure->label;
cbl_label_t *section = nullptr;
@@ -2730,6 +2721,9 @@ paragraph_label(struct cbl_proc_t *procedure)
section_name ? section_name: "(null)" ,
current_function->our_unmangled_name ? current_function->our_unmangled_name: "" ,
(fmt_size_t)deconflictor );
+
+ // (0) is wrong, so back up one
+
gg_insert_into_assembler(psz1);
SHOW_PARSE
@@ -2746,7 +2740,25 @@ paragraph_label(struct cbl_proc_t *procedure)
combined_name(procedure->label));
assembler_label(psz2);
free(psz2);
- gg_assign(var_decl_nop, build_int_cst_type(INT, 109));
+
+ // We are inserting a NOP after having created a label for the procedure.
+ // This means that when using GDC_COBOL to step into a procedure, the
+ // execution will stop there and show "123 para-name." at the stopped point.
+ //
+ // Note that because there is no user-specified executable code at that point
+ // the user can't set a working breakpoint with "break 123". But because
+ // GDB will pick up the psz2 text and set a breakpoint there (which is the
+ // location of the NOP) "break para-name" will actually stop and show line
+ // 123.
+ //
+ // This really only makes sense when you look at the assembly language. Keep
+ // in mind as you read it that issuing a "break 123" causes GDB to set a
+ // breakpoint at the first executable machine language code following the
+ // first ".loc 123" directive.
+ //
+ // Yes, trying to understand this causes headaches for many people who read
+ // this. Take an aspirin.
+ insert_nop(109);
}
static void
@@ -2790,6 +2802,7 @@ pseudo_return_pop(cbl_proc_t *procedure)
NULL_TREE);
}
+ token_location_override(current_location_minus_one());
IF( var_decl_exit_address, eq_op, procedure->exit.addr )
{
TRACE1
@@ -2799,11 +2812,13 @@ pseudo_return_pop(cbl_proc_t *procedure)
// The top of the stack is us!
// Pick up the return address from the pseudo_return stack:
+ token_location_override(current_location_minus_one());
gg_assign(current_function->void_star_temp,
gg_call_expr( VOID_P,
"__gg__pseudo_return_pop",
NULL_TREE));
// And do the return:
+ token_location_override(current_location_minus_one());
gg_goto(current_function->void_star_temp);
}
ELSE
@@ -2837,11 +2852,13 @@ leave_procedure(struct cbl_proc_t *procedure, bool /*section*/)
// procedure->bottom.label);
// Procedure can be null, for example at the beginning of a
// new program, or after somebody else has cleared it out.
+
gg_append_statement(procedure->exit.label);
char *psz;
psz = xasprintf("_procret." HOST_SIZE_T_PRINT_DEC ":",
(fmt_size_t)symbol_label_id(procedure->label));
+ token_location_override(current_location_minus_one());
gg_insert_into_assembler(psz);
free(psz);
pseudo_return_pop(procedure);
@@ -3012,6 +3029,8 @@ parser_enter_section(cbl_label_t *label)
{
SHOW_PARSE_HEADER
SHOW_PARSE_LABEL(" ", label)
+ SHOW_PARSE_INDENT
+ linemap_dump_location( line_table, current_token_location(), stderr );
SHOW_PARSE_END
}
@@ -3019,8 +3038,7 @@ parser_enter_section(cbl_label_t *label)
// This NOP is needed to give GDB a line number for the entry point of
// paragraphs
- gg_set_current_line_number(CURRENT_LINE_NUMBER);
- gg_assign(var_decl_nop, build_int_cst_type(INT, 101));
+ insert_nop(101);
struct cbl_proc_t *procedure = find_procedure(label);
gg_append_statement(procedure->top.label);
@@ -3047,6 +3065,8 @@ parser_enter_paragraph(cbl_label_t *label)
{
SHOW_PARSE_HEADER
SHOW_PARSE_LABEL(" ", label)
+ SHOW_PARSE_INDENT
+ linemap_dump_location( line_table, current_token_location(), stderr );
SHOW_PARSE_END
}
@@ -3272,7 +3292,7 @@ parser_perform(cbl_label_t *label, bool suppress_nexting)
SHOW_PARSE_TEXT(ach)
if( label )
{
- sprintf(ach,
+ sprintf(ach,
" label->proc is %p",
static_cast<void*>(label->structs.proc));
}
@@ -3426,6 +3446,7 @@ parser_perform_times( cbl_label_t *proc_1, cbl_refer_t count )
sprintf(ach,
"_procretb." HOST_SIZE_T_PRINT_DEC ":",
(fmt_size_t)our_pseudo_label);
+ token_location_override(current_location_minus_one());
gg_insert_into_assembler(ach);
}
@@ -3579,6 +3600,7 @@ internal_perform_through_times( cbl_label_t *proc_1,
sprintf(ach,
"_procretb." HOST_SIZE_T_PRINT_DEC ":",
(fmt_size_t)our_pseudo_label);
+ token_location_override(current_location_minus_one());
gg_insert_into_assembler( ach );
}
@@ -3770,6 +3792,22 @@ parser_leave_file()
{
// We are leaving the top-level file, which means this compilation is
// done, done, done.
+
+ // There is, however, one thing left to do. If the command line says
+ // that this module needs a main entry point, then this is where
+ // we create a main() function. We build it at the end, so that all of
+ // the .loc directives associated with it appear at the end of the
+ // source code. We used to create the main() entry point at the beginning,
+ // but that created confusion for GDB when trying to debug the generated
+ // executable.
+ if( main_entry_point )
+ {
+ next_program_is_main = false;
+ build_main_that_calls_something(main_entry_point);
+ free(main_entry_point);
+ main_entry_point = NULL;
+ }
+
gg_leaving_the_source_code_file();
}
}
@@ -3879,17 +3917,8 @@ parser_enter_program( const char *funcname_,
// The first thing we have to do is mangle this name. This is safe even
// though the end result will be mangled again, because the mangler doesn't
// change a mangled name.
-
- char *mangled_name;
-
- if( current_call_convention() == cbl_call_cobol_e )
- {
- mangled_name = cobol_name_mangler(funcname_);
- }
- else
- {
- mangled_name = xstrdup(funcname_);
- }
+
+ char *mangled_name = cobol_name_mangler(funcname_);
size_t parent_index = current_program_index();
char *funcname;
@@ -3917,28 +3946,25 @@ parser_enter_program( const char *funcname_,
if( !is_function && !parent_index )
{
- // This is a top_level program, and not a function
+ // This is a top_level program-id, and not a function
if( next_program_is_main )
{
+ // This is the first top-level program-id.
next_program_is_main = false;
- if(main_entry_point)
- {
- build_main_that_calls_something(main_entry_point);
- free(main_entry_point);
- main_entry_point = NULL;
- }
- else
+ if( !main_entry_point )
{
- build_main_that_calls_something(funcname);
+ // Because no explicit main_entry_point was specified, this program-id,
+ // the first in the file, becomes the target of the main() function
+ // that will be created at parser_leave_file time.
+ main_entry_point = xstrdup(funcname);
+
+ char *psz = cobol_name_mangler(main_entry_point);
+ strncpy(ach_cobol_entry_point, psz, sizeof(ach_cobol_entry_point)-1);
+ free(psz);
}
}
}
- // Call this after build_main_that_calls_something, because it manipulates
- // the current line number to DEFAULT_LINE_NUMBER. We have to manipulate it
- // back afterward.
- gg_set_current_line_number(CURRENT_LINE_NUMBER);
-
if( strcmp(funcname_, "main") == 0 && this_module_has_main )
{
// setting 'retval' to 1 let's the caller know that we are being told
@@ -4361,7 +4387,7 @@ psa_FldBlob(struct cbl_field_t *var )
}
void
-parser_accept(struct cbl_refer_t tgt,
+parser_accept(const struct cbl_refer_t &tgt,
special_name_t special_e,
cbl_label_t *error,
cbl_label_t *not_error )
@@ -4464,7 +4490,7 @@ parser_accept(struct cbl_refer_t tgt,
case ARG_VALUE_e:
// We are fetching the variable whose index was established by a prior
- // DISPLAY UPON ARGUMENT-NUMBER. After the fetch, the value will be
+ // DISPLAY UPON ARGUMENT-NUMBER. After the fetch, the value will be
// incremented by one.
function_to_call = "__gg__accept_arg_value";
break;
@@ -4600,8 +4626,8 @@ parser_accept_exception_end( cbl_label_t *accept_label )
}
void
-parser_accept_command_line( cbl_refer_t tgt,
- cbl_refer_t source,
+parser_accept_command_line( const cbl_refer_t &tgt,
+ const cbl_refer_t &source,
cbl_label_t *error,
cbl_label_t *not_error )
{
@@ -4743,7 +4769,7 @@ parser_accept_command_line( cbl_refer_t tgt,
}
void
-parser_accept_command_line_count( cbl_refer_t tgt )
+parser_accept_command_line_count( const cbl_refer_t &tgt )
{
Analyze();
SHOW_PARSE
@@ -4765,10 +4791,10 @@ parser_accept_command_line_count( cbl_refer_t tgt )
}
void
-parser_accept_envar(struct cbl_refer_t tgt,
- struct cbl_refer_t envar,
- cbl_label_t *error,
- cbl_label_t *not_error )
+parser_accept_envar(const struct cbl_refer_t &tgt,
+ const struct cbl_refer_t &envar,
+ cbl_label_t *error,
+ cbl_label_t *not_error )
{
Analyze();
@@ -4851,7 +4877,8 @@ parser_accept_envar(struct cbl_refer_t tgt,
}
void
-parser_set_envar( struct cbl_refer_t name, struct cbl_refer_t value )
+parser_set_envar( const struct cbl_refer_t &name,
+ const struct cbl_refer_t &value )
{
Analyze();
SHOW_PARSE
@@ -5392,9 +5419,9 @@ parser_display_field(cbl_field_t *field)
void
parser_display( const struct cbl_special_name_t *upon,
- std::vector<cbl_refer_t> refs,
- bool advance,
- const cbl_label_t *not_error,
+ const std::vector<cbl_refer_t> &refs,
+ bool advance,
+ const cbl_label_t *not_error,
const cbl_label_t *error )
{
const size_t n = refs.size();
@@ -5569,6 +5596,106 @@ parser_display( const struct cbl_special_name_t *upon,
cursor_at_sol = advance;
}
+static
+bool // Returns false for literals; true for named variables
+get_exhibit_name(tree file_descriptor, const cbl_refer_t &arg)
+ {
+ bool retval;
+ if( is_literal(arg.field) )
+ {
+ // If something is a literal, we just display the literal value
+ parser_display_internal(file_descriptor,
+ arg,
+ DISPLAY_NO_ADVANCE);
+ retval = false;
+ }
+ else
+ {
+ // It's not a literal, so we show its name, and the names or literal
+ // values) of any qualifier subscripts or refmods
+ gg_write( file_descriptor,
+ gg_string_literal(arg.field->name),
+ build_int_cst_type(SIZE_T, strlen(arg.field->name)) );
+
+ if( arg.subscripts.size() )
+ {
+ // This refer has subscripts:
+ gg_write( file_descriptor,
+ gg_string_literal("("),
+ integer_one_node );
+ for(size_t i=0; i<arg.subscripts.size(); i++)
+ {
+ if( i > 0 )
+ {
+ gg_write( file_descriptor,
+ gg_string_literal(","),
+ integer_one_node );
+ }
+ get_exhibit_name(file_descriptor, arg.subscripts[i]);
+ }
+ gg_write( file_descriptor,
+ gg_string_literal(")"),
+ integer_one_node );
+ }
+ if( arg.refmod.from || arg.refmod.len )
+ {
+ gg_write( file_descriptor,
+ gg_string_literal("("),
+ integer_one_node );
+ if( arg.refmod.from )
+ {
+ get_exhibit_name(file_descriptor, *(arg.refmod.from));
+ }
+ gg_write( file_descriptor,
+ gg_string_literal(":"),
+ integer_one_node );
+ if( arg.refmod.len )
+ {
+ get_exhibit_name(file_descriptor, *(arg.refmod.len));
+ }
+ gg_write( file_descriptor,
+ gg_string_literal(")"),
+ integer_one_node );
+ }
+ retval = true;
+ }
+ return retval;
+ }
+
+void
+parser_exhibit( bool /*changed*/, bool /*named*/,
+ const std::vector<cbl_refer_t> &args )
+ {
+ tree file_descriptor = gg_define_int();
+ gg_assign(file_descriptor, integer_one_node); // stdout is file descriptor 1.
+
+ for(size_t i=0; i<args.size(); i++)
+ {
+ CHECK_FIELD(args[i].field);
+ if(i > 0)
+ {
+ // When there more than one argument, the second through Nth get a space
+ // in front of them.
+ gg_write( file_descriptor,
+ gg_string_literal(" "),
+ integer_one_node);
+ }
+ if( get_exhibit_name(file_descriptor, args[i]) )
+ {
+ gg_write( file_descriptor,
+ gg_string_literal("="),
+ integer_one_node);
+ parser_display_internal(file_descriptor,
+ args[i],
+ DISPLAY_NO_ADVANCE);
+ }
+ }
+ gg_write( file_descriptor,
+ gg_string_literal("\n"),
+ integer_one_node);
+ cursor_at_sol = true;
+ }
+
static tree
get_literalN_value(cbl_field_t *var)
{
@@ -6344,7 +6471,7 @@ is_valuable( cbl_field_type_t type ) {
return false;
}
-void parser_sleep(cbl_refer_t seconds)
+void parser_sleep(const cbl_refer_t &seconds)
{
if( seconds.field )
{
@@ -6364,7 +6491,7 @@ void parser_sleep(cbl_refer_t seconds)
// This is a naked place-holding CONTINUE. Generate some do-nothing
// code that will stick some .LOC information into the assembly language,
// so that GDB-COBOL can display the CONTINUE statement.
- gg_assign(var_decl_nop, build_int_cst_type(INT, 103));
+ insert_nop(103);
}
}
@@ -6935,8 +7062,6 @@ parser_division(cbl_division_t division,
SHOW_PARSE_END
}
- gg_set_current_line_number(CURRENT_LINE_NUMBER);
-
if( division == data_div_e )
{
Analyze();
@@ -7394,6 +7519,11 @@ parser_division(cbl_division_t division,
ENDIF
}
ENDIF
+ // The first token_location that the parser establishes is caused by the
+ // parser scanning all of the lines in the source code. This messes up the
+ // logic for backing up one line, which is needed to correctly step through
+ // COBOL code with GDB-COBOL. So, we clear it here.
+ current_location_minus_one_clear();
}
}
@@ -8002,7 +8132,7 @@ parser_setop( struct cbl_field_t *tgt,
void
parser_classify( cbl_field_t *tgt,
- cbl_refer_t candidate,
+ const cbl_refer_t &candidate,
enum classify_t type )
{
Analyze();
@@ -8099,14 +8229,6 @@ create_iline_address_pairs(struct cbl_perform_tgt_t *tgt)
gg_create_goto_pair(&tgt->addresses.setup.go_to,
&tgt->addresses.setup.label);
-
- // Even in -O0 compilations, the compiler does some elementary optimizations
- // around JMP instructions. We have the SETUP code for in-line performats
- // in an island at the end of the loop code. With this intervention, NEXTing
- // through the code shows you the final statement of the loop before the
- // loop actually starts.
-
- tgt->addresses.line_number_of_setup_code = gg_get_current_line_number();
}
void
@@ -8169,7 +8291,7 @@ parser_perform_start( struct cbl_perform_tgt_t *tgt )
// Give GDB-COBOL something to chew on when NEXTing. This instruction will
// get the line number of the PERFORM N TIMES code.
gg_append_statement(tgt->addresses.top.label);
- gg_assign(var_decl_nop, build_int_cst_type(INT, 104));
+ insert_nop(104);
}
void
@@ -8321,6 +8443,7 @@ perform_outofline_before_until(struct cbl_perform_tgt_t *tgt,
sprintf(ach,
"_procretb." HOST_SIZE_T_PRINT_DEC ":",
(fmt_size_t)our_pseudo_label);
+ token_location_override(current_location_minus_one());
gg_insert_into_assembler( ach );
}
@@ -8384,6 +8507,7 @@ perform_outofline_after_until(struct cbl_perform_tgt_t *tgt,
sprintf(ach,
"_procretb." HOST_SIZE_T_PRINT_DEC ":",
(fmt_size_t)our_pseudo_label);
+ token_location_override(current_location_minus_one());
gg_insert_into_assembler( ach );
}
@@ -8504,6 +8628,7 @@ perform_outofline_testafter_varying(struct cbl_perform_tgt_t *tgt,
sprintf(ach,
"_procretb." HOST_SIZE_T_PRINT_DEC ":",
(fmt_size_t)our_pseudo_label);
+ token_location_override(current_location_minus_one());
gg_insert_into_assembler( ach );
}
@@ -8647,6 +8772,7 @@ perform_outofline_before_varying( struct cbl_perform_tgt_t *tgt,
sprintf(ach,
"_procretb." HOST_SIZE_T_PRINT_DEC ":",
(fmt_size_t)our_pseudo_label);
+ token_location_override(current_location_minus_one());
gg_insert_into_assembler( ach );
}
@@ -8726,8 +8852,6 @@ perform_inline_until( struct cbl_perform_tgt_t *tgt,
GOTO TOP
EXIT:
*/
- gg_set_current_line_number(cobol_location().last_line);
-
gg_append_statement(tgt->addresses.test.label);
// Go to where the conditional is recalculated....
@@ -8842,8 +8966,6 @@ perform_inline_testbefore_varying( struct cbl_perform_tgt_t *tgt,
parser_move(varys[i].varying, varys[i].from);
}
- gg_set_current_line_number(cobol_location().last_line);
-
// Lay down the testing cycle:
for(size_t i=0; i<N; i++)
{
@@ -9165,9 +9287,6 @@ parser_perform_until( struct cbl_perform_tgt_t *tgt,
SHOW_PARSE_END
}
- gg_set_current_line_number(cobol_location().last_line);
- gg_assign(var_decl_nop, build_int_cst_type(INT, 105));
-
if( tgt->from()->type != LblLoop )
{
perform_outofline( tgt, test_before, N, varys);
@@ -9234,10 +9353,6 @@ parser_perform_inline_times(struct cbl_perform_tgt_t *tgt,
gg_append_statement( tgt->addresses.testA.label );
gg_append_statement( tgt->addresses.test.label );
- // AT this point, we want to set the line_number to the location of the
- // END-PERFORM statement.
- gg_set_current_line_number(cobol_location().last_line);
-
gg_decrement(counter);
// Do the test:
IF( counter, gt_op, gg_cast(LONG, integer_zero_node) )
@@ -9268,8 +9383,6 @@ parser_perform_inline_times(struct cbl_perform_tgt_t *tgt,
SHOW_PARSE_END
}
- int stash = gg_get_current_line_number();
- gg_set_current_line_number(tgt->addresses.line_number_of_setup_code);
gg_append_statement( tgt->addresses.setup.label );
// Get the count:
@@ -9300,8 +9413,6 @@ parser_perform_inline_times(struct cbl_perform_tgt_t *tgt,
gg_append_statement( tgt->addresses.exit.go_to );
ENDIF
- gg_set_current_line_number(stash);
-
SHOW_PARSE
{
SHOW_PARSE_INDENT
@@ -10740,7 +10851,7 @@ parser_intrinsic_numval_c( cbl_field_t *f,
void
parser_intrinsic_subst( cbl_field_t *f,
- cbl_refer_t& ref1,
+ const cbl_refer_t& ref1,
size_t argc,
cbl_substitute_t * argv )
{
@@ -12317,7 +12428,7 @@ parser_file_merge( cbl_file_t *workfile,
const cbl_enabled_exceptions_t&
enabled_exceptions( cdf_enabled_exceptions() );
-
+
for(size_t i=0; i<ninputs; i++)
{
if( process_this_exception(ec_sort_merge_file_open_e) )
@@ -13016,7 +13127,7 @@ create_and_call(size_t narg,
// Fetch the FUNCTION_DECL for that FUNCTION_TYPE
tree function_decl = gg_build_fn_decl(funcname, fndecl_type);
set_call_convention(function_decl, current_call_convention());
-
+
// Take the address of the function decl:
tree address_of_function = gg_get_address_of(function_decl);
@@ -13028,7 +13139,7 @@ create_and_call(size_t narg,
parser_call_target( funcname, assigment );
// Create the call_expr from that address
- call_expr = build_call_array_loc( location_from_lineno(),
+ call_expr = build_call_array_loc( gg_token_location(),
returned_value_type,
address_of_function,
narg,
@@ -14140,9 +14251,9 @@ conditional_abs(tree source, const cbl_field_t *field)
}
static bool
-mh_identical(cbl_refer_t &destref,
- const cbl_refer_t &sourceref,
- const TREEPLET &tsource)
+mh_identical(const cbl_refer_t &destref,
+ const cbl_refer_t &sourceref,
+ const TREEPLET &tsource)
{
// Check to see if the two variables are identical types, thus allowing
// for a simple byte-for-byte copy of the data areas:
@@ -14733,10 +14844,10 @@ picky_memcpy(tree &dest_p, const tree &source_p, size_t length)
}
static bool
-mh_numeric_display( cbl_refer_t &destref,
- const cbl_refer_t &sourceref,
- const TREEPLET &tsource,
- tree size_error)
+mh_numeric_display( const cbl_refer_t &destref,
+ const cbl_refer_t &sourceref,
+ const TREEPLET &tsource,
+ tree size_error)
{
bool moved = false;
@@ -15222,11 +15333,11 @@ mh_numeric_display( cbl_refer_t &destref,
}
static bool
-mh_little_endian( cbl_refer_t &destref,
- const cbl_refer_t &sourceref,
- const TREEPLET &tsource,
- bool check_for_error,
- tree size_error)
+mh_little_endian( const cbl_refer_t &destref,
+ const cbl_refer_t &sourceref,
+ const TREEPLET &tsource,
+ bool check_for_error,
+ tree size_error)
{
bool moved = false;
@@ -15294,9 +15405,9 @@ mh_little_endian( cbl_refer_t &destref,
}
static bool
-mh_source_is_group( cbl_refer_t &destref,
- const cbl_refer_t &sourceref,
- const TREEPLET &tsrc)
+mh_source_is_group( const cbl_refer_t &destref,
+ const cbl_refer_t &sourceref,
+ const TREEPLET &tsrc)
{
bool retval = false;
if( sourceref.field->type == FldGroup && !(destref.field->attr & rjust_e) )
@@ -16640,7 +16751,7 @@ psa_FldLiteralA(struct cbl_field_t *field )
vs_file_static);
}
else
-#endif
+#endif
{
// We have not seen that string before
static int nvar = 0;
diff --git a/gcc/cobol/genapi.h b/gcc/cobol/genapi.h
index c2219a7..b41b906 100644
--- a/gcc/cobol/genapi.h
+++ b/gcc/cobol/genapi.h
@@ -52,20 +52,26 @@ void parser_division( cbl_division_t division,
void parser_enter_program(const char *funcname, bool is_function, int *retval);
void parser_leave_program();
-void parser_accept( cbl_refer_t refer, special_name_t special_e,
- cbl_label_t *error, cbl_label_t *not_error );
+void parser_accept( const cbl_refer_t &refer,
+ special_name_t special_e,
+ cbl_label_t *error,
+ cbl_label_t *not_error );
void parser_accept_exception( cbl_label_t *name );
void parser_accept_exception_end( cbl_label_t *name );
void parser_accept_under_discussion(struct cbl_refer_t tgt, special_name_t special,
cbl_label_t *error, cbl_label_t *not_error );
-void parser_accept_envar( cbl_refer_t refer, cbl_refer_t envar,
- cbl_label_t *error, cbl_label_t *not_error );
-void parser_set_envar( cbl_refer_t envar, cbl_refer_t refer );
-
-void parser_accept_command_line( cbl_refer_t tgt, cbl_refer_t src,
- cbl_label_t *error, cbl_label_t *not_error );
-void parser_accept_command_line_count( cbl_refer_t tgt );
+void parser_accept_envar( const cbl_refer_t &refer,
+ const cbl_refer_t &envar,
+ cbl_label_t *error,
+ cbl_label_t *not_error );
+void parser_set_envar( const cbl_refer_t &envar, const cbl_refer_t &refer );
+
+void parser_accept_command_line(const cbl_refer_t &tgt,
+ const cbl_refer_t &src,
+ cbl_label_t *error,
+ cbl_label_t *not_error );
+void parser_accept_command_line_count( const cbl_refer_t &tgt );
void parser_accept_date_yymmdd( cbl_field_t *tgt );
void parser_accept_date_yyyymmdd( cbl_field_t *tgt );
@@ -89,8 +95,7 @@ parser_add( size_t nC, cbl_num_result_t *C,
size_t nA, cbl_refer_t *A,
cbl_arith_format_t format,
cbl_label_t *error,
- cbl_label_t *not_error,
- void *compute_error = NULL); // This has to be cast to a tree pointer to int
+ cbl_label_t *not_error, void *compute_error = NULL); // This has to be cast to a tree pointer to int
void parser_arith_error( cbl_label_t *name );
void parser_arith_error_end( cbl_label_t *name );
@@ -177,7 +182,8 @@ parser_bitwise_op(struct cbl_field_t *tgt,
void
parser_classify( struct cbl_field_t *tgt,
- struct cbl_refer_t srca, enum classify_t type );
+ const struct cbl_refer_t &srca,
+ enum classify_t type );
void
parser_op( struct cbl_refer_t cref,
@@ -256,7 +262,7 @@ parser_program_hierarchy( const struct cbl_prog_hier_t& hier );
void
parser_end_program(const char *name=NULL);
-void parser_sleep(cbl_refer_t seconds);
+void parser_sleep(const cbl_refer_t &seconds);
void parser_exit( const cbl_refer_t& refer, ec_type_t = ec_none_e );
void parser_exit_section(void);
@@ -265,9 +271,12 @@ void parser_exit_perform( struct cbl_perform_tgt_t *tgt, bool cycle );
void parser_exit_program(void); // exits back to COBOL only, else continue
void
+parser_exhibit( bool changed, bool named,
+ const std::vector<cbl_refer_t> &args );
+void
parser_display( const struct cbl_special_name_t *upon,
- std::vector<cbl_refer_t> args,
- bool advance = DISPLAY_ADVANCE,
+ const std::vector<cbl_refer_t> &args,
+ bool advance = DISPLAY_ADVANCE,
const cbl_label_t *not_error = nullptr,
const cbl_label_t *compute_error = nullptr );
@@ -305,7 +314,7 @@ void
parser_initialize(const cbl_refer_t& refer, bool like_parser_symbol_add=false);
void
-parser_initialize_programs(size_t nprog, struct cbl_refer_t *progs);
+parser_initialize_programs(size_t nprog, const struct cbl_refer_t *progs);
void
parser_label_label( struct cbl_label_t *label );
@@ -452,7 +461,7 @@ parser_intrinsic_numval_c( cbl_field_t *f,
void
parser_intrinsic_subst( cbl_field_t *f,
- cbl_refer_t& ref1,
+ const cbl_refer_t& ref1,
size_t argc,
cbl_substitute_t * argv );
diff --git a/gcc/cobol/gengen.cc b/gcc/cobol/gengen.cc
index 7395350..3ad3344 100644
--- a/gcc/cobol/gengen.cc
+++ b/gcc/cobol/gengen.cc
@@ -107,8 +107,6 @@
// Don't like it? Cry me a river.
static const int ARG_LIMIT = 512;
-static int sv_current_line_number;
-
// These are globally useful constants
tree char_nodes[256];
@@ -452,7 +450,7 @@ gg_assign(tree dest, const tree source)
if( okay )
{
- stmt = build2_loc(location_from_lineno(),
+ stmt = build2_loc(gg_token_location(),
MODIFY_EXPR,
TREE_TYPE(dest),
dest,
@@ -616,7 +614,7 @@ gg_add_field_to_structure(const tree type_of_field, const char *name_of_field, t
tree id_of_field = get_identifier (name_of_field);
// Create the new field:
- tree new_field_decl = build_decl( location_from_lineno(),
+ tree new_field_decl = build_decl( gg_token_location(),
FIELD_DECL,
id_of_field,
type_of_field);
@@ -1043,7 +1041,7 @@ gg_define_from_declaration(tree var_decl)
{
// Having made sure the chain of variable declarations is nicely started,
// it's time to actually define the storage with a decl_expression:
- tree stmt = build1_loc (location_from_lineno(),
+ tree stmt = build1_loc (gg_token_location(),
DECL_EXPR,
TREE_TYPE(var_decl),
var_decl);
@@ -1774,7 +1772,7 @@ gg_build_relational_expression(tree operand_a,
compare = LE_EXPR;
break;
}
- tree relational_expression = build2_loc(location_from_lineno(),
+ tree relational_expression = build2_loc(gg_token_location(),
compare,
boolean_type_node,
operand_a,
@@ -1891,7 +1889,7 @@ gg_create_goto_pair(tree *goto_expr,
void
gg_goto_label_decl(tree label_decl)
{
- tree goto_expr = build1_loc( location_from_lineno(),
+ tree goto_expr = build1_loc( gg_token_location(),
GOTO_EXPR,
void_type_node,
label_decl);
@@ -1938,7 +1936,7 @@ gg_create_goto_pair(tree *goto_expr, tree *label_expr, const char *name)
void
gg_goto(tree var_decl_pointer)
{
- tree go_to = build1_loc(location_from_lineno(),
+ tree go_to = build1_loc(gg_token_location(),
GOTO_EXPR,
void_type_node,
var_decl_pointer);
@@ -2186,7 +2184,7 @@ gg_printf(const char *format_string, ...)
function = gg_get_function_address(INT, "__gg__fprintf_stderr");
}
- tree stmt = build_call_array_loc (location_from_lineno(),
+ tree stmt = build_call_array_loc (gg_token_location(),
INT,
function,
nargs,
@@ -2233,7 +2231,7 @@ gg_fprintf(tree fd, int nargs, const char *format_string, ...)
function = gg_get_function_address(INT, "sprintf");
}
- tree stmt = build_call_array_loc (location_from_lineno(),
+ tree stmt = build_call_array_loc (gg_token_location(),
INT,
function,
argc,
@@ -2280,7 +2278,7 @@ void
gg_memset(tree dest, const tree value, tree size)
{
tree the_call =
- build_call_expr_loc(location_from_lineno(),
+ build_call_expr_loc(gg_token_location(),
builtin_decl_explicit (BUILT_IN_MEMSET),
3,
dest,
@@ -2294,7 +2292,7 @@ gg_memchr(tree buf, tree ch, tree length)
{
tree the_call = fold_convert(
pvoid_type_node,
- build_call_expr_loc(location_from_lineno(),
+ build_call_expr_loc(gg_token_location(),
builtin_decl_explicit (BUILT_IN_MEMCHR),
3,
buf,
@@ -2309,7 +2307,7 @@ void
gg_memcpy(tree dest, const tree src, tree size)
{
tree the_call = build_call_expr_loc(
- location_from_lineno(),
+ gg_token_location(),
builtin_decl_explicit (BUILT_IN_MEMCPY),
3,
dest,
@@ -2324,7 +2322,7 @@ void
gg_memmove(tree dest, const tree src, tree size)
{
tree the_call = build_call_expr_loc(
- location_from_lineno(),
+ gg_token_location(),
builtin_decl_explicit (BUILT_IN_MEMMOVE),
3,
dest,
@@ -2357,7 +2355,7 @@ void
gg_strcpy(tree dest, tree src)
{
tree the_call =
- build_call_expr_loc(location_from_lineno(),
+ build_call_expr_loc(gg_token_location(),
builtin_decl_explicit (BUILT_IN_STRCPY),
2,
dest,
@@ -2370,7 +2368,7 @@ gg_strcmp(tree A, tree B)
{
tree the_call = fold_convert(
integer_type_node,
- build_call_expr_loc(location_from_lineno(),
+ build_call_expr_loc(gg_token_location(),
builtin_decl_explicit (BUILT_IN_STRCMP),
2,
A,
@@ -2402,7 +2400,7 @@ gg_strncmp(tree char_star_A, tree char_star_B, tree size_t_N)
{
tree the_call = fold_convert(
integer_type_node,
- build_call_expr_loc(location_from_lineno(),
+ build_call_expr_loc(gg_token_location(),
builtin_decl_explicit (BUILT_IN_STRNCMP),
3,
char_star_A,
@@ -2433,7 +2431,7 @@ gg_return(tree operand)
{
// When there is no operand, or if the function result is void, then
// we just generate a return_expr.
- stmt = build1_loc(location_from_lineno(), RETURN_EXPR, void_type_node, NULL_TREE);
+ stmt = build1_loc(gg_token_location(), RETURN_EXPR, void_type_node, NULL_TREE);
}
else
{
@@ -2443,7 +2441,7 @@ gg_return(tree operand)
function_type,
DECL_RESULT(current_function->function_decl),
gg_cast(function_type, operand));
- stmt = build1_loc(location_from_lineno(), RETURN_EXPR, void_type_node, modify);
+ stmt = build1_loc(gg_token_location(), RETURN_EXPR, void_type_node, modify);
}
gg_append_statement(stmt);
}
@@ -2451,7 +2449,7 @@ gg_return(tree operand)
void
chain_parameter_to_function(tree function_decl, const tree param_type, const char *name)
{
- tree parm = build_decl (location_from_lineno(),
+ tree parm = build_decl (gg_token_location(),
PARM_DECL,
get_identifier (name),
param_type);
@@ -2686,7 +2684,7 @@ gg_define_function( tree return_type,
}
// Establish the RESULT_DECL for the function:
- tree resdecl = build_decl (location_from_lineno(), RESULT_DECL, NULL_TREE, return_type);
+ tree resdecl = build_decl (gg_token_location(), RESULT_DECL, NULL_TREE, return_type);
DECL_CONTEXT (resdecl) = function_decl;
DECL_RESULT (function_decl) = resdecl;
@@ -2818,7 +2816,7 @@ gg_get_function_decl(tree return_type, const char *funcname, ...)
}
// Establish the RESULT_DECL for the function:
- tree resdecl = build_decl (location_from_lineno(), RESULT_DECL, NULL_TREE, return_type);
+ tree resdecl = build_decl (gg_token_location(), RESULT_DECL, NULL_TREE, return_type);
DECL_CONTEXT (resdecl) = function_decl;
DECL_RESULT (function_decl) = resdecl;
@@ -3076,7 +3074,7 @@ gg_call_expr(tree return_type, const char *function_name, ...)
tree the_func_addr = build1(ADDR_EXPR,
build_pointer_type (TREE_TYPE(function_decl)),
function_decl);
- tree the_call = build_call_array_loc(location_from_lineno(),
+ tree the_call = build_call_array_loc(gg_token_location(),
return_type,
the_func_addr,
nargs,
@@ -3132,7 +3130,7 @@ gg_call(tree return_type, const char *function_name, ...)
tree the_func_addr = build1(ADDR_EXPR,
build_pointer_type (TREE_TYPE(function_decl)),
function_decl);
- tree the_call = build_call_array_loc(location_from_lineno(),
+ tree the_call = build_call_array_loc(gg_token_location(),
return_type,
the_func_addr,
nargs,
@@ -3157,7 +3155,7 @@ gg_call_expr_list(tree return_type, tree function_pointer, int param_count, tree
// Avoid that with something like
// gg_assign( dest, gg_call_expr_list(...) );
- tree the_call = build_call_array_loc(location_from_lineno(),
+ tree the_call = build_call_array_loc(gg_token_location(),
return_type,
function_pointer,
param_count,
@@ -3192,7 +3190,7 @@ void
gg_exit(tree exit_code)
{
tree the_call =
- build_call_expr_loc(location_from_lineno(),
+ build_call_expr_loc(gg_token_location(),
builtin_decl_explicit (BUILT_IN_EXIT),
1,
exit_code);
@@ -3203,7 +3201,7 @@ void
gg_abort()
{
tree the_call =
- build_call_expr_loc(location_from_lineno(),
+ build_call_expr_loc(gg_token_location(),
builtin_decl_explicit (BUILT_IN_ABORT),
0);
gg_append_statement(the_call);
@@ -3214,7 +3212,7 @@ gg_strlen(tree psz)
{
tree the_call = fold_convert(
size_type_node,
- build_call_expr_loc(location_from_lineno(),
+ build_call_expr_loc(gg_token_location(),
builtin_decl_explicit (BUILT_IN_STRLEN),
1,
psz));
@@ -3226,7 +3224,7 @@ gg_strdup(tree psz)
{
tree the_call = fold_convert(
build_pointer_type(char_type_node),
- build_call_expr_loc(location_from_lineno(),
+ build_call_expr_loc(gg_token_location(),
builtin_decl_explicit (BUILT_IN_STRDUP),
1,
psz));
@@ -3240,7 +3238,7 @@ gg_malloc(tree size)
{
tree the_call = fold_convert(
pvoid_type_node,
- build_call_expr_loc(location_from_lineno(),
+ build_call_expr_loc(gg_token_location(),
builtin_decl_explicit (BUILT_IN_MALLOC),
1,
size));
@@ -3252,7 +3250,7 @@ gg_realloc(tree base, tree size)
{
tree the_call = fold_convert(
pvoid_type_node,
- build_call_expr_loc(location_from_lineno(),
+ build_call_expr_loc(gg_token_location(),
builtin_decl_explicit (BUILT_IN_REALLOC),
2,
base,
@@ -3276,7 +3274,7 @@ void
gg_free(tree pointer)
{
tree the_call =
- build_call_expr_loc(location_from_lineno(),
+ build_call_expr_loc(gg_token_location(),
builtin_decl_explicit (BUILT_IN_FREE),
1,
pointer);
@@ -3377,18 +3375,6 @@ gg_string_literal(const char *string)
return build_string_literal(strlen(string)+1, string);
}
-void
-gg_set_current_line_number(int line_number)
- {
- sv_current_line_number = line_number;
- }
-
-int
-gg_get_current_line_number()
- {
- return sv_current_line_number;
- }
-
tree
gg_trans_unit_var_decl(const char *var_name)
{
@@ -3410,7 +3396,7 @@ gg_insert_into_assembler(const char ach[])
if( !optimize )
{
// Create the required generic tag
- tree asm_expr = build5_loc( location_from_lineno(),
+ tree asm_expr = build5_loc( gg_token_location(),
ASM_EXPR,
VOID,
build_string(strlen(ach), ach),
@@ -3447,5 +3433,28 @@ gg_insert_into_assemblerf(const char *format, ...)
gg_insert_into_assembler(ach);
}
}
+#pragma GCC diagnostic pop
+
+static location_t sv_token_location_override = 0;
-#pragma GCC diagnostic pop \ No newline at end of file
+void
+token_location_override(location_t loc)
+ {
+ sv_token_location_override = loc;
+ }
+
+location_t
+gg_token_location()
+ {
+ location_t retval;
+ if( sv_token_location_override )
+ {
+ retval = sv_token_location_override;
+ sv_token_location_override = 0;
+ }
+ else
+ {
+ retval = current_token_location();
+ }
+ return retval;
+ }
diff --git a/gcc/cobol/gengen.h b/gcc/cobol/gengen.h
index 06b28e06..96e69dd 100644
--- a/gcc/cobol/gengen.h
+++ b/gcc/cobol/gengen.h
@@ -525,11 +525,11 @@ extern tree gg_indirect(tree pointer, tree byte_offset = NULL_TREE);
extern tree gg_string_literal(const char *string);
#define CURRENT_LINE_NUMBER (cobol_location().first_line)
-extern location_t location_from_lineno();
-
-// When set to true, use UNKNOWN_LOCATION instead of CURRENT_LINE_NUMBER
-extern void gg_set_current_line_number(int line_number);
-extern int gg_get_current_line_number();
+extern location_t gg_token_location();
+extern location_t current_token_location();
+extern location_t current_location_minus_one();
+extern void current_location_minus_one_clear();
+extern void token_location_override(location_t loc);
extern tree gg_trans_unit_var_decl(const char *var_name);
diff --git a/gcc/cobol/genmath.cc b/gcc/cobol/genmath.cc
index e74aebd..e7eb971 100644
--- a/gcc/cobol/genmath.cc
+++ b/gcc/cobol/genmath.cc
@@ -610,7 +610,7 @@ static bool
fast_divide(size_t nC, cbl_num_result_t *C,
size_t nA, cbl_refer_t *A,
size_t nB, cbl_refer_t *B,
- cbl_refer_t remainder)
+ const cbl_refer_t &remainder)
{
bool retval = false;
if( all_results_binary(nC, C) )
diff --git a/gcc/cobol/genutil.cc b/gcc/cobol/genutil.cc
index 20b47ab..7895ea8 100644
--- a/gcc/cobol/genutil.cc
+++ b/gcc/cobol/genutil.cc
@@ -305,7 +305,7 @@ static
void
get_and_check_refstart_and_reflen( tree refstart,// LONG returned value
tree reflen, // LONG returned value
- cbl_refer_t &refer)
+ const cbl_refer_t &refer)
{
const cbl_enabled_exceptions_t&
enabled_exceptions( cdf_enabled_exceptions() );
@@ -542,8 +542,8 @@ get_depending_on_value(tree retval, const cbl_refer_t &refer)
static
tree
-get_data_offset(cbl_refer_t &refer,
- int *pflags = NULL)
+get_data_offset(const cbl_refer_t &refer,
+ int *pflags = NULL)
{
Analyze();
// This routine returns a tree which is the size_t offset to the data in the
@@ -1974,7 +1974,7 @@ refer_is_clean(const cbl_refer_t &refer)
*/
static
tree // size_t
-refer_refmod_length(cbl_refer_t &refer)
+refer_refmod_length(const cbl_refer_t &refer)
{
Analyze();
REFER("refstart and reflen");
@@ -2017,8 +2017,8 @@ refer_fill_depends(const cbl_refer_t &refer)
}
tree // size_t
-refer_offset(cbl_refer_t &refer,
- int *pflags)
+refer_offset(const cbl_refer_t &refer,
+ int *pflags)
{
// This routine calculates the effect of a refer offset on the
// refer.field->data location. When there are subscripts, the data location
@@ -2045,7 +2045,7 @@ refer_offset(cbl_refer_t &refer,
static
tree // size_t
-refer_size(cbl_refer_t &refer, refer_type_t refer_type)
+refer_size(const cbl_refer_t &refer, refer_type_t refer_type)
{
Analyze();
static tree retval = gg_define_variable(SIZE_T, "..rs_retval", vs_file_static);
@@ -2086,13 +2086,13 @@ refer_size(cbl_refer_t &refer, refer_type_t refer_type)
}
tree // size_t
-refer_size_dest(cbl_refer_t &refer)
+refer_size_dest(const cbl_refer_t &refer)
{
return refer_size(refer, refer_dest);
}
tree // size_t
-refer_size_source(cbl_refer_t &refer)
+refer_size_source(const cbl_refer_t &refer)
{
/* There are oddities involved with refer_size_source and refer_size_dest.
See the comments in refer_has_depends for some explanation. There are
@@ -2129,7 +2129,7 @@ refer_size_source(cbl_refer_t &refer)
}
tree
-qualified_data_location(cbl_refer_t &refer)
+qualified_data_location(const cbl_refer_t &refer)
{
return gg_add(member(refer.field->var_decl_node, "data"),
refer_offset(refer));
diff --git a/gcc/cobol/genutil.h b/gcc/cobol/genutil.h
index 20783e1..f12124e 100644
--- a/gcc/cobol/genutil.h
+++ b/gcc/cobol/genutil.h
@@ -140,12 +140,12 @@ char *get_literal_string(cbl_field_t *field);
bool refer_is_clean(const cbl_refer_t &refer);
-tree refer_offset(cbl_refer_t &refer,
+tree refer_offset(const cbl_refer_t &refer,
int *pflags=NULL);
-tree refer_size_source(cbl_refer_t &refer);
-tree refer_size_dest(cbl_refer_t &refer);
+tree refer_size_source(const cbl_refer_t &refer);
+tree refer_size_dest(const cbl_refer_t &refer);
-tree qualified_data_location(cbl_refer_t &refer);
+tree qualified_data_location(const cbl_refer_t &refer);
void build_array_of_treeplets( int ngroup,
size_t N,
diff --git a/gcc/cobol/parse.y b/gcc/cobol/parse.y
index 7bcbf74..59cc64d 100644
--- a/gcc/cobol/parse.y
+++ b/gcc/cobol/parse.y
@@ -801,6 +801,7 @@
%type <boolean> io_invalid read_eof write_eop
global is_global anycase backward
end_display
+ exh_changed exh_named
%type <number> mistake globally first_last
%type <io_mode> io_mode
@@ -1012,7 +1013,9 @@
%right IF THEN ELSE
SENTENCE
ACCEPT ADD ALTER CALL CANCEL CLOSE COMPUTE CONTINUE
- DELETE DISPLAY DIVIDE EVALUATE END EOP EXIT FILLER_kw
+ DELETE DISPLAY DIVIDE
+ EVALUATE END EOP EXIT
+ FILLER_kw
GOBACK GOTO
INITIALIZE INSPECT
MERGE MOVE MULTIPLY OPEN OVERFLOW_kw PARAGRAPH PERFORM
@@ -5052,6 +5055,7 @@ statement: error {
| divide { $$ = DIVIDE; }
| entry { $$ = ENTRY; }
| evaluate { $$ = EVALUATE; }
+ | exhibit_stmt { $$ = EXHIBIT; }
| exit { $$ = EXIT; }
| free { $$ = FREE; }
| go_to { $$ = GOTO; }
@@ -5687,6 +5691,20 @@ disp_upon: device_name {
}
;
+exhibit_stmt: EXHIBIT exh_changed exh_named vargs {
+ statement_begin(@1, EXHIBIT);
+ std::vector<cbl_refer_t> args( $vargs->args.begin(),
+ $vargs->args.end() );
+ parser_exhibit( $exh_changed, $exh_named, args );
+ }
+ ;
+exh_changed: %empty { $$ = false; }
+ | CHANGED { $$ = true; }
+ ;
+exh_named: %empty { $$ = false; }
+ | NAMED { $$ = true; }
+ ;
+
divide: divide_impl end_divide { ast_divide($1); }
| divide_cond end_divide { ast_divide($1); }
;
@@ -7636,6 +7654,7 @@ perform_cond: UNTIL { parser_perform_conditional( &perform_current()->tgt); }
perform_inline: perform_start statements END_PERFORM
{
location_set(@END_PERFORM);
+ parser_sleep(*cbl_refer_t::empty());
$$ = perform_current();
if( $perform_start == LOCATION ) {
error_msg(@1, "LOCATION not valid with PERFORM Format 2");
@@ -7644,6 +7663,7 @@ perform_inline: perform_start statements END_PERFORM
| perform_start END_PERFORM
{
location_set(@END_PERFORM);
+ parser_sleep(*cbl_refer_t::empty());
$$ = perform_current();
if( $perform_start == LOCATION ) {
error_msg(@1, "LOCATION not valid with PERFORM Format 2");
@@ -11788,7 +11808,7 @@ label_add( const YYLTYPE& loc,
name, cbl_label_of(p)->name, cbl_label_of(p)->line);
}
}
- struct cbl_label_t label = { type, parent, loc.last_line };
+ struct cbl_label_t label = { type, parent, loc.first_line };
if( !namcpy(loc, label.name, name) ) return NULL;
auto p = symbol_label_add(PROGRAM, &label);
diff --git a/gcc/cobol/parse_ante.h b/gcc/cobol/parse_ante.h
index fa06e6c..03cb0a0 100644
--- a/gcc/cobol/parse_ante.h
+++ b/gcc/cobol/parse_ante.h
@@ -103,7 +103,7 @@ void input_file_status_notify();
} \
location_dump("parse.c", __LINE__, "current", (Current)); \
input_file_status_notify(); \
- gcc_location_set( location_set(Current) ); \
+ location_set(Current); \
} while (0)
int yylex(void);
@@ -3493,18 +3493,18 @@ goodnight_gracie() {
// false after USE statement, to enter Declarative with EC intact.
static bool statement_cleanup = true;
+static YYLTYPE current_location;
static void statement_epilog( int token );
const char * keyword_str( int token );
-static YYLTYPE current_location;
-
const YYLTYPE& cobol_location() { return current_location; }
-static inline YYLTYPE
+static inline void
location_set( const YYLTYPE& loc ) {
- return current_location = loc;
+ current_location = loc;
+ gcc_location_set(loc);
}
static void statement_begin( const YYLTYPE& loc, int token );
diff --git a/gcc/cobol/scan.l b/gcc/cobol/scan.l
index 8b5dc25..2da38d8 100644
--- a/gcc/cobol/scan.l
+++ b/gcc/cobol/scan.l
@@ -89,6 +89,7 @@ EOL \r?\n
BLANK_EOL [[:blank:]]*{EOL}
BLANK_OEOL [[:blank:]]*{EOL}?
+PICTURE [^[:space:]]+
DOTSEP [.]+[[:space:]]
DOTEOL [[:blank:]]*[.]{BLANK_EOL}
@@ -176,7 +177,7 @@ SIZE_ERROR (ON[[[:space:]]+)?SIZE[[:space:]]+ERROR
VARTYPE NUMERIC|ALPHABETIC|ALPHABETIC_LOWER|ALPHABETIC_UPPER|DBCS|KANJI
NAMTYP {NAME}|{VARTYPE}
-NL [[:blank:]]*\r?\n[[:blank:]]*
+NL [[:blank:]]*{EOL}[[:blank:]]*
PUSH_FILE \f?[#]FILE{SPC}PUSH{SPC}[^\f]+\f
POP_FILE \f?[#]FILE{SPC}POP\f
@@ -965,7 +966,9 @@ USE({SPC}FOR)? { return USE; }
return NUMSTR;
}
- PIC(TURE)?({SPC}IS)?[[:space:]]{BLANK_OEOL} {
+ PIC(TURE)?({SPC}IS)?{SPC}{PICTURE} {
+ auto pos = validate_picture();
+ myless(pos);
yy_push_state(picture); return PIC; }
ANY { return ANY; }
@@ -1147,7 +1150,7 @@ USE({SPC}FOR)? { return USE; }
yy_push_state(hex_state); }
N?X{nonseq} { dbgmsg("invalid hexadecimal value: %s", yytext);
return NO_CONDITION; }
- [[:blank:]]*\r?\n {}
+ [[:blank:]]*{EOL} {}
WORKING-STORAGE{SPC}SECTION { return WORKING_STORAGE_SECT; }
LOCAL-STORAGE{SPC}SECTION { return LOCAL_STORAGE_SECT; }
@@ -1217,7 +1220,7 @@ USE({SPC}FOR)? { return USE; }
{NP}V?/[,.]? { yylval.number = ndigit(yyleng); return picset(PIC_P); }
{N9}*V/{N9}* { yylval.number = ndigit(yyleng - 1); return picset(NINEV); }
{N9}/{N9}*[,.]? { yylval.number = ndigit(yyleng); return picset(NINES); }
- P+/[,.]?\r?\n { yylval.number = yyleng; return picset(PIC_P); }
+ P+/[,.]?{EOL} { yylval.number = yyleng; return picset(PIC_P); }
1{1,31}/({COUNT}|[(]{NAME}[)]) {
yy_push_state(picture_count);
@@ -1316,7 +1319,7 @@ USE({SPC}FOR)? { return USE; }
[""]{SPC}[&]{SPC}[""''] {
if( yytext[yyleng - 1] == '\'' ) BEGIN(quoted1);
}
- [""]-{OSPC}(\r?\n{OSPC})+[""] /* continue ... */
+ [""]-{OSPC}({EOL}{OSPC})+[""] /* continue ... */
[""] {
char *s = xstrdup(tmpstring? tmpstring : "\0");
yylval.literal.set_data(strlen(s), s);
@@ -1333,7 +1336,7 @@ USE({SPC}FOR)? { return USE; }
['']{SPC}[&]{SPC}[""''] {
if( yytext[yyleng - 1] == '"' ) BEGIN(quoted2);
}
- ['']-{OSPC}(\r?\n{OSPC})+[''] /* continue ... */
+ ['']-{OSPC}({EOL}{OSPC})+[''] /* continue ... */
[''] {
char *s = xstrdup(tmpstring? tmpstring : "\0");
yylval.literal.set_data(strlen(s), s);
@@ -2040,7 +2043,7 @@ BASIS { yy_push_state(basis); return BASIS; }
return symbol_file(PROGRAM, yytext)? FILENAME : NAME;
}
[[:blank:]]+
- \r?\n { yy_pop_state(); }
+ {EOL} { yy_pop_state(); }
}
<raising>{
@@ -2169,7 +2172,7 @@ BASIS { yy_push_state(basis); return BASIS; }
<*>{DOTSEP} { return '.'; }
<*>[().=*/+&-] { return *yytext; }
<*>[[:blank:]]+
-<*>\r?\n
+<*>{EOL}
<*>{
{COMMA}
diff --git a/gcc/cobol/scan_ante.h b/gcc/cobol/scan_ante.h
index 6128a3f..19ceb2b 100644
--- a/gcc/cobol/scan_ante.h
+++ b/gcc/cobol/scan_ante.h
@@ -694,6 +694,387 @@ picset( int token ) {
return token;
}
+/**
+## Script and data to produce picture_t::followers.
+## Based on ISO Table 10.
+#! /usr/bin/awk -f
+
+BEGIN {
+ str = "B0/ , . + +- +- CR/DB cs cs Z* Z* + + cs cs 9 AX S V P P 1 N E"
+ split(str, cols)
+}
+
+$1 ~ /CR|DB|cs/ { next }
+
+0 && !nlines++ {
+ for( i=0; i < length(cols); i++ ) {
+ print i, cols[i], "'" $i "'"
+ }
+}
+
+$field == "x" {
+ if( ! nout++ ) {
+ printf "%2d: %5s: \"", field, cols[field - 1]
+ }
+
+ gsub(/^ +| +$/, "", $1)
+ printf "%s", $1
+}
+
+END {
+ if( ! nout++ ) {
+ printf "%2d: %5s: \"", field, cols[field - 1]
+ }
+ print "\""
+}
+
+B x x x - x - - x - x x x x x x x x - x - x - x
+0 x x x - x - - x - x x x x x x x x - x - x - x
+/ x x x - x - - x - x x x x x x x x - x - x - x
+, x x x - x - - x - x x x x x x x - - x - x
+. x x - - x - - x - x - x - x - x
++ - - - - - - - - - - - - - - - - - - - - - - - x
++
+–
++ x x x - - - - x x x x - - x x x - - x x x
+CR x x x - - - - x x x x - - x x x - - x x x
+DB x x x - - - - x x x x - - x x x - - x x x
+cs - - - - x
+cs x x x - x - - - - x x - - - - x - - x x x
+
+Z x x - - x - - x - x
+* x x - - x - - x - x
+Z x x x - x - - x - x x - - - - - - - x - x
+* x x x - x - - x - x x - - - - - - - x - x
++ x x - - - - - x - - - x
+– x x - - - - - x - - - x
++ x x x - - - - x - - - x x - - - - - x
+– x x x - - - - x - - - x x - - - - - x
+cs x x - - x - - - - - - - - x
+cs x x x - x - - - - - - - - x x - - - x
+
+9 x x x x x - - x - x - x - x - x x x x - x - - x
+A x - - - - - - - - - - - - - - x x
+X x - - - - - - - - - - - - - - x x
+S
+V x x - - x - - x - x - x - x - x - x - x
+P x x - - x - - x - x - x - x - x - x - x
+P - - - - x - - x - - - - - - - - - x x - x
+1 - - - - - - - - - - - - - - - - - - - - - x
+N x - - - - - - - - - - - - - - - - - - - - - x
+E x x x - x - - - - - - - - - - x
+**/
+
+class picture_t {
+ static const char dot = '.', comma = ',';
+
+ typedef std::vector<std::string> followings_t;
+ static const std::map <char, followings_t> followers;
+
+ const char * const begin;
+ const char *p, *pend;
+ size_t pos;
+ struct exclusions_t { // Nonzero if set, > 1 is false.
+ // crdb means CR/DB or +/-.
+ // pluses means 2 or more consecutive '+'.
+ // minuses means 2 or more consecutive '-'.
+ // "21) The symbol 'Z' and the symbol '*' are mutually exclusive "
+ // stars means '*' or Z.
+ unsigned short int crdb, currency, dot, pluses, minuses, stars, zzz;
+ exclusions_t()
+ : crdb(0), currency(0), dot(0), pluses(0), minuses(0), stars(0)
+ {}
+ } exclusions;
+ YYLTYPE loc;
+
+ bool is_crdb() const { // input must be uppercase for CR/DB
+ if( p[0] == 'C' || p[0] == 'D' ) {
+ char input[3] = { p[0], p[1] };
+ return ( 0 == strcmp(input, "CR") || 0 == strcmp(input, "DB") );
+ }
+ return false;
+ }
+
+ const char * match_paren( const char *paren ) const {
+ gcc_assert(paren[0] == '('); // start with opening paren
+ paren = std::find_if( paren, pend,
+ []( char ch ) {
+ return ch == '(' || ch == ')';
+ } );
+ if( *paren == '(' ) return nullptr; // no nesting
+ if( paren == pend ) return nullptr;
+ return ++paren;
+ }
+
+ const char * next_not( char ch ) const {
+ return std::find_if( p, pend,
+ [ch = TOUPPER(ch)]( char next ) {
+ return ch != next;
+ } );
+ }
+
+ const char * valid_next( const char *p, const std::string& valid ) const {
+ if( p == pend || p + 1 == pend ) return pend;
+ if( p[1] == '(' ) {
+ return match_paren(++p);
+ }
+ auto pv = std::find(valid.begin(), valid.end(), TOUPPER(p[1]));
+ return pv != valid.end()? ++p : nullptr;
+ }
+ const char * valid_next( const char *p,
+ bool first = true, char ch = '\0' ) const {
+ if( p == pend || p + 1 == pend ) return pend;
+ if( p[0] == '(' ) {
+ if( (p = match_paren(p)) == nullptr ) return nullptr;
+ }
+ if( p[0] == '(' ) return nullptr; // consecutive parentheses
+
+ int index = first? 0 : 1;
+ if( !ch ) ch = *p; // use current character unless overridden
+ auto valid = followers.find(TOUPPER(ch));
+ if( valid == followers.end() ) {
+ YYLTYPE loc(yylloc);
+ loc.first_column += int(p - begin);
+ error_msg( loc, "PICTURE: strange character %qc, giving up", ch );
+ return nullptr;
+ }
+ return valid_next(p, valid->second[index]);
+ }
+
+ const char * start() { // start modifies exclusions, but not p
+ auto pnext = p;
+
+ switch(TOUPPER(p[0])) {
+ case comma: case dot:
+ // use decimal_is_comma()
+ // 4: .: "B0/,+Z*+-9E"
+ exclusions.dot++;
+ pnext = valid_next(p, "B0/,+Z*+-9E");
+ break;
+ case '+': case '-':
+ // 6: +-: "B0/,.Z*Z*9VPPE"
+ exclusions.crdb++;
+ pnext = next_not(p[0]);
+ if( p + 1 < pnext ) {
+ exclusions.pluses++;
+ }
+ pnext = valid_next(--pnext, "B0/,.Z*Z*9VPPE");
+ break;
+ case 'Z': case '*':
+ exclusions.stars++;
+ pnext = next_not(p[0]);
+ break;
+ case 'S':
+ // 19: S: "9VP"
+ pnext = valid_next(p, "9VP");
+ break;
+ }
+
+ /*
+ * "For fixed editing sign control, the currency symbol, when used, shall
+ * be either the leftmost symbol in character-string-1, optionally preceded
+ * by one of the symbols '+' or '-' "
+ */
+ if( pnext ) {
+ if( p == pnext || p[0] == '+' || p[0] == '-' ) {
+ if( symbol_currency(*pnext) ) {
+ exclusions.currency++;
+ pnext = next_not(*pnext);
+ pnext = valid_next(--pnext, true, '$');
+ }
+ }
+ }
+
+ return pnext;
+ }
+
+ const char * next() { // modify state; do not modify position
+ auto pnext = p;
+ auto loc(picture_t::loc);
+ loc.first_column += int(p - begin);
+
+ if( is_crdb() ) {
+ if( exclusions.crdb++ ) {
+ error_msg( loc, "PICTURE: CR/DB and %c/%c may appear only once", '+', '-' );
+ return nullptr;
+ }
+ if( p + 2 != pend ) {
+ error_msg( loc, "PICTURE: CR/DB must appear at the end" );
+ return nullptr;
+ }
+ return pend;
+ }
+
+ if( symbol_currency(p[0]) ) {
+ if( false && exclusions.currency++ ) { // not enforced
+ error_msg( loc, "PICTURE: CURRENCY SYMBOL sequence may appear at most once" );
+ return nullptr;
+ }
+ return valid_next(p, ! exclusions.dot, '$');
+ }
+
+ switch(TOUPPER(p[0])) {
+ case '(':
+ return match_paren(p);
+ break;
+ case 'B': case '0': case '/':
+ pnext = valid_next(p);
+ break;
+ case comma:
+ if( decimal_is_comma() ) {
+ if( exclusions.dot++ ) {
+ error_msg( loc, "PICTURE: %qc: may appear at most once", p[0] );
+ return nullptr;
+ }
+ pnext = valid_next(p, true, dot);
+ } else {
+ pnext = valid_next(p);
+ }
+ break;
+ case dot:
+ if( p + 1 == pend ) {
+ pnext = pend;
+ } else {
+ if( decimal_is_comma() ) {
+ pnext = valid_next(p, true, comma );
+ } else {
+ if( exclusions.dot++ ) {
+ error_msg( loc, "PICTURE: %qc: may appear at most once", p[0] );
+ return nullptr;
+ }
+ pnext = valid_next(p);
+ }
+ }
+ break;
+
+ case '+': case '-':
+ // 7 is trailing sign; 13 & 14 are numeric. Leading sign handled by start().
+ if( p + 1 == pend ) {
+ if( exclusions.crdb++ ) {
+ error_msg( loc, "PICTURE: %c/%c may appear at most once as a sign", '+', '-' );
+ return nullptr;
+ }
+ pnext = pend;
+ } else {
+ pnext = next_not(p[0]);
+ if( p + 1 < pnext ) {
+ if( false && exclusions.pluses++ ) { // not enforced
+ error_msg( loc, "PICTURE: %qc: sequence may appear at most once", p[0] );
+ return nullptr;
+ }
+ }
+ pnext = valid_next(pnext, ! exclusions.dot);
+ }
+ break;
+
+ case 'Z': case '*':
+ if( false && exclusions.stars++ ) { // not enforced
+ error_msg( loc, "PICTURE: %qc: sequence may appear at most once", p[0] );
+ return nullptr;
+ }
+ if( (pnext = next_not(p[0])) == nullptr ) return pnext;
+ pnext = valid_next(pnext, ! exclusions.dot);
+ break;
+ case 'P':
+ pnext = valid_next(pnext, ! exclusions.dot);
+ break;
+ case '9':
+ case 'A': case 'X':
+ case 'V':
+ case '1':
+ case 'N':
+ pnext = valid_next(p);
+ break;
+ case 'E':
+ pnext = valid_next(p, "+9");
+ if( pnext && *pnext == '+' ) {
+ pnext = valid_next(p, "9");
+ }
+ break;
+ default:
+ error_msg( loc, "PICTURE: %qc: invalid character", p[0] );
+ return nullptr;
+ }
+ return pnext;
+ }
+
+ public:
+ picture_t( const char *p, int len )
+ : begin(p)
+ , p(p), pend(p + len)
+ , loc(yylloc)
+ {
+ assert(TOUPPER(*p) == 'P'); // as in PICTURE (or PICTURE IS)
+ // move p to start of picture string
+ while( (p = std::find_if(p, pend, fisspace)) != pend ) {
+ this->p = p = std::find_if(p, pend,
+ []( char ch ) { return ! fisspace(ch); } );
+ }
+ assert(this->p != pend);
+ pos = this->p - begin;
+ }
+
+ bool is_valid() {
+ if( !p ) return false;
+ if( (p = start()) == nullptr ) {
+ return false;
+ }
+
+ while( p && p < pend) {
+ p = next();
+ }
+ return p == pend;
+ }
+
+ int starts_at() const { return pos; }
+};
+
+/*
+ * The Followers map gives 1 or 2 lists of valid characters following a
+ * character, the one in the key. If there are two lists, the correct one is
+ * determined by the caller based on the state of the picture string, i.e.,
+ * what has been seen before.
+ */
+const std::map <char, picture_t::followings_t> picture_t::followers {
+ /* B0/ */ { 'B', {"B0/,.Z*+-9AXVPNE" } },
+ /* B0/ */ { '0', {"B0/,.Z*+-9AXVPNE" } },
+ /* B0/ */ { '/', {"B0/,.Z*+-9AXVPNE" } },
+ /* , */ { ',', {"B0/,.Z*+-9VPE"} },
+ /* . */ { '.', {"B0/,Z*+-9E"} },
+ /* + { '+', "9" }, */
+ /* +- */ { '+', {"B0/,.Z*9VPE", "" } },
+ /* +- */ { '-', {"B0/,.Z*9VPE", "" } },
+ /* CR/DB { 'C', "" }, */
+ /* cs { 'c', "B0/,.Z*+-9VP" }, */
+ /* cs { 'c', "+" }, */
+ /* Z* */ { 'Z', {"B0/,.+Z*9VP", "B0/,+Z*"} },
+ /* Z* */ { '*', {"B0/,.+Z*9VP", "B0/,+Z*"} },
+ /* + */ { '+', {"B0/,.+-9VP", "B0/,+-"} },
+ /* cs */ { '$', {"B0/,.+9VP", "B0/,+"} },
+ /* 9 */ { '9', {"B0/,.+9AXVPE"} },
+ /* AX */ { 'A', {"B0/9AX"} },
+ /* AX */ { 'X', {"B0/9AX"} },
+ /* S */ { 'S', {"9VP"} },
+ /* V */ { 'V', {"B0/,+Z*+-9P"} },
+ /* P */ { 'P', {"+VP", "B0/,+Z*9P"} },
+ /* 1 */ { '1', {"1"} },
+ /* N */ { 'N', {"B0/N"} },
+ /* E */ { 'E', {"+9"} },
+};
+
+/*
+ * Although picture_t::is_valid return a bool, it's not used. The validation
+ * routines emit messages where the error is detected. The entire string is
+ * subsequently parsed by the parser, which might otherwise accept an invalid
+ * string, but will usually emit a message of its own.
+ */
+static int
+validate_picture() {
+ picture_t picture(yytext, yyleng);
+ picture.is_valid();
+ return picture.starts_at();
+}
+
static inline bool
is_integer_token( int *pvalue = NULL ) {
int v, n = 0;
diff --git a/gcc/cobol/symbols.cc b/gcc/cobol/symbols.cc
index aaaa6f3..7d6a955 100644
--- a/gcc/cobol/symbols.cc
+++ b/gcc/cobol/symbols.cc
@@ -4249,6 +4249,11 @@ symbol_currency( char sign ) {
if( currencies.size() == 0 ) {
currencies['$'] = "$";
}
+ if( sign == '\0' ) { // default
+ auto result = currencies.begin();
+ gcc_assert(result != currencies.end());
+ return result->second;
+ }
auto result = currencies.find(sign);
return result == currencies.end()? NULL : result->second;
}
diff --git a/gcc/cobol/symbols.h b/gcc/cobol/symbols.h
index c3de0aa..c8ae32f 100644
--- a/gcc/cobol/symbols.h
+++ b/gcc/cobol/symbols.h
@@ -2613,7 +2613,7 @@ symbol_field_same_as( cbl_field_t *tgt, const cbl_field_t *src );
size_t symbol_file_same_record_area( std::list<cbl_file_t*>& files );
bool symbol_currency_add( const char symbol[], const char sign[] = NULL );
-const char * symbol_currency( char symbol );
+const char * symbol_currency( char symbol = '\0' );
const char * symbol_type_str( enum symbol_type_t type );
const char * cbl_field_type_str( enum cbl_field_type_t type );
diff --git a/gcc/cobol/util.cc b/gcc/cobol/util.cc
index 6439f23..2a7bf2b 100644
--- a/gcc/cobol/util.cc
+++ b/gcc/cobol/util.cc
@@ -47,15 +47,7 @@
#include <intl.h>
#include <backtrace.h>
#include <diagnostic.h>
-#include <diagnostic-color.h>
-#include <diagnostic-url.h>
-#include <diagnostic-metadata.h>
-#include <diagnostic-path.h>
-#include <edit-context.h>
-#include <selftest.h>
-#include <selftest-diagnostic.h>
#include <opts.h>
-
#include "util.h"
#include "cbldiag.h"
@@ -2078,16 +2070,45 @@ cobol_filename_restore() {
linemap_add(line_table, LC_LEAVE, sysp, NULL, 0);
}
-static location_t token_location;
+static int first_line_minus_1 = 0;
+static location_t token_location_minus_1 = 0;
+static location_t token_location = 0;
-location_t location_from_lineno() { return token_location; }
+location_t current_token_location() { return token_location; }
+location_t current_location_minus_one() { return token_location_minus_1; }
+void current_location_minus_one_clear()
+ {
+ first_line_minus_1 = 0;
+ }
template <typename LOC>
static void
gcc_location_set_impl( const LOC& loc ) {
// Set the position to the first line & column in the location.
+ if( getenv("KILROY") )
+ {
+ fprintf(stderr, "********** KILROY %d\n", loc.first_line);
+ }
+
+ static location_t loc_m_1 = 0;
+
token_location = linemap_line_start( line_table, loc.first_line, 80 );
token_location = linemap_position_for_column( line_table, loc.first_column);
+
+ if( loc.first_line > first_line_minus_1 )
+ {
+ // In order for GDB-COBOL to be able to step through COBOL code properly,
+ // it is sometimes necessary for the code at the beginning of a COBOL
+ // line to be using the location_t of the previous line. This is true, for
+ // example, when laying down the infrastructure code between the last
+ // statement of a paragraph and the code created at the beginning of the
+ // following paragragh. This code assumes that token_location values of
+ // interest are monotonic, and stores that prior value.
+ first_line_minus_1 = loc.first_line;
+ token_location_minus_1 = loc_m_1;
+ loc_m_1 = token_location;
+ }
+
location_dump(__func__, __LINE__, "parser", loc);
}
@@ -2128,7 +2149,7 @@ verify_format( const char gmsgid[] ) {
}
#endif
-static const diagnostic_option_id option_zero;
+static const diagnostics::option_id option_zero;
size_t parse_error_inc();
void gcc_location_dump() {
@@ -2147,7 +2168,8 @@ ydferror( const char gmsgid[], ... ) {
va_start (ap, gmsgid);
rich_location richloc (line_table, token_location);
/*bool ret =*/ global_dc->diagnostic_impl (&richloc, nullptr, option_zero,
- gmsgid, &ap, DK_ERROR);
+ gmsgid, &ap,
+ diagnostics::kind::error);
va_end (ap);
}
@@ -2202,7 +2224,8 @@ class temp_loc_t {
va_start (ap, gmsgid); \
rich_location richloc (line_table, token_location); \
bool ret = global_dc->diagnostic_impl (&richloc, nullptr, option_zero, \
- gmsgid, &ap, DK_ERROR); \
+ gmsgid, &ap, \
+ diagnostics::kind::error); \
va_end (ap); \
global_dc->end_group();
@@ -2218,13 +2241,29 @@ void error_msg( const YDFLTYPE& loc, const char gmsgid[], ... ) {
ERROR_MSG_BODY
}
+bool
+warn_msg( const YYLTYPE& loc, const char gmsgid[], ... ) {
+ temp_loc_t looker(loc);
+ verify_format(gmsgid);
+ auto_diagnostic_group d;
+ va_list ap;
+ va_start (ap, gmsgid);
+ rich_location richloc (line_table, token_location);
+ auto ret = emit_diagnostic_valist( diagnostics::kind::warning,
+ token_location,
+ option_zero, gmsgid, &ap );
+ va_end (ap);
+ return ret;
+}
+
void error_msg_direct( const char gmsgid[], ... ) {
verify_format(gmsgid);
parse_error_inc();
auto_diagnostic_group d;
va_list ap;
va_start (ap, gmsgid);
- /*auto ret = */emit_diagnostic_valist( DK_ERROR, token_location,
+ /*auto ret = */emit_diagnostic_valist( diagnostics::kind::error,
+ token_location,
option_zero, gmsgid, &ap );
va_end (ap);
}
@@ -2242,7 +2281,7 @@ yyerror( const char gmsgid[], ... ) {
nullptr,
option_zero,
gmsgid,
- &ap, DK_ERROR);
+ &ap, diagnostics::kind::error);
va_end (ap);
global_dc->end_group();
}
@@ -2253,7 +2292,7 @@ yywarn( const char gmsgid[], ... ) {
auto_diagnostic_group d;
va_list ap;
va_start (ap, gmsgid);
- auto ret = emit_diagnostic_valist( DK_WARNING, token_location,
+ auto ret = emit_diagnostic_valist( diagnostics::kind::warning, token_location,
option_zero, gmsgid, &ap );
va_end (ap);
return ret;
@@ -2451,7 +2490,8 @@ cbl_internal_error(const char *gmsgid, ...) {
auto_diagnostic_group d;
va_list ap;
va_start(ap, gmsgid);
- emit_diagnostic_valist( DK_ICE, token_location, option_zero, gmsgid, &ap );
+ emit_diagnostic_valist( diagnostics::kind::ice,
+ token_location, option_zero, gmsgid, &ap );
va_end(ap);
abort(); // This unnecessary statement is needed so that [[noreturn]]
// // doesn't cause a warning.
@@ -2463,7 +2503,8 @@ cbl_unimplementedw(const char *gmsgid, ...) {
auto_diagnostic_group d;
va_list ap;
va_start(ap, gmsgid);
- emit_diagnostic_valist( DK_SORRY, token_location, option_zero, gmsgid, &ap );
+ emit_diagnostic_valist( diagnostics::kind::sorry,
+ token_location, option_zero, gmsgid, &ap );
va_end(ap);
}
@@ -2473,7 +2514,8 @@ cbl_unimplemented(const char *gmsgid, ...) {
auto_diagnostic_group d;
va_list ap;
va_start(ap, gmsgid);
- emit_diagnostic_valist( DK_SORRY, token_location, option_zero, gmsgid, &ap );
+ emit_diagnostic_valist( diagnostics::kind::sorry,
+ token_location, option_zero, gmsgid, &ap );
va_end(ap);
}
@@ -2484,7 +2526,8 @@ cbl_unimplemented_at( const YYLTYPE& loc, const char *gmsgid, ... ) {
auto_diagnostic_group d;
va_list ap;
va_start(ap, gmsgid);
- emit_diagnostic_valist( DK_SORRY, token_location, option_zero, gmsgid, &ap );
+ emit_diagnostic_valist( diagnostics::kind::sorry,
+ token_location, option_zero, gmsgid, &ap );
va_end(ap);
}
@@ -2501,7 +2544,8 @@ cbl_err(const char *fmt, ...) {
verify_format(gmsgid);
va_list ap;
va_start(ap, fmt);
- emit_diagnostic_valist( DK_FATAL, token_location, option_zero, gmsgid, &ap );
+ emit_diagnostic_valist( diagnostics::kind::fatal,
+ token_location, option_zero, gmsgid, &ap );
va_end(ap);
}
#pragma GCC diagnostic pop
@@ -2512,7 +2556,8 @@ cbl_errx(const char *gmsgid, ...) {
auto_diagnostic_group d;
va_list ap;
va_start(ap, gmsgid);
- emit_diagnostic_valist( DK_FATAL, token_location, option_zero, gmsgid, &ap );
+ emit_diagnostic_valist( diagnostics::kind::fatal,
+ token_location, option_zero, gmsgid, &ap );
va_end(ap);
}
diff --git a/gcc/cobol/util.h b/gcc/cobol/util.h
index 00ab6a7..d478ea2 100644
--- a/gcc/cobol/util.h
+++ b/gcc/cobol/util.h
@@ -49,7 +49,7 @@ void cobol_set_pp_option(int opt);
void cobol_filename_restore();
const char * cobol_lineno( int );
-int cobol_lineno();
+int cobol_lineno(void);
unsigned long gb4( size_t input );
generated by cgit v1.1 at 2025-07-29 18:41:35 +0000