Merge SVN 4711

cobc/ChangeLog

@@ -208,6 +208,25 @@
 	* codegen.c (output_perform_call): allow label end to be NULL if
 	  there is no PERFORM THRU, adjusted callers to not pass duplicate labels
 
+2022-09-26  Simon Sobisch <[email protected]>
+
+	* cobc.c (cobc_abort_msg): use negative cb_source_line to reference
+	  last known position during codegen
+	* codegen.c (output_stmt): store source reference if generated
+	  statement has one attached
+	* codegen.c (output_standard_includes): fix bug #708 missing math
+	  header inclusion if first program has no decimal
+	* codegen.c (output_data, output_call): fix bug #855 CALL generation
+	  when using figurative constants
+	* codegen.c: correct use of CB_PREFIX_DECIMAL -> generated code now has
+	  "d_" prefix instead of "d" in all places
+	* cobc.h, tree.h: moved some function declarations
+	* tree.c, tree.h (cb_literal_value), codegen.c, parser.y: moved double
+	  and identical defined function literal_value to a single place
+	* codegen.c, tree.h, cobc.c: renamed cb_init_codegen
+	  to clear_local_codegen_vars
+	* cobc.c: ask user for reporting reallocation memory issues
+
 2022-09-20  Simon Sobisch <[email protected]>
 
 	* parser.y (examine_format_variant): fix compiler warning

cobc/cobc.c

@@ -172,7 +172,7 @@ int			errorcount = 0;
 int			warningcount = 0;
 int			fatal_errors_flag = 0;
 int			no_physical_cancel = 0;
-int			cb_source_line = 0;
+int			cb_source_line = 0;	/* current source line, when negative: in codegen */
 int			cb_saveargc = 0;
 int			cb_keycompress_pend = 0;
 int			cb_keycompress_ready = 0; /* Value for cb_keycompress */
@@ -629,7 +629,7 @@ cobc_free_mem (void)
 		cobc_free (repsl);
 	}
 	cobc_mainmem_base = NULL;
-	cb_init_codegen ();
+	clear_local_codegen_vars ();
 	ppp_clear_lists ();
 }
 
@@ -982,7 +982,7 @@ cobc_main_realloc (void *prevptr, const size_t size)
 	/* LCOV_EXCL_START */
 	if (!curr) {
 		cobc_err_msg (_("attempt to reallocate non-allocated memory"));
-		cobc_abort_terminate (0);
+		cobc_abort_terminate (1);
 	}
 	/* LCOV_EXCL_STOP */
 	m->next = curr->next;
@@ -1098,7 +1098,7 @@ cobc_parse_realloc (void *prevptr, const size_t size)
 	/* LCOV_EXCL_START */
 	if (!curr) {
 		cobc_err_msg (_("attempt to reallocate non-allocated memory"));
-		cobc_abort_terminate (0);
+		cobc_abort_terminate (1);
 	}
 	/* LCOV_EXCL_STOP */
 	m->next = curr->next;
@@ -2128,13 +2128,18 @@ cobc_abort_msg (void)
 		} else {
 			prog_type = prog_id = (char *)_("unknown");
 		}
-		if (!cb_source_line) {
-			cobc_err_msg (_("aborting codegen for %s (%s: %s)"),
-				cb_source_file, prog_type, prog_id);
-		} else {
+		if (cb_source_line > 0) {
 			cobc_err_msg (_("aborting compile of %s at line %d (%s: %s)"),
 				cb_source_file, cb_source_line, prog_type, prog_id);
+		/* LCOV_EXCL_START */
+		} else if (cb_source_line) {
+			cobc_err_msg (_("aborting codegen for %s, last statement at line %d (%s: %s)"),
+				cb_source_file, -cb_source_line, prog_type, prog_id);
+		} else {
+			cobc_err_msg (_("aborting codegen for %s (%s: %s)"),
+				cb_source_file, prog_type, prog_id);
 		}
+		/* LCOV_EXCL_STOP */
 	} else {
 		cobc_err_msg (_("aborting"));
 	}
@@ -8780,7 +8785,7 @@ process_file (struct filename *fn, int status)
 			cobc_free (mptrt);
 		}
 		cobc_parsemem_base = NULL;
-		cb_init_codegen ();
+		clear_local_codegen_vars ();
 		/* Restore default flags */
 		cb_odoslide = save_odoslide;
 	} else {

cobc/cobc.h

@@ -643,18 +643,9 @@ extern int		yylex (void);
 extern int		yyparse (void);
 #endif
 
-extern void		ylex_clear_all (void);
-extern void		ylex_call_destroy (void);
-
 /* typeck.c */
 extern size_t		suppress_warn;	/* no warnings for internal generated stuff */
 
-/* codeoptim.c */
-extern void		cob_gen_optim (const enum cb_optim);
-
-/* codegen.c */
-extern void		cb_init_codegen (void);
-
 /* error.c */
 #define CB_MSG_STYLE_GCC	0
 #define CB_MSG_STYLE_MSC	1U

cobc/codegen.c

@@ -568,7 +568,7 @@ list_cache_sort (void *inlist, int (*cmpfunc)(const void *mp1, const void *mp2))
 
 /* Clear local variables */
 void
-cb_init_codegen (void)
+clear_local_codegen_vars (void)
 {
 	attr_cache = NULL;
 	base_cache = NULL;
@@ -1411,12 +1411,13 @@ output_data (cb_tree x)
 			field_iteration);
 		break;
 	case CB_TAG_CONST:
-		/* LCOV_EXCL_START */
-		if (x != cb_null) {
-			CB_TREE_TAG_UNEXPECTED_ABORT (x);
+		if (x == cb_null) {
+			output ("NULL");
+		} else {
+			output ("(");
+			output_param (x, 0);
+			output (")->data");
 		}
-		/* LCOV_EXCL_STOP */
-		output ("NULL");
 		break;
 	/* LCOV_EXCL_START */
 	default:
@@ -1918,6 +1919,16 @@ output_globext_cache (void)
 static void
 output_standard_includes (struct cb_program *prog)
 {
+	struct cb_program *p;
+
+#if defined (HAVE_GMP_H)
+	const char *math_include = "#include <gmp.h>";
+#elif defined (HAVE_MPIR_H)
+	const char *math_include = "#include <mpir.h>";
+#else
+#error either HAVE_GMP_H or HAVE_MPIR_H needs to be defined
+#endif
+
 #if !defined (_GNU_SOURCE) && defined (_XOPEN_SOURCE_EXTENDED)
 	output_line ("#ifndef\t_XOPEN_SOURCE_EXTENDED");
 	output_line ("#define\t_XOPEN_SOURCE_EXTENDED 1");
@@ -1935,14 +1946,12 @@ output_standard_includes (struct cb_program *prog)
 	if (cb_flag_winmain) {
 		output_line ("#include <windows.h>");
 	}
-	if (prog->decimal_index_max || prog->flag_decimal_comp) {
-		#if defined (HAVE_GMP_H)
-		output_line ("#include <gmp.h>");
-		#elif defined (HAVE_MPIR_H)
-		output_line ("#include <mpir.h>");
-		#else
-		#error either HAVE_GMP_H or HAVE_MPIR_H needs to be defined
-		#endif
+	/* check if any of the processed programs has any decimal - then include appropriate header */
+	for (p = prog; p; p = p->next_program) {
+		if (p->decimal_index_max || p->flag_decimal_comp) {
+			output_line (math_include);
+			break;
+		}
 	}
 	output_line ("#include <libcob.h>");
 	output_newline ();
@@ -4348,7 +4357,7 @@ output_param (cb_tree x, int id)
 		}
 		break;
 	case CB_TAG_DECIMAL:
-		output ("d%d", CB_DECIMAL (x)->id);
+		output ("%s%d", CB_PREFIX_DECIMAL, CB_DECIMAL (x)->id);
 		break;
 	case CB_TAG_DECIMAL_LITERAL:
 		output ("%s%d", CB_PREFIX_DEC_CONST, CB_DECIMAL_LITERAL (x)->id);
@@ -7322,8 +7331,10 @@ output_call (struct cb_call *p)
 			}
 			if (x == cb_null) {
 				output ("NULL /*OMITTED*/");
-				break;
+			} else {
+				output_param (x, 0);
 			}
+			break;
 		default:
 			output ("NULL");
 			break;
@@ -8397,13 +8408,15 @@ output_goto (struct cb_goto *p)
 		output_block_close ();
 	} else if (p->target == NULL
 	        || p->target == cb_int1) {
-		/* EXIT PROGRAM/FUNCTION */
 		needs_exit_prog = 1;
+		/* EXIT FUNCTION */
 		if (current_prog->prog_type == COB_MODULE_TYPE_FUNCTION) {
 			output_line ("goto exit_function;");
+		/* GOBACK (target = cb_int1), possibly implied */
 		} else if (p->target == cb_int1
 		        || cb_flag_implicit_init || current_prog->nested_level) {
 			output_line ("goto exit_program;");
+		/* EXIT PROGRAM */
 		} else {
 			/* Ignore if not a callee */
 			output_line ("if (module->next)");
@@ -9005,6 +9018,12 @@ output_stmt (cb_tree x)
 		}
 	}
 
+	if (x->source_line) {
+		cb_source_file = x->source_file;
+		cb_source_line = -x->source_line;
+		/* cb_source_column = x->source_column; */
+	}
+
 	switch (CB_TREE_TAG (x)) {
 	case CB_TAG_STATEMENT: {
 		const struct cb_statement	*p = CB_STATEMENT (x);
@@ -11523,28 +11542,6 @@ output_report_source_move (struct cb_report *rep)
 
 /* Alphabet-name */
 
-static int
-literal_value (cb_tree x)
-{
-	if (x == cb_space) {
-		return ' ';
-	} else if (x == cb_zero) {
-		return '0';
-	} else if (x == cb_quote) {
-		return cb_flag_apostrophe ? '\'' : '"';
-	} else if (x == cb_norm_low) {
-		return 0;
-	} else if (x == cb_norm_high) {
-		return 255;
-	} else if (x == cb_null) {
-		return 0;
-	} else if (CB_TREE_CLASS (x) == CB_CLASS_NUMERIC) {
-		return cb_get_int (x) - 1;
-	} else {
-		return CB_LITERAL (x)->data[0];
-	}
-}
-
 static void
 output_alphabet_name_definition (struct cb_alphabet_name *p)
 {
@@ -11603,14 +11600,14 @@ output_class_name_definition (struct cb_class_name *p)
 	for (l = p->list; l; l = CB_CHAIN (l)) {
 		x = CB_VALUE (l);
 		if (CB_PAIR_P (x)) {
-			lower = literal_value (CB_PAIR_X (x));
-			upper = literal_value (CB_PAIR_Y (x));
+			lower = cb_literal_value (CB_PAIR_X (x));
+			upper = cb_literal_value (CB_PAIR_Y (x));
 			for (n = lower; n <= upper; ++n) {
 				vals[n] = 1;
 			}
 		} else {
 			if (CB_NUMERIC_LITERAL_P (x)) {
-				vals[literal_value (x)] = 1;
+				vals[cb_literal_value (x)] = 1;
 			} else if (x == cb_space) {
 				vals[' '] = 1;
 			} else if (x == cb_zero) {
@@ -12343,7 +12340,7 @@ output_internal_function (struct cb_program *prog, cb_tree parameter_list)
 	if (prog->decimal_index_max) {
 		output_local ("/* Decimal structures */\n");
 		for (inc = 0; inc < prog->decimal_index_max; inc++) {
-			output_local ("cob_decimal\t*d%d = NULL;\n", inc);
+			output_local ("cob_decimal\t*%s%d = NULL;\n", CB_PREFIX_DECIMAL, inc);
 		}
 		output_local ("\n");
 	}
@@ -12641,7 +12638,7 @@ output_internal_function (struct cb_program *prog, cb_tree parameter_list)
 			output ("cob_decimal_alloc (%u", prog->decimal_index_max);
 		}
 		for (inc = 0; inc < prog->decimal_index_max; inc++) {
-			output (", &d%u", inc);
+			output (", &%s%u", CB_PREFIX_DECIMAL, inc);
 		}
 		output (");");
 		output_newline ();
@@ -13002,8 +12999,7 @@ output_internal_function (struct cb_program *prog, cb_tree parameter_list)
 				output_line ("if (%s%d) {", CB_PREFIX_BASE, f->id);
 				output_line ("\tcob_free_alloc (&%s%d, NULL);",
 					     CB_PREFIX_BASE, f->id);
-				output_line ("\t%s%d = NULL;",
-					     CB_PREFIX_BASE, f->id);
+				output_line ("\t%s%d = NULL;", CB_PREFIX_BASE, f->id);
 				output_line ("}");
 			}
 		}
@@ -13015,7 +13011,7 @@ output_internal_function (struct cb_program *prog, cb_tree parameter_list)
 		output_prefix ();
 		output ("cob_decimal_pop (%u", prog->decimal_index_max);
 		for (inc = 0; inc < prog->decimal_index_max; inc++) {
-			output (", d%u", inc);
+			output (", %s%u", CB_PREFIX_DECIMAL, inc);
 		}
 		output (");");
 		output_newline ();
@@ -13191,7 +13187,7 @@ output_internal_function (struct cb_program *prog, cb_tree parameter_list)
 				seen = 1;
 				output_line ("/* Set Decimal Constant values */");
 			}
-			output_line ("%s%d = &%s%d;", 	CB_PREFIX_DEC_CONST, m->id,
+			output_line ("%s%d = &%s%d;", CB_PREFIX_DEC_CONST, m->id,
 				     CB_PREFIX_DEC_FIELD, m->id);
 			output_line ("cob_decimal_init(%s%d);", CB_PREFIX_DEC_CONST, m->id);
 			output_line ("cob_decimal_set_field (%s%d, (cob_field *)&%s%d);",

cobc/error.c

@@ -53,8 +53,7 @@ print_error_prefix (const char *file, int line, const char *prefix)
 	if (file) {
 		if (line <= 0) {
 			fprintf (stderr, "%s: ", file);
-		} else
-		if (cb_msg_style == CB_MSG_STYLE_MSC) {
+		} else if (cb_msg_style == CB_MSG_STYLE_MSC) {
 			fprintf (stderr, "%s(%d): ", file, line);
 		} else {
 			fprintf (stderr, "%s:%d: ", file, line);

cobc/parser.y

@@ -632,28 +632,6 @@ terminator_clear (cb_tree stmt, const unsigned int termid)
 	}
 }
 
-static int
-literal_value (cb_tree x)
-{
-	if (x == cb_space) {
-		return ' ';
-	} else if (x == cb_zero) {
-		return '0';
-	} else if (x == cb_quote) {
-		return cb_flag_apostrophe ? '\'' : '"';
-	} else if (x == cb_null) {
-		return 0;
-	} else if (x == cb_low) {
-		return 0;
-	} else if (x == cb_high) {
-		return 255;
-	} else if (CB_TREE_CLASS (x) == CB_CLASS_NUMERIC) {
-		return cb_get_int (x);
-	} else {
-		return CB_LITERAL (x)->data[0];
-	}
-}
-
 static void
 setup_use_file (struct cb_file *fileptr)
 {
@@ -4831,7 +4809,7 @@ class_item:
 	    CB_LITERAL_P ($3) && CB_LITERAL ($3)->size != 1) {
 		cb_error (_("CLASS literal with THRU must have size 1"));
 	}
-	if (literal_value ($1) <= literal_value ($3)) {
+	if (cb_literal_value ($1) <= cb_literal_value ($3)) {
 		$$ = CB_BUILD_PAIR ($1, $3);
 	} else {
 		$$ = CB_BUILD_PAIR ($3, $1);
@@ -5561,11 +5539,11 @@ _suppress_clause:
   }
 | SUPPRESS WHEN ALL basic_value
   {
-	$$ = cb_int (literal_value ($4));
+	$$ = cb_int (cb_literal_value ($4));
   }
 | SUPPRESS WHEN space_or_zero
   {
-	$$ = cb_int (literal_value ($3));
+	$$ = cb_int (cb_literal_value ($3));
   }
 | SUPPRESS WHEN LITERAL
   {