diff --git a/gcc/cobol/ChangeLog b/gcc/cobol/ChangeLog
index 10c33869cc49275a4ff5bd05bd33006f4b33a634..100df619a5be68940e32ccb40931c76783af1196 100644
--- a/gcc/cobol/ChangeLog
+++ b/gcc/cobol/ChangeLog
@@ -60,12 +60,37 @@
* Normalize #includes in scan.l
required the creation of fisspace and fisdigit in util.cc
* Normalize #includes in parse.y
- required the creation of ftolower in util.cc. Jim uses things like
- std::transform, which can't take TOLOWER because it is a macro. So I
+ required the creation of ftolower in util.cc. Jim uses things like
+ std::transform, which can't take TOLOWER because it is a macro. So I
wrapped those necessary macros into functions.
* Normalize #includes in symbols.h.cc
+2024-12-26 Robert Dubner <rdubner@symas.com>
+ * Use built_in version of memcpy
+ * Use built_in version of malloc; required initialization
+ during lang_hook_init
+
+2024-12-27 Robert Dubner <rdubner@symas.com>
+ * Use built_in version of realloc and free
+ * Use built_in version of strdup, memchr, and memset
+ * Use built_in version of abort
+ * Use built_in version of exit
+ * Use built_in version of strncmp
+ * Use built_in version of strcmp
+ * Use built_in version of strcpy
+
+2024-12-27 Robert Dubner <rdubner@symas.com>
+ * Put called_by_main_counter in static memory, not the stack!
+
+2025-01-01 Robert Dubner <rdubner@symas.com>
+ * Eliminate proc->target_of_call variable; it was unused.
+ * Wrap asprintf calls in assert() to suppress compiler warnings.
+
+2025-01-03 Robert Dubner <rdubner@symas.com>
+ * Eliminate old "#if 0" code
+ * Modify line directives to skip over paragraph/section labels:
+ * Unwrapped asprintf calls in assert(), because it was a stupid error.
+
2025-01-06 Robert Dubner <rdubner@symas.com>
* Updated warning in tests/check_88 and etests/check_88
* Updated some UAT error messages.
-
diff --git a/gcc/cobol/cdf.y b/gcc/cobol/cdf.y
index 78b5ac43e69c54db5df1cc2fc56f817f3e30683d..568eca2482b3eb8c949bf049bb5b8ae11d413325 100644
--- a/gcc/cobol/cdf.y
+++ b/gcc/cobol/cdf.y
@@ -610,7 +610,7 @@ replace_bys: replace_by
replace_by: name_any[a] BY name_any[b]
{
bool add_whitespace = false;
- replace_type_t type;
+ replace_type_t type = {};
switch($a.token) {
case YDF_NUMSTR:
case YDF_LITERAL:
diff --git a/gcc/cobol/cobol1.cc b/gcc/cobol/cobol1.cc
index 8a2c50aae066830aac82cc3b810addddbbd251f0..8c782fb0a9fbc13d8bdd7d159def87718e71c864 100644
--- a/gcc/cobol/cobol1.cc
+++ b/gcc/cobol/cobol1.cc
@@ -60,6 +60,7 @@ along with GCC; see the file COPYING3. If not see
#include "exceptl.h"
#include "exceptg.h"
#include "util.h"
+#include "gengen.h"
/* Required language-dependent contents of a type. */
@@ -107,13 +108,170 @@ struct GTY (()) language_function
* Language hooks.
*/
+/* This static function copied verbatim from the built_ion initialization
+ code in the fortran directory */
+
+#define ATTR_NULL 0
+#define ATTR_LEAF_LIST (ECF_LEAF)
+#define ATTR_NOTHROW_LEAF_LIST (ECF_NOTHROW | ECF_LEAF)
+#define ATTR_NOTHROW_LEAF_MALLOC_LIST (ECF_NOTHROW | ECF_LEAF | ECF_MALLOC)
+#define ATTR_CONST_NOTHROW_LEAF_LIST (ECF_NOTHROW | ECF_LEAF | ECF_CONST)
+#define ATTR_PURE_NOTHROW_LEAF_LIST (ECF_NOTHROW | ECF_LEAF | ECF_PURE)
+#define ATTR_NOTHROW_LIST (ECF_NOTHROW)
+#define ATTR_CONST_NOTHROW_LIST (ECF_NOTHROW | ECF_CONST)
+#define ATTR_ALLOC_WARN_UNUSED_RESULT_SIZE_2_NOTHROW_LIST \
+ (ECF_NOTHROW | ECF_LEAF | ECF_MALLOC)
+#define ATTR_ALLOC_WARN_UNUSED_RESULT_SIZE_2_NOTHROW_LEAF_LIST \
+ (ECF_NOTHROW | ECF_LEAF)
+#define ATTR_COLD_NORETURN_NOTHROW_LEAF_LIST \
+ (ECF_COLD | ECF_NORETURN | \
+ ECF_NOTHROW | ECF_LEAF)
+#define ATTR_PURE_NOTHROW_NONNULL_LEAF (ECF_PURE|ECF_NOTHROW|ECF_LEAF)
+#define ATTR_MALLOC_WARN_UNUSED_RESULT_NOTHROW_NONNULL_LEAF (ECF_MALLOC|ECF_NOTHROW|ECF_LEAF)
+#define ATTR_TMPURE_NORETURN_NOTHROW_LEAF_COLD_LIST (ECF_TM_PURE|ECF_NORETURN|ECF_NOTHROW|ECF_LEAF|ECF_COLD)
+#define ATTR_NORETURN_NOTHROW_LIST (ECF_NORETURN|ECF_NOTHROW)
+#define ATTR_NOTHROW_NONNULL_LEAF (ECF_NOTHROW|ECF_LEAF)
+
+static void
+gfc_define_builtin (const char *name, tree type, enum built_in_function code,
+ const char *library_name, int attr)
+{
+ tree decl;
+
+ decl = add_builtin_function (name, type, code, BUILT_IN_NORMAL,
+ library_name, NULL_TREE);
+ set_call_expr_flags (decl, attr);
+
+ set_builtin_decl (code, decl, true);
+}
+
+static void
+create_our_type_nodes_init()
+ {
+ for(int i=0; i<256; i++)
+ {
+ char_nodes[i] = build_int_cst_type(CHAR, i);
+ }
+
+ // Create some useful constants to avoid cluttering up the code
+ // build_int_cst_type() calls
+ pvoid_type_node = build_pointer_type(void_type_node);
+ integer_minusone_node = build_int_cst_type(INT, -1);
+ integer_two_node = build_int_cst_type(INT, 2);
+ integer_eight_node = build_int_cst_type(INT, 8);
+ size_t_zero_node = build_int_cst_type(SIZE_T, 0);
+ int128_zero_node = build_int_cst_type(INT128, 0);
+ int128_five_node = build_int_cst_type(INT128, 5);
+ int128_ten_node = build_int_cst_type(INT128, 10);
+ char_ptr_type_node = build_pointer_type(CHAR);
+ uchar_ptr_type_node = build_pointer_type(UCHAR);
+ wchar_ptr_type_node = build_pointer_type(WCHAR);
+ long_double_ten_node = build_real_from_int_cst(
+ LONGDOUBLE,
+ build_int_cst_type(INT,10));
+ sizeof_size_t = build_int_cst_type(SIZE_T, sizeof(size_t));
+ sizeof_pointer = build_int_cst_type(SIZE_T, sizeof(void *));
+
+ bool_true_node = build2(EQ_EXPR,
+ integer_type_node,
+ integer_one_node,
+ integer_one_node);
+
+ bool_false_node = build2( EQ_EXPR,
+ integer_type_node,
+ integer_one_node,
+ integer_zero_node);
+ }
+
+
static bool
cobol_langhook_init (void)
{
build_common_tree_nodes (true);
+ create_our_type_nodes_init();
+
void_list_node = build_tree_list (NULL_TREE, void_type_node);
+ tree char_pointer_type_node = build_pointer_type (char_type_node);
+ tree const_char_pointer_type_node
+ = build_pointer_type (build_type_variant (char_pointer_type_node, 1, 0));
+
+ tree ftype;
+
+ ftype = build_function_type_list (pvoid_type_node,
+ size_type_node,
+ NULL_TREE);
+ gfc_define_builtin ("__builtin_malloc",
+ ftype,
+ BUILT_IN_MALLOC,
+ "malloc",
+ ATTR_NOTHROW_LEAF_MALLOC_LIST);
+
+ ftype = build_function_type_list (pvoid_type_node, pvoid_type_node,
+ size_type_node, NULL_TREE);
+ gfc_define_builtin ("__builtin_realloc", ftype, BUILT_IN_REALLOC,
+ "realloc", ATTR_NOTHROW_LEAF_LIST);
+
+ ftype = build_function_type_list (void_type_node,
+ pvoid_type_node, NULL_TREE);
+ gfc_define_builtin ("__builtin_free", ftype, BUILT_IN_FREE,
+ "free", ATTR_NOTHROW_LEAF_LIST);
+
+ ftype = build_function_type_list (pvoid_type_node,
+ const_ptr_type_node,
+ integer_type_node,
+ size_type_node,
+ NULL_TREE);
+ gfc_define_builtin ("__builtin_memchr", ftype, BUILT_IN_MEMCHR,
+ "memchr", ATTR_PURE_NOTHROW_NONNULL_LEAF);
+
+
+ ftype = build_function_type_list (size_type_node,
+ const_char_pointer_type_node,
+ NULL_TREE);
+ gfc_define_builtin ("__builtin_strlen", ftype, BUILT_IN_STRLEN,
+ "strlen", ATTR_PURE_NOTHROW_NONNULL_LEAF);
+
+
+ ftype = build_function_type_list (char_pointer_type_node,
+ const_char_pointer_type_node,
+ NULL_TREE);
+ gfc_define_builtin ("__builtin_strdup", ftype, BUILT_IN_STRDUP,
+ "strdup", ATTR_MALLOC_WARN_UNUSED_RESULT_NOTHROW_NONNULL_LEAF);
+
+ ftype = build_function_type_list (void_type_node, NULL_TREE);
+ gfc_define_builtin ("__builtin_abort", ftype, BUILT_IN_ABORT,
+ "abort", ATTR_TMPURE_NORETURN_NOTHROW_LEAF_COLD_LIST);
+
+ ftype = build_function_type_list (void_type_node,
+ integer_type_node,
+ NULL_TREE);
+ gfc_define_builtin ("__builtin_exit", ftype, BUILT_IN_EXIT,
+ "exit", ATTR_TMPURE_NORETURN_NOTHROW_LEAF_COLD_LIST);
+
+ ftype = build_function_type_list (integer_type_node,
+ const_char_pointer_type_node,
+ const_char_pointer_type_node,
+ size_type_node,
+ NULL_TREE);
+ gfc_define_builtin ("__builtin_strncmp", ftype, BUILT_IN_STRNCMP,
+ "strncmp", ATTR_PURE_NOTHROW_NONNULL_LEAF);
+
+ ftype = build_function_type_list (integer_type_node,
+ const_char_pointer_type_node,
+ const_char_pointer_type_node,
+ NULL_TREE);
+ gfc_define_builtin ("__builtin_strcmp", ftype, BUILT_IN_STRCMP,
+ "strcmp", ATTR_PURE_NOTHROW_NONNULL_LEAF);
+
+ ftype = build_function_type_list (char_pointer_type_node,
+ char_pointer_type_node,
+ const_char_pointer_type_node,
+ NULL_TREE);
+ gfc_define_builtin ("__builtin_strcpy", ftype, BUILT_IN_STRCPY,
+ "strcpy", ATTR_NOTHROW_NONNULL_LEAF);
+
build_common_builtin_nodes ();
return true;
@@ -646,30 +804,6 @@ cobol_set_decl_assembler_name (tree decl)
dbgmsg("Public/FileScope %s", name);
}
}
-#if 0
- else {
- char vis[5] = "";
- vis[0] = TREE_STATIC(decl)? 'S' : ' ';
- vis[1] = DECL_EXTERNAL(decl)? 'E' : ' ';
- vis[2] = DECL_VISIBILITY(decl)? 'V' : ' ';
- vis[2] = DECL_NONLOCAL(decl)? 'L' : ' ';
-
- tree parent = get_containing_scope (decl);
- const_tree context = get_ultimate_context (decl);
- struct { const char *parent, *context; } names = {};
-
- vis[3] = parent? 'P' : ' ';
- vis[4] = context? 'F' : ' ';
- if (parent)
- names.parent = IDENTIFIER_POINTER (DECL_NAME (parent));
- if (context)
- names.context = IDENTIFIER_POINTER (DECL_NAME (context));
-
- // WORKING-STORAGE static variables
- dbgmsg("variable %s %-16s of %-14s of %s: %%s",
- vis, name, names.parent, names.context);
- }
-#endif
if(getenv("SEE_NAMES") && strncmp( name, "__", 2) )
{
diff --git a/gcc/cobol/failures/playpen/playpen.cbl b/gcc/cobol/failures/playpen/playpen.cbl
index a32a01a357e29f321ddca5bfedd7ba55449ffe2b..056d00690d625a1f9d23b9691dd92f6f9038a2fb 100644
--- a/gcc/cobol/failures/playpen/playpen.cbl
+++ b/gcc/cobol/failures/playpen/playpen.cbl
@@ -1,9 +1,17 @@
-
- IDENTIFICATION DIVISION.
- PROGRAM-ID. prog.
- DATA DIVISION.
- WORKING-STORAGE SECTION.
- COPY copy1.
- PROCEDURE DIVISION.
- DISPLAY TEST-VAR.
- STOP RUN.
+ identification division.
+ program-id. prog.
+ procedure division.
+ display "about to perform stuff"
+ perform stuff
+ display "line 1 after perform"
+ display "line 2 after perform"
+ display "line 3 after perform".
+ stuff.
+ display "This is paragraph ""stuff1""".
+ display "This is paragraph ""stuff2""".
+ display "This is paragraph ""stuff3""".
+ display "This is paragraph ""stuff4""".
+ endstuff.
+ display "That's all, folks!"
+ goback.
+ end program prog.
diff --git a/gcc/cobol/genapi.cc b/gcc/cobol/genapi.cc
index 0ba163484abc213e8cc48b042cb9ab37fde42332..51a06bf0aff1b9bb108def4919dbe6d076460cb7 100644
--- a/gcc/cobol/genapi.cc
+++ b/gcc/cobol/genapi.cc
@@ -52,9 +52,6 @@
#define TSI_BACK (tsi_last(current_function->statement_list_stack.back()))
-//#define XXX do{gg_printf("LINE %d\n", build_int_cst_type(INT, __LINE__), NULL_TREE);}while(0);
-#define XXX
-
static std::unordered_map<std::string, std::string> main_strings;
extern char *cobol_name_mangler(const char *cobol_name);
@@ -80,7 +77,9 @@ int show_parse_indent = 0;
#define DEFAULT_LINE_NUMBER 2
-#if 0
+#ifdef LINE_TICK
+/* This code is used from time to time when sorting out why compilation
+ takes more time than expected */
static void
line_tick()
{
@@ -2314,25 +2313,6 @@ assembler_label(const char *label)
strcat(build, local_text);
gg_insert_into_assembler(build);
-
- // In order for the assembler label to be effective, it needs to be followed
- // by a .loc directive. The __ASM__ directive won't make that happen; we
- // need a different GENERIC tag. An ordinary label does the job:
-
- tree tgo_to;
- tree tlabel;
- tree taddr;
- gg_create_goto_pair(&tgo_to,
- &tlabel,
- &taddr);
- SET_EXPR_LOCATION (tgo_to, location_from_lineno());
- SET_EXPR_LOCATION (tlabel, location_from_lineno());
-
- // The following two tags end up generating a NOP in -O0 code. This is
- // almost ideal. I am still looking for another way, but this seems to be
- // about as good as it gets.
- gg_append_statement(tgo_to);
- gg_append_statement(tlabel);
}
static void
@@ -2341,6 +2321,8 @@ 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);
+
static size_t deconflictor = symbol_label_id(procedure->label);
cbl_label_t *label = procedure->label;
@@ -2358,7 +2340,14 @@ section_label(struct cbl_proc_t *procedure)
sprintf(secname,
"_sect.%s",
combined_name(procedure->label));
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_TEXT(secname);
+ SHOW_PARSE_END
+ }
assembler_label(secname);
+ gg_assign(var_decl_nop, build_int_cst_type(INT, 108));
}
static void
@@ -2372,6 +2361,9 @@ paragraph_label(struct cbl_proc_t *procedure)
// 2) paragraph names can be duplicated in a section, provided that they
// 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;
@@ -2395,12 +2387,20 @@ paragraph_label(struct cbl_proc_t *procedure)
deconflictor);
gg_insert_into_assembler(ach);
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_TEXT(ach);
+ SHOW_PARSE_END
+ }
+
// The label has to start with an underscore. I tried a period, but those
// don't seem to show up in GDB's internal symbol tables.
sprintf(ach,
"_para.%s",
combined_name(procedure->label));
assembler_label(ach);
+ gg_assign(var_decl_nop, build_int_cst_type(INT, 109));
}
static void
@@ -2598,6 +2598,7 @@ find_procedure(cbl_label_t *label)
// defined more than once. Had it been referenced with a GOTO or PERFORM,
// that would have been a syntax error.
//
+ //
// In this case, we need to replace the existing cbl_proc_t structure. We
// will be laying down labels for this second (or more) instance of
// parser_enter_paragraph, and we must create different labels.
@@ -2611,9 +2612,6 @@ find_procedure(cbl_label_t *label)
retval = (struct cbl_proc_t *)xmalloc(sizeof(struct cbl_proc_t));
retval->label = label;
- sprintf(ach, "_proc_call_target_%d", counter);
- retval->target_of_call = xstrdup(ach);
-
gg_create_goto_pair(&retval->top.go_to,
&retval->top.label,
&retval->top.addr,
@@ -2706,11 +2704,6 @@ parser_enter_paragraph(cbl_label_t *label)
CHECK_LABEL(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, 102));
-
struct cbl_proc_t *procedure = find_procedure(label);
gg_append_statement(procedure->top.label);
paragraph_label(procedure);
@@ -2808,27 +2801,6 @@ parser_alter( cbl_perform_tgt_t *tgt )
proceed_to_proc->top.addr);
}
-#if 0
-static void
-parser_init_paragraph( cbl_label_t *altered )
- {
- Analyze();
- SHOW_PARSE
- {
- SHOW_PARSE_HEADER
- SHOW_PARSE_END
- }
- TRACE1
- {
- TRACE1_HEADER
- TRACE1_END
- }
- struct cbl_proc_t *altered_proc = find_procedure(altered);
- gg_assign( altered_proc->alter_location,
- null_pointer_node);
- }
-#endif
-
void
parser_goto( cbl_refer_t value_ref, size_t narg, cbl_label_t * const labels[] )
{
@@ -3503,9 +3475,9 @@ enter_program_common(const char *funcname, const char *funcname_)
current_function->first_time_through =
gg_define_variable(INT,
- "_first_time_through",
- vs_static,
- integer_one_node);
+ "_first_time_through",
+ vs_static,
+ integer_one_node);
gg_create_goto_pair(¤t_function->skip_init_goto,
¤t_function->skip_init_label);
@@ -3555,10 +3527,21 @@ enter_program_common(const char *funcname, const char *funcname_)
"__gg__codeset_figurative_constants",
NULL_TREE);
- current_function->first_declarative_section
- = gg_define_char_star(null_pointer_node);
+ static int counter=1;
+ char ach[32];
- current_function->called_by_main_counter = gg_define_int(0);
+ sprintf(ach, "_cf_fds_%d", counter);
+ current_function->first_declarative_section
+ = gg_define_variable(CHAR_P,
+ ach,
+ vs_static,
+ null_pointer_node);
+ sprintf(ach, "_cf_cbmc_%d", counter);
+ current_function->called_by_main_counter = gg_define_variable(INT,
+ ach,
+ vs_static,
+ integer_zero_node);
+ counter += 1;
// Initialize the TRACE logic, which has to be done before the first TRACE1
// invocation, but after there is a function to lay down GIMPLE code in.
@@ -4536,7 +4519,6 @@ parser_accept_date_yyyymmdd( struct cbl_field_t *target )
move_tree_to_field( target,
pointer);
- XXX;
gg_free(pointer);
TRACE1
@@ -4567,7 +4549,6 @@ parser_accept_date_yyddd( struct cbl_field_t *target )
move_tree_to_field( target,
pointer);
- XXX;
gg_free(pointer);
TRACE1
@@ -4598,7 +4579,6 @@ parser_accept_date_yyyyddd( struct cbl_field_t *target )
move_tree_to_field( target,
pointer);
- XXX;
gg_free(pointer);
TRACE1
@@ -4629,7 +4609,6 @@ parser_accept_date_dow( struct cbl_field_t *target )
move_tree_to_field( target,
pointer);
- XXX;
gg_free(pointer);
TRACE1
@@ -4660,7 +4639,6 @@ parser_accept_date_hhmmssff( struct cbl_field_t *target )
move_tree_to_field( target,
pointer);
- XXX;
gg_free(pointer);
TRACE1
@@ -5873,7 +5851,7 @@ static
void
pe_stuff(cbl_refer_t refer, ec_type_t ec)
{
- // This is the moral equivalent of a C "return XXX;".
+ // This is the moral equivalent of a C "return xyz;".
// There cannot be both a non-zero exit status and an exception condition.
gcc_assert( !(ec != ec_none_e && refer.field != NULL) );
@@ -6505,7 +6483,6 @@ parser_division(cbl_division_t division,
ENDIF
gg_append_statement(current_function->skip_init_label);
-
// This is where we check to see if somebody tried to cancel us
tree cancelled = gg_define_int();
gg_assign(cancelled,
@@ -6887,8 +6864,6 @@ parser_division(cbl_division_t division,
ENDIF
}
ENDIF
-
-
}
}
@@ -12380,6 +12355,7 @@ create_and_call(size_t narg,
// passed expressions BY VALUE and BY CONTENT
gg_assign(gg_array_value(var_decl_call_parameter_lengths, i),length);
}
+
// Let the called program know how many parameters we are passing
gg_assign(var_decl_call_parameter_count,
build_int_cst_type(INT, narg));
@@ -12398,7 +12374,6 @@ create_and_call(size_t narg,
// We are expecting a return value of type CHAR_P, SSIZE_T, SIZE_T,
// UINT128 or INT128
-
push_program_state();
gg_assign(returned_value, gg_cast(returned_value_type, call_expr));
pop_program_state();
@@ -12640,7 +12615,6 @@ parser_call( cbl_refer_t name,
tree function_handle = function_handle_from_name( name,
returned_value_type);
-
if( (use_static_call() && is_literal(name.field))
|| (name.field && name.field->type == FldPointer) )
{
@@ -13234,58 +13208,6 @@ parser_program_hierarchy( const struct cbl_prog_hier_t& hier )
gg_append_statement(skipper_label);
}
-#if 0
-void parser_declarative_except( bool global,
- bool standard,
- bool error,
- declarative_culprit_t culprit,
- size_t nfiles,
- cbl_file_t *files[] )
- {
- // error is true for AFTER ERROR, and false for AFTER EXCEPTION
- SHOW_PARSE
- {
- SHOW_PARSE_HEADER
- if( global )
- {
- SHOW_PARSE_TEXT(" GLOBAL")
- }
- if( standard )
- {
- SHOW_PARSE_TEXT(" STANDARD")
- }
- if( error )
- {
- SHOW_PARSE_TEXT(" ERROR")
- }
- switch( culprit )
- {
- case culpa_none_e:
- SHOW_PARSE_TEXT(" NONE (error)")
- break;
- case culpa_input_e:
- SHOW_PARSE_TEXT(" INPUT")
- break;
- case culpa_output_e:
- SHOW_PARSE_TEXT(" OUTPUT")
- break;
- case culpa_io_e:
- SHOW_PARSE_TEXT(" I-O")
- break;
- case culpa_extend_e:
- SHOW_PARSE_TEXT(" EXTEND")
- break;
- }
- for( size_t i=0; i<nfiles; i++ )
- {
- SHOW_PARSE_TEXT(" ")
- SHOW_PARSE_TEXT(files[i]->name)
- }
- SHOW_PARSE_END
- }
- }
-#endif
-
void
parser_set_handled(ec_type_t ec_handled)
{
@@ -13378,62 +13300,6 @@ parser_set_numeric(struct cbl_field_t *tgt, ssize_t value)
NULL_TREE );
}
-#if 0
-static void
-exception_enable( bool enabled, bool location,
- const cbl_exception_files_t& ecf )
- {
- SHOW_PARSE
- {
- SHOW_PARSE_HEADER
- SHOW_PARSE_TEXT("enabled:")
- SHOW_PARSE_TEXT(enabled?"1":"0")
- SHOW_PARSE_TEXT(" location:")
- SHOW_PARSE_TEXT(location?"1":"0")
- SHOW_PARSE_TEXT(" ec:")
- char ach[32];
- sprintf(ach, "type:0x%x", ecf.type);
- SHOW_PARSE_TEXT(ach)
- for( size_t i=0; i<ecf.nfile; i++ )
- {
- SHOW_PARSE_INDENT
- auto f = cbl_file_of(symbol_at(ecf.files[i]));
- SHOW_PARSE_TEXT(f->name)
- }
- SHOW_PARSE_END
- }
-
- // We create and populate an array of size_t values
- tree values_p = gg_define_variable(build_pointer_type(SIZE_T));
- if( ecf.nfile )
- {
- gg_assign( values_p,
- gg_cast(build_pointer_type(SIZE_T),
- gg_malloc(ecf.nfile*sizeof(SIZE_T))));
-
- for(size_t i=0; i<ecf.nfile; i++)
- {
- gg_assign(gg_array_value(values_p, i),
- build_int_cst_type(SIZE_T, ecf.files[i]));
- }
- }
- else
- {
- gg_assign(values_p,
- gg_cast(build_pointer_type(SIZE_T), null_pointer_node ));
- }
- gg_call(VOID,
- "__gg__exception_enable",
- enabled ? integer_one_node : integer_zero_node,
- build_int_cst_type(INT, ecf.type),
- build_int_cst_type(SIZE_T, ecf.nfile),
- values_p,
- location ? integer_one_node : integer_zero_node,
- NULL_TREE);
- gg_free(values_p);
- }
-#endif
-
static void
stash_exceptions( const cbl_enabled_exceptions_array_t *enabled )
{
@@ -16383,25 +16249,6 @@ parser_field_attr_set( cbl_field_t *tgt, cbl_field_attr_t attr, bool on_off )
void
parser_symbol_add(struct cbl_field_t *new_var )
{
-#if 0
- using namespace std::chrono;
- static int counter = 1;
-
- static high_resolution_clock::time_point t1 = high_resolution_clock::now();
- static high_resolution_clock::time_point t2 = high_resolution_clock::now();
- if( counter == 1 )
- {
- t1 = high_resolution_clock::now();
- }
- if( (counter % 10000) == 0 )
- {
- t2 = high_resolution_clock::now();
- duration<double> time_span = duration_cast<duration<double>>(t2 - t1);
- fprintf(stderr, "psa %6d %6.1lf\n", counter, time_span.count());
- }
- counter += 1;
-#endif
-
Analyze();
SHOW_PARSE
{
diff --git a/gcc/cobol/genapi.h b/gcc/cobol/genapi.h
index 39144cb6651d4057cc2b2532050d231b75c460d3..4f22185b10e2a33530dc0d26baff1afbaec2281d 100644
--- a/gcc/cobol/genapi.h
+++ b/gcc/cobol/genapi.h
@@ -492,12 +492,6 @@ parser_intrinsic_call_4( cbl_field_t *tgt,
cbl_refer_t& ref3,
cbl_refer_t& ref4 );
-// void parser_declarative_except( bool global, bool standard, bool error,
- // declarative_culprit_t culprit,
- // size_t nproc,
- // cbl_file_t *files[] );
-
-
void
parser_string_overflow( cbl_label_t *name );
void
diff --git a/gcc/cobol/gengen.cc b/gcc/cobol/gengen.cc
index 3540a352986a377d80b1891b547ac8ea0eff5cf9..381c02aab94d87c2b0505308e5a74f09656b9011 100644
--- a/gcc/cobol/gengen.cc
+++ b/gcc/cobol/gengen.cc
@@ -94,6 +94,7 @@
#include "cgraph.h"
#include "toplev.h"
#include "function.h"
+#include "fold-const.h"
#define HOWEVER_GCC_DEFINES_TREE 1
#include "symbols.h"
#include "gengen.h"
@@ -108,6 +109,7 @@ static int sv_current_line_number;
// These are globally useful constants
tree char_nodes[256];
+tree pvoid_type_node;
tree integer_minusone_node;
tree integer_two_node;
tree integer_eight_node;
@@ -315,8 +317,7 @@ gg_trunc(tree integer_type, tree floating_var)
tree
gg_cast(tree type, tree var)
{
- tree retval = build1(CONVERT_EXPR, type, var);
- return retval;
+ return fold_convert(type, var);
}
static bool saw_pointer;
@@ -354,6 +355,20 @@ static
char *
show_type(tree type)
{
+ if( !type )
+ {
+ cbl_internal_error("The given type is not NULL, and that's just not fair");
+ }
+
+ if( DECL_P(type) )
+ {
+ type = TREE_TYPE(type);
+ }
+ if( !TYPE_P(type) )
+ {
+ cbl_internal_error("The given type is not a DECL or a TYPE");
+ }
+
static char ach[1024];
switch( TREE_CODE(type) )
{
@@ -382,6 +397,14 @@ show_type(tree type)
(TYPE_UNSIGNED(type) ? "unsigned" : " signed"));
break;
+ case FUNCTION_TYPE:
+ sprintf(ach, "FUNCTION");
+// sprintf(ach,
+// "%3ld-bit %s INT",
+// TREE_INT_CST_LOW(TYPE_SIZE(type)),
+// (TYPE_UNSIGNED(type) ? "unsigned" : " signed"));
+ break;
+
default:
cbl_internal_error("Unknown type %d", TREE_CODE(type));
}
@@ -2283,46 +2306,58 @@ gg_write(tree fd, tree buf, tree count)
void
gg_memset(tree dest, const tree value, tree size)
{
- // The C equivalent: "memset(dest, value, size);"
- gg_call(VOID_P,
- "memset",
- dest,
- value,
- size,
- NULL_TREE);
+ tree the_call =
+ build_call_expr_loc(location_from_lineno(),
+ builtin_decl_explicit (BUILT_IN_MEMSET),
+ 3,
+ dest,
+ value,
+ size);
+ gg_append_statement(the_call);
}
tree
gg_memchr(tree buf, tree ch, tree length)
{
- return gg_call_expr(VOID_P,
- "memchr",
- buf,
- ch,
- length,
- NULL_TREE);
+ tree the_call = fold_convert(
+ pvoid_type_node,
+ build_call_expr_loc(location_from_lineno(),
+ builtin_decl_explicit (BUILT_IN_MEMCHR),
+ 3,
+ buf,
+ ch,
+ length));
+ return the_call;
}
+/* Built-in call to memcpy() */
+
void
gg_memcpy(tree dest, const tree src, tree size)
{
- gg_call(VOID_P,
- "memcpy",
- dest,
- src,
- size,
- NULL_TREE);
+ tree the_call = build_call_expr_loc(
+ location_from_lineno(),
+ builtin_decl_explicit (BUILT_IN_MEMCPY),
+ 3,
+ dest,
+ src,
+ size);
+ gg_append_statement(the_call);
}
+/* Built-in call to memmove() */
+
void
gg_memmove(tree dest, const tree src, tree size)
{
- gg_call(VOID_P,
- "memmove",
- dest,
- src,
- size,
- NULL_TREE);
+ tree the_call = build_call_expr_loc(
+ location_from_lineno(),
+ builtin_decl_explicit (BUILT_IN_MEMMOVE),
+ 3,
+ dest,
+ src,
+ size);
+ gg_append_statement(the_call);
}
tree
@@ -2348,21 +2383,26 @@ gg_memdup(tree data, size_t length)
void
gg_strcpy(tree dest, tree src)
{
- gg_call(CHAR_P,
- "strcpy",
- dest,
- src,
- NULL_TREE);
+ tree the_call =
+ build_call_expr_loc(location_from_lineno(),
+ builtin_decl_explicit (BUILT_IN_STRCPY),
+ 2,
+ dest,
+ src);
+ gg_append_statement(the_call);
}
tree
gg_strcmp(tree A, tree B)
{
- return gg_call_expr(INT,
- "strcmp",
- A,
- B,
- NULL_TREE);
+ tree the_call = fold_convert(
+ integer_type_node,
+ build_call_expr_loc(location_from_lineno(),
+ builtin_decl_explicit (BUILT_IN_STRCMP),
+ 2,
+ A,
+ B));
+ return the_call;
}
tree
@@ -2387,12 +2427,15 @@ gg_close(tree int_A)
tree
gg_strncmp(tree char_star_A, tree char_star_B, tree size_t_N)
{
- return gg_call_expr(INT,
- "strncmp",
- char_star_A,
- char_star_B,
- size_t_N,
- NULL_TREE);
+ tree the_call = fold_convert(
+ integer_type_node,
+ build_call_expr_loc(location_from_lineno(),
+ builtin_decl_explicit (BUILT_IN_STRNCMP),
+ 3,
+ char_star_A,
+ char_star_B,
+ size_t_N));
+ return the_call;
}
void
@@ -2675,24 +2718,6 @@ gg_define_function(tree return_type, const char *funcname, ...)
TREE_NOTHROW(function_decl) = 0;
TREE_USED(function_decl) = 1;
-#if 0
- // This code was for true nexted functions
- if( gg_trans_unit.function_stack.size() == 0 )
- {
- // gg_trans_unit.function_stack is empty, so our context is
- // the compilation module, and we need to be public:
- DECL_CONTEXT (function_decl) = gg_trans_unit.trans_unit_decl;
- TREE_PUBLIC(function_decl) = 1;
- }
- else
- {
- // The stack has something in it, so we are building a nested function.
- // Make the current function our context
- DECL_CONTEXT (function_decl) = current_function->function_decl;
- TREE_PUBLIC(function_decl) = 0;
- DECL_STATIC_CHAIN(function_decl) = 1;
- }
-#else
// This code makes COBOL nested programs actual visible on the
// source code "trans_unit_decl" level, but with non-public "static"
// visibility.
@@ -2717,7 +2742,6 @@ gg_define_function(tree return_type, const char *funcname, ...)
// associated with the computation module.
gg_append_var_decl(function_decl);
}
-#endif
// Chain the names onto the variables list:
for(int i=0; i<nparams; i++)
@@ -3208,56 +3232,73 @@ gg_create_bind_expr()
void
gg_exit(tree exit_code)
{
- gg_call(VOID,
- "exit",
- exit_code,
- NULL_TREE);
+ tree the_call =
+ build_call_expr_loc(location_from_lineno(),
+ builtin_decl_explicit (BUILT_IN_EXIT),
+ 1,
+ exit_code);
+ gg_append_statement(the_call);
}
void
gg_abort()
{
- gg_call(VOID,
- "abort",
- NULL_TREE);
+ tree the_call =
+ build_call_expr_loc(location_from_lineno(),
+ builtin_decl_explicit (BUILT_IN_ABORT),
+ 0);
+ gg_append_statement(the_call);
}
tree
gg_strlen(tree psz)
{
- return gg_call_expr(SIZE_T,
- "strlen",
- psz,
- NULL_TREE);
+ tree the_call = fold_convert(
+ size_type_node,
+ build_call_expr_loc(location_from_lineno(),
+ builtin_decl_explicit (BUILT_IN_STRLEN),
+ 1,
+ psz));
+ return the_call;
}
tree
gg_strdup(tree psz)
{
- return gg_call_expr(CHAR_P,
- "strdup",
- psz,
- NULL_TREE);
+ tree the_call = fold_convert(
+ build_pointer_type(char_type_node),
+ build_call_expr_loc(location_from_lineno(),
+ builtin_decl_explicit (BUILT_IN_STRDUP),
+ 1,
+ psz));
+ return the_call;
}
+/* built_in call to malloc() */
+
tree
gg_malloc(tree size)
{
- return gg_call_expr(VOID_P,
- "malloc",
- size,
- NULL_TREE);
+ tree the_call = fold_convert(
+ pvoid_type_node,
+ build_call_expr_loc(location_from_lineno(),
+ builtin_decl_explicit (BUILT_IN_MALLOC),
+ 1,
+ size));
+ return the_call;
}
tree
gg_realloc(tree base, tree size)
{
- return gg_cast(TREE_TYPE(base),
- gg_call_expr(VOID_P,
- "realloc",
- base,
- size,
- NULL_TREE));
+ tree the_call = fold_convert(
+ pvoid_type_node,
+ build_call_expr_loc(location_from_lineno(),
+ builtin_decl_explicit (BUILT_IN_REALLOC),
+ 2,
+ base,
+ size));
+ return the_call;
}
tree
@@ -3275,10 +3316,12 @@ gg_malloc(size_t size)
void
gg_free(tree pointer)
{
- gg_call(VOID_P,
- "free",
- pointer,
- NULL_TREE);
+ tree the_call =
+ build_call_expr_loc(location_from_lineno(),
+ builtin_decl_explicit (BUILT_IN_FREE),
+ 1,
+ pointer);
+ gg_append_statement(the_call);
}
void
diff --git a/gcc/cobol/gengen.h b/gcc/cobol/gengen.h
index d5f1a727360b23ed3e4456a0bd008db42aa8a80a..9a19d237f2511001ea9cff184b26ee3a0f50273b 100644
--- a/gcc/cobol/gengen.h
+++ b/gcc/cobol/gengen.h
@@ -232,7 +232,6 @@ struct gg_function_t
// decremented and a return is created. When the counter is 1, the
// EXIT program is treated as a CONTINUE.
tree called_by_main_counter;
-
};
struct cbl_translation_unit_t
@@ -264,23 +263,23 @@ extern struct cbl_translation_unit_t gg_trans_unit;
#define current_function (&gg_trans_unit.function_stack.back())
-extern tree char_nodes[256];
-
-extern tree integer_minusone_node;
-extern tree integer_two_node;
-extern tree integer_eight_node;
-extern tree size_t_zero_node;
-extern tree int128_zero_node;
-extern tree int128_five_node;
-extern tree int128_ten_node;
-extern tree bool_true_node;
-extern tree bool_false_node;
-extern tree char_ptr_type_node;
-extern tree uchar_ptr_type_node;
-extern tree wchar_ptr_type_node;
-extern tree long_double_ten_node;
-extern tree sizeof_size_t;
-extern tree sizeof_pointer;
+extern tree char_nodes[256] GTY(());
+extern tree pvoid_type_node GTY(());
+extern tree integer_minusone_node GTY(());
+extern tree integer_two_node GTY(());
+extern tree integer_eight_node GTY(());
+extern tree size_t_zero_node GTY(());
+extern tree int128_zero_node GTY(());
+extern tree int128_five_node GTY(());
+extern tree int128_ten_node GTY(());
+extern tree bool_true_node GTY(());
+extern tree bool_false_node GTY(());
+extern tree char_ptr_type_node GTY(());
+extern tree uchar_ptr_type_node GTY(());
+extern tree wchar_ptr_type_node GTY(());
+extern tree long_double_ten_node GTY(());
+extern tree sizeof_size_t GTY(());
+extern tree sizeof_pointer GTY(());
// These routines happen when beginning to process a new file, which is also
// known, in GCC, as a "translation unit"
diff --git a/gcc/cobol/genutil.cc b/gcc/cobol/genutil.cc
index 56e8560e64e50e02126237b03e4ecd663b145da9..25e85b5828d19ada6d1e23e1c262256dad82ac36 100644
--- a/gcc/cobol/genutil.cc
+++ b/gcc/cobol/genutil.cc
@@ -48,12 +48,7 @@ bool skip_exception_processing = true;
bool suppress_dest_depends = false;
-// This is useful for determining which set_exception_code is the culprit
-#if 0
-#define SET_EXCEPTION_CODE(a) do{gg_printf("set_except %s:%d\n", gg_string_literal(__func__), build_int_cst_type(INT,__LINE__), NULL_TREE);set_exception_code((a));}while(0);
-#else
#define SET_EXCEPTION_CODE(a) do{set_exception_code((a));}while(0);
-#endif
std::vector<std::string>current_filename;
@@ -1555,49 +1550,6 @@ scale_by_power_of_ten(tree value,
}
gg_assign(retval, integer_zero_node);
-#if 0
- IF( N, gt_op, gg_cast(TREE_TYPE(N), integer_zero_node) )
- {
- gg_assign(value,
- gg_multiply(value,
- gg_cast(value_type,
- gg_call_expr( INT128,
- "__gg__power_of_ten",
- N,
- NULL_TREE))));
- if( check_for_fractional )
- {
- IF( gg_mod( value,
- gg_cast(value_type,
- gg_call_expr( INT128,
- "__gg__power_of_ten",
- N,
- NULL_TREE))),
- ne_op,
- gg_cast(value_type, integer_zero_node) )
- {
- gg_assign(retval, integer_one_node);
- }
- ELSE
- ENDIF
- }
- }
- ELSE
- ENDIF
-
- IF( N, lt_op, gg_cast(TREE_TYPE(N), integer_zero_node) )
- {
- gg_assign(value,
- gg_divide(value,
- gg_cast(value_type,
- gg_call_expr( INT128,
- "__gg__power_of_ten",
- gg_negate(N),
- NULL_TREE))));
- }
- ELSE
- ENDIF
-#endif
return retval;
}
diff --git a/gcc/cobol/structs.cc b/gcc/cobol/structs.cc
index d04d8d0c5fd9b05582e2c449fe6848010df4ec39..5321e43c690e698c39dac31b91c0102ba6cd5181 100644
--- a/gcc/cobol/structs.cc
+++ b/gcc/cobol/structs.cc
@@ -339,40 +339,6 @@ create_our_type_nodes()
if( just_once )
{
just_once = false;
-
- for(int i=0; i<256; i++)
- {
- char_nodes[i] = build_int_cst_type(CHAR, i);
- }
-
- // Create some useful constants to avoid cluttering up the code
- // build_int_cst_type() calls
- integer_minusone_node = build_int_cst_type(INT, -1);
- integer_two_node = build_int_cst_type(INT, 2);
- integer_eight_node = build_int_cst_type(INT, 8);
- size_t_zero_node = build_int_cst_type(SIZE_T, 0);
- int128_zero_node = build_int_cst_type(INT128, 0);
- int128_five_node = build_int_cst_type(INT128, 5);
- int128_ten_node = build_int_cst_type(INT128, 10);
- char_ptr_type_node = build_pointer_type(CHAR);
- uchar_ptr_type_node = build_pointer_type(UCHAR);
- wchar_ptr_type_node = build_pointer_type(WCHAR);
- long_double_ten_node = build_real_from_int_cst(
- LONGDOUBLE,
- build_int_cst_type(INT,10));
- sizeof_size_t = build_int_cst_type(SIZE_T, sizeof(size_t));
- sizeof_pointer = build_int_cst_type(SIZE_T, sizeof(void *));
-
- bool_true_node = build2(EQ_EXPR,
- integer_type_node,
- integer_one_node,
- integer_one_node);
-
- bool_false_node = build2( EQ_EXPR,
- integer_type_node,
- integer_one_node,
- integer_zero_node);
-
cblc_field_type_node = create_cblc_field_t();
cblc_field_p_type_node = build_pointer_type(cblc_field_type_node);
cblc_field_pp_type_node = build_pointer_type(cblc_field_p_type_node);
diff --git a/gcc/cobol/symbols.h b/gcc/cobol/symbols.h
index 02c27d05f995c285be39f6b50356bf0579aedd62..06cc35900cfe01b7977b0c227ef8760998c54be1 100644
--- a/gcc/cobol/symbols.h
+++ b/gcc/cobol/symbols.h
@@ -722,7 +722,6 @@ struct cbl_proc_addresses_t {
struct cbl_proc_t {
struct cbl_label_t *label;
- const char *target_of_call;
struct cbl_proc_addresses_t top;
struct cbl_proc_addresses_t exit;
struct cbl_proc_addresses_t bottom;
diff --git a/gcc/cobol/symfind.cc b/gcc/cobol/symfind.cc
index 5891c102507d93aa222db5a291521b7cf6efe470..f4578887c3a9dd11024594f037f92329fb64c4c0 100644
--- a/gcc/cobol/symfind.cc
+++ b/gcc/cobol/symfind.cc
@@ -143,9 +143,8 @@ dump_symbol_map2( const field_key_t& key, const std::list<size_t>& candidates )
free(tmp);
}
- //warn( "%s:%d: %3zu %s {%s}", __func__, __LINE__,
- yywarn( "%s:%d: %zu %s {%s}", __func__, __LINE__,
- key.program, key.name, fields );
+ dbgmsg( "%s:%d: %3zu %s {%s}", __func__, __LINE__,
+ key.program, key.name, fields );
free(fields);
}
@@ -160,7 +159,7 @@ dump_symbol_map2() {
n++;
}
}
- yywarn("symbol_map2 has %d program elements", n);
+ dbgmsg("symbol_map2 has %d program elements", n);
}
static void
@@ -176,7 +175,7 @@ dump_symbol_map_value( const char name[], const symbol_map_t::value_type& value
free(tmp);
}
- yywarn( "%s:%d: %s -> %-24s {%s }", __func__, __LINE__,
+ dbgmsg( "%s:%d: %s -> %-24s {%s }", __func__, __LINE__,
name, value.first.c_str(), ancestry );
free(ancestry);
}
@@ -194,7 +193,7 @@ field_structure( symbol_elem_t& sym ) {
if( getenv(__func__) && sym.type == SymField ) {
const auto& field = *cbl_field_of(&sym);
- yywarn("%s: #%zu %s: '%s' is_data_field: %s", __func__,
+ dbgmsg("%s: #%zu %s: '%s' is_data_field: %s", __func__,
symbol_index(&sym), cbl_field_type_str(field.type), field.name,
is_data_field(sym)? "yes" : "no" );
}
@@ -226,7 +225,7 @@ field_structure( symbol_elem_t& sym ) {
}
if( getenv(__func__) && yydebug ) {
- yywarn( "%s:%d: '%s' has %zu ancestors", __func__, __LINE__,
+ dbgmsg( "%s:%d: '%s' has %zu ancestors", __func__, __LINE__,
elem.first.c_str(), elem.second.size() );
dump_symbol_map_value(__func__, elem);
}
@@ -260,7 +259,7 @@ build_symbol_map() {
symbol_map.erase(sym_name_t(""));
if( yydebug ) {
- yywarn( "%s:%d: %zu of %zu symbols inserted into %zu in symbol_map",
+ dbgmsg( "%s:%d: %zu of %zu symbols inserted into %zu in symbol_map",
__func__, __LINE__, nsym, end, symbol_map.size() );
if( getenv(__func__) ) {
@@ -290,7 +289,7 @@ public:
}
protected:
void dump_key( const char tag[], const symbol_map_t::key_type& key ) const {
- yywarn( "symbol_map key: %s { %3zu %3zu %s }",
+ dbgmsg( "symbol_map key: %s { %3zu %3zu %s }",
tag, key.program, key.parent, key.name );
}
};
@@ -323,7 +322,7 @@ public:
ancestors->front() );
if( p != item.second.end() ) {
if( false && yydebug ) {
- yywarn( "reduce_ancestry:%d: reduce %s to %zu parents [%zu ...]", __LINE__,
+ dbgmsg( "reduce_ancestry:%d: reduce %s to %zu parents [%zu ...]", __LINE__,
item.first.c_str(), ancestors->size(), ancestors->at(0) );
}
// Preserve symbol's index at front of ancestor list.
@@ -434,7 +433,7 @@ name_has_names( const symbol_elem_t *e,
for( auto name : names ) {
p += snprintf( p, (buffer + sizeof(buffer)) - p, "%s ", name );
}
- yywarn("%s: #%zu (%s) matches '%s'", __func__,
+ dbgmsg("%s: #%zu (%s) matches '%s'", __func__,
symbol_index(orig), cbl_field_of(orig)->name, buffer);
}
@@ -473,27 +472,29 @@ symbol_match2( size_t program,
const char *sep = "";
for( auto name : names ) {
char *partial = ancestry;
- asprintf(&ancestry, "%s%s%s", partial? partial : "", sep, name);
+ int asret = asprintf(&ancestry, "%s%s%s", partial? partial : "", sep, name);
+ assert(asret);
sep = " -> ";
assert(ancestry);
free(partial);
}
if( fields.empty() ) {
- yywarn("%s: '%s' matches no fields", __func__, ancestry);
+ dbgmsg("%s: '%s' matches no fields", __func__, ancestry);
dump_symbol_map2();
} else {
char *fieldstr = NULL;
sep = "";
for( auto field : fields ) {
char *partial = fieldstr;
- asprintf(&fieldstr, "%s%s%zu", partial? partial : "", sep, field);
+ int asret = asprintf(&fieldstr, "%s%s%zu", partial? partial : "", sep, field);
+ assert(asret);
sep = ", ";
assert(fieldstr);
free(partial);
}
- yywarn("%s: '%s' matches %zu fields: {%s}", __func__, ancestry, fields.size(), fieldstr);
+ dbgmsg("%s: '%s' matches %zu fields: {%s}", __func__, ancestry, fields.size(), fieldstr);
free(fieldstr);
}
free(ancestry);
@@ -577,7 +578,7 @@ symbol_find( size_t program, std::list<const char *> names ) {
return std::pair<symbol_elem_t *, bool>(NULL, false);
}
if( yydebug ) {
- yywarn( "%s:%d: '%s' has %zu possible matches",
+ dbgmsg( "%s:%d: '%s' has %zu possible matches",
__func__, __LINE__, names.back(), items.size() );
std::for_each( items.begin(), items.end(), dump_symbol_map_value1 );
}
@@ -640,7 +641,7 @@ symbol_find_of( size_t program, std::list<const char *> names, size_t group ) {
symbol_map_t input = symbol_match(program, names);
if( getenv(__func__) && input.size() != 1 ) {
- yywarn( "%s:%d: '%s' has %zu candidates for group %zu",
+ dbgmsg( "%s:%d: '%s' has %zu candidates for group %zu",
__func__, __LINE__, names.back(), input.size(), group );
std::for_each( input.begin(), input.end(), dump_symbol_map_value1 );
}
@@ -656,7 +657,7 @@ symbol_find_of( size_t program, std::list<const char *> names, size_t group ) {
}
if( yydebug ) {
- yywarn( "%s:%d: '%s' has %zu possible matches",
+ dbgmsg( "%s:%d: '%s' has %zu possible matches",
__func__, __LINE__, names.back(), input.size() );
std::for_each( input.begin(), input.end(), dump_symbol_map_value1 );
}
diff --git a/libgcobol/gfileio.cc b/libgcobol/gfileio.cc
index d8188a384383b6cab969ea789f4f49d2f1b71ce7..6d02fe935468e03455a0c46d748b01297141e2c2 100644
--- a/libgcobol/gfileio.cc
+++ b/libgcobol/gfileio.cc
@@ -783,25 +783,6 @@ file_indexed_first_position(cblc_file_t *file, int key_number)
return retval;
}
-#if 0
-static long
-file_indexed_next_position(cblc_file_t *file, int key_number)
- {
- // Return the next position for the original key value from the multimap
- long retval = -1;
-
- // Pick up our structure for this key_number
- file_index_t *file_index = &file->supplemental->indexes[key_number];
-
- if( file_index->current_iterator != file_index->ending_iterator)
- {
- file_index->current_iterator++;
- retval = file_index->current_iterator->second;
- }
- return retval;
- }
-#endif
-
static int
read_an_indexed_record( cblc_file_t *file,
long max_bytes,
@@ -1981,33 +1962,14 @@ file_indexed_update_indices(cblc_file_t *file,
file_index->current_iterator++;
}
-// std::multimap<std::vector<unsigned char>, long>::iterator iti;
if( safe_to_insert )
{
std::vector<unsigned char>key_value =
file_indexed_make_key(file, key_number);
std::pair<std::vector<unsigned char>, long>
- to_insert(key_value, record_position);
-// iti =
- file_index->key_to_position.insert(to_insert);
- }
-#if 0
- size_t i = key_number;
- fprintf(stderr, "Inserted Key Number %ld\n", i);
- std::multimap<std::vector<unsigned char>, long>::const_iterator it =
- file->supplemental->indexes[i].key_to_position.begin();
- while( it != file->supplemental->indexes[i].key_to_position.end() )
- {
- fprintf(stderr, " ");
- for(size_t j=0; j<it->first.size(); j++)
- {
- fprintf(stderr, "%c", it->first[j]);
- }
- fprintf(stderr, " %ld\n", it->second);
- it++;
+ to_insert(key_value, record_position);
+ file_index->key_to_position.insert(to_insert);
}
-#endif
-
}
}
return okay;
@@ -3047,7 +3009,7 @@ line_sequential_file_read( cblc_file_t *file)
}
else // We filled the whole record area. Look ahead one character
{
-#if 0
+#ifdef POSSIBLY_IBM
// In this code, unread characters before the internal_newline
// are read next time. See page 133 of the IBM Language Reference
// Manual: "If the first unread character is the record delimiter, it
@@ -4063,27 +4025,6 @@ done:
fseek(file->file_pointer, 0, SEEK_SET);
handle_ferror(file, __func__, "fseek() error");
-#if 0
- // Dump all of the keys:
- for( size_t i=1; i<file->supplemental->indexes.size(); i++ )
- {
- fprintf(stderr, "Key Number %ld\n", i);
-
- std::multimap<std::vector<unsigned char>, long>::iterator it =
- file->supplemental->indexes[i].current_iterator;
-
- while( it != file->supplemental->indexes[i].key_to_position.end() )
- {
- fprintf(stderr, " ");
- for(size_t j=0; j<it->first.size(); j++)
- {
- fprintf(stderr, "%c", it->first[j]);
- }
- fprintf(stderr, " %ld\n", it->second);
- it++;
- }
- }
-#endif
}
static void
@@ -4564,7 +4505,7 @@ public:
, Delete(Delete)
{}
-#if 0 && implemented
+#if FILE_IO_IMPLEMENTED
int read_next();
int fildelete();
void ioinit();
diff --git a/libgcobol/gmath.cc b/libgcobol/gmath.cc
index 9236446008c9d010ca4024dba0bce31ef471816e..db76ae1c7739d33e53d5982e5be9a92b053566cd 100644
--- a/libgcobol/gmath.cc
+++ b/libgcobol/gmath.cc
@@ -1609,13 +1609,6 @@ divide_int128_by_int128(int256 "ient,
scale_int256_by_digits(quotient, scale);
quotient_rdigits = scale + dividend_rdigits - divisor_rdigits;
-
-#if 0
- int scale = MAX_FIXED_POINT_DIGITS;
- scale_int256_by_digits(quotient, scale-dividend_rdigits);
- quotient_rdigits = scale - divisor_rdigits;
-#endif
-
// Now, let's see if we can do a simple divide-by-single-place calculation:
if( divisor64[1] == 0 )
diff --git a/libgcobol/libgcobol.cc b/libgcobol/libgcobol.cc
index 8f98068f11d4051bc1f07ffc3730a7441b69c375..c20918115a07103d988ed02000cad2254a262d52 100644
--- a/libgcobol/libgcobol.cc
+++ b/libgcobol/libgcobol.cc
@@ -169,7 +169,11 @@ size_t __gg__call_parameter_lengths[ARG_LIMIT];
void *__gg__entry_location = NULL;
-// This needs a comment. Right now I don't remember what it is for.
+// This is the current value at the back of the PERFORM <PROC> stack of
+// procedure signatures. Said another way: When the exit address at
+// the end of a paragraph matches this value address, then it is time to pop
+// the return address off of the stack. It's in this fashion that we implements
+// nested PERFORM PROC statements.
void *__gg__exit_address = NULL;
static ec_status_t ec_status;
@@ -429,15 +433,6 @@ __gg__set_program_name(char *progname)
program_name = progname;
}
-#if 0
-static
-char *
-get_program_name()
- {
- return program_name;
- }
-#endif
-
extern "C"
void
__gg__push_program_state()
@@ -12435,19 +12430,6 @@ __gg__module_name(cblc_field_t *dest, module_type_t type)
}
strcat(result, " ");
-#if 0
- {
- static const int SIZE=100;
- void *buffer[SIZE];
- int size = backtrace(buffer, SIZE);
- char **symbols = backtrace_symbols(buffer, size);
- for(int i=0; i<size; i++)
- {
- fprintf(stderr, "%s\n", symbols[i]);
- }
- free(symbols);
- }
-#endif
break;
case module_toplevel_e: