Merge remote-tracking branch 'upstream/master' into gc4

NEWS

@@ -423,6 +423,11 @@ Open Plans:
    previous versions; sources with *leading* P never worked correct before,
    and *must* be recompiled after upgrading
 
+** since its addition to GnuCOBOL ROUNDING MODE PROHIBITED just prevented
+   rounding; its behaviour changed to match the specification by doing that,
+   raising EC-SIZE-TRUNCATION and changed: not adjust the target field if
+   rounding would be necessary to store the data
+
 * Listing changes
 
 ** the timestamp in the header was changed from ANSI date format like

TODO

@@ -247,3 +247,5 @@ https://sourceforge.net/p/gnucobol/code/HEAD/tree/external-doc/guide/
 - Check if should use strcpy or memcpy with computed max-length for file_open_name in fileio.c:cob_open
 
 - Check what we should do about the casts used to remove const on open_mode in fileio.c and others (eg. in cob_file_open)
+
+- Investigate failed manual tests "CRT STATUS clause" and "X/Open CRT STATUS clause" (see r4180)

cobc/ChangeLog

@@ -50,6 +50,69 @@
 	* typeck.c (cb_emit_sort_init): generate call to cob_file_sort_options
 	* help.c (cobc_print_usage_dialect): extended -fregister help
 
+2023-05-11  Simon Sobisch <[email protected]>
+
+	* cobc.c (cobc_check_valid_name): allow leading underscore,
+	  prevent leading hyphen
+	* scanner.l (error_literal): change parameter literal_error to unsigned
+	  and raise only a warning for negative values, adjust callers
+	* scanner.l (scan_x): internally handle odd numbers of x'' literals,
+	  raise only a warning if the size is 1 and relaxed-syntax is active
+	* parser.y (data_description): improve error handling in DATA DIVISION
+	  to raise less errors and create "validated invalid" fields
+
+2023-05-10  Simon Sobisch <[email protected]>
+
+	* field.c (cb_build_field_tree), parser.y: copy SCREEN SECTION
+	  attributes from parent - instead of doing it in the parser
+	* parser.y (validate_screen_attributes): extracted duplicate code
+	* typeck.c (emit_field_accept_display): new function extracted
+	  from (cb_emit_accept), handling both DISPLAY and ACCEPT
+	* typeck.c (cob_field_display): dropped, replaced in the callers
+	  by call to (emit_field_accept_display) for not generating a call to
+	  fixed-attribute "cob_field_display" but to the varargs
+	  function "cob_display_field"
+	* codegen.c (output_screen_init), codeoptim.c (COB_SET_SCREEN):
+	  generate screen init not as separate function "cob_set_screen" but
+	  as macro "COB_SET_SCREEN" (there's no need or use to put all
+	  attributes on the stack)
+
+2023-05-09  Simon Sobisch <[email protected]>
+
+	* codegen.c (output_funcall): backup and restore adjusted static fields,
+	  minor refactoring
+	* codegen.c (output_funcall_item): extracted from (output_funcall)
+	* typeck.c (cb_emit_accept): dropped cb_gen_field_accept and don't generate
+	  call to fixed-attribute "cob_field_accept", instead generate a call to
+	  the varargs function "cob_accept_field" with passing only the attributes
+	  that are set (including the new CONTROL, COLOR and CURSOR)
+
+2023-05-08  Simon Sobisch <[email protected]>
+
+	* tree.c (cb_build_funcall), tree.h (struct cb_funcall): defined
+	  max. parameters for internal function calls as CB_BUILD_FUNCALL_MAX
+	  and increased it to 14
+
+	FR #189 + FR #355 - runtime-adjustable attributes for extended screenio
+	* tree.h (cb_field): new attributes screen_control and screen_color
+	* tree.h (cb_attr_struct): new attributes control, color and cursor
+	* parser.y, typeck.c (validate_attrs, cb_emit_accept, cb_emit_display,
+	  emit_field_display_for_last): add complete parsing for CONTROL,
+	  COLOR and CURSOR and set/read new attributes as appropriate
+	* parser.y: pass COB_SCREEN_CONV to runtime (currently not handled)
+
+2023-05-05  Simon Sobisch <[email protected]>
+
+	* field.c (cb_resolve_redefines): fix #881 wrong REDEFINES error on
+	  fields with redefinition
+
+2023-05-04  Simon Sobisch <[email protected]>
+
+	* typeck.c (cb_build_move_literal): restore writing of negative zero
+	  (DISPLAY overpunched), that was removed undocumented with 2.0
+	* typeck.c (cb_build_move_literal): optimized output for literals to
+	  fields with BLANK WHEN ZERO and SIGN LEADING
+
 2023-04-25  Simon Sobisch <[email protected]>
 
 	* codegen.c (output_so_load_version_check): new function to generate

cobc/cobc.c

@@ -1407,7 +1407,7 @@ cobc_bcompare (const void *p1, const void *p2)
 enum name_error_reason {
 	INVALID_LENGTH = 1,
 	EMPTY_NAME,
-	SPACE_UNDERSCORE_FIRST_CHAR,
+	SPACE_HYPHEN_FIRST_CHAR,
 	GNUCOBOL_PREFIX,
 	C_KEYWORD,
 	CONTAINS_DIRECTORY_SEPARATOR
@@ -1427,8 +1427,8 @@ cobc_error_name (const char *name, const enum cobc_name_type type,
 	case EMPTY_NAME:
 		s = _(" - name cannot be empty");
 		break;
-	case SPACE_UNDERSCORE_FIRST_CHAR:
-		s = _(" - name cannot begin with space or underscore");
+	case SPACE_HYPHEN_FIRST_CHAR:
+		s = _(" - name cannot begin with space or hyphen");
 		break;
 	case GNUCOBOL_PREFIX:
 		s = _(" - name cannot begin with 'cob_' or 'COB_'");
@@ -1498,8 +1498,8 @@ cobc_check_valid_name (const char *name, const enum cobc_name_type prechk)
 	/* missing check (here): encoded length > internal buffer,
 	   see cob_encode_program_id */
 
-	if (*name == '_' || *name == ' ') {
-		cobc_error_name (name, prechk, SPACE_UNDERSCORE_FIRST_CHAR);
+	if (*name == '-' || *name == ' ') {
+		cobc_error_name (name, prechk, SPACE_HYPHEN_FIRST_CHAR);
 		return 1;
 	}
 
@@ -2119,14 +2119,15 @@ set_compile_date (void)
 {
 	static int sde_todo = 0;
 	if (sde_todo == 0) {
-		char  *s = getenv ("SOURCE_DATE_EPOCH");
+		unsigned char  *s = (unsigned char *) getenv ("SOURCE_DATE_EPOCH");
 		sde_todo = 1;
 		if (s && *s) {
 			if (cob_set_date_from_epoch (&current_compile_time, s) == 0) {
 				set_compile_date_tm ();
 				return;
 			}
-			cobc_err_msg (_("environment variable '%s' has invalid content"), "SOURCE_DATE_EPOCH");
+			cobc_err_msg (_("environment variable '%s' has invalid content"),
+				"SOURCE_DATE_EPOCH");
 			if (!cb_flag_syntax_only) {
 				cb_source_file = NULL;
 				cobc_abort_terminate (0);

cobc/codegen.c

@@ -4847,12 +4847,26 @@ output_funcall_typed (struct cb_funcall *p, const char type)
 }
 
 
+static void COB_INLINE COB_A_INLINE
+output_funcall_item (cb_tree x, const int i, unsigned int func_nolitcast)
+{
+	if (x && CB_LITERAL_P (x)) {
+		nolitcast = func_nolitcast;
+	} else {
+		nolitcast = 0;
+	}
+	output_param (x, i);
+}
+
+
 static void
 output_funcall (cb_tree x)
 {
 	struct cb_funcall	*p;
 	cb_tree			l;
 	int			i;
+	const int	nolitcast_origin = nolitcast;
+	const int	screenptr_origin = screenptr;
 
 	p = CB_FUNCALL (x);
 	if (p->name[0] == '$') {
@@ -4863,33 +4877,22 @@ output_funcall (cb_tree x)
 	screenptr = p->screenptr;
 	output ("%s (", p->name);
 	for (i = 0; i < p->argc; i++) {
+		if (i) {
+			output (", ");
+		}
 		if (p->varcnt && i + 1 == p->argc) {
-			output ("%d, ", p->varcnt);
-			for (l = p->argv[i]; l; l = CB_CHAIN (l)) {
-				if (CB_VALUE (l) && CB_LITERAL_P (CB_VALUE (l))) {
-					nolitcast = p->nolitcast;
-				}
-				output_param (CB_VALUE (l), i);
-				nolitcast = 0;
-				i++;
-				if (CB_CHAIN (l)) {
-					output (", ");
-				}
-			}
-		} else {
-			if (p->argv[i] && CB_LITERAL_P (p->argv[i])) {
-				nolitcast = p->nolitcast;
-			}
-			output_param (p->argv[i], i);
-			nolitcast = 0;
-			if (i + 1 < p->argc) {
+			output ("%d", p->varcnt);
+			for (l = p->argv[i]; l; l = CB_CHAIN (l), i++) {
 				output (", ");
+				output_funcall_item (CB_VALUE (l), i, p->nolitcast);
 			}
+		} else {
+			output_funcall_item (p->argv[i], i, p->nolitcast);
 		}
 	}
 	output (")");
-	nolitcast = 0;
-	screenptr = 0;
+	nolitcast = nolitcast_origin;
+	screenptr = screenptr_origin;
 }
 
 static void
@@ -10338,13 +10341,13 @@ output_screen_definition (struct cb_field *p)
 static void
 output_screen_init (struct cb_field *p, struct cb_field *previous)
 {
-	int	type;
-
-	type = (p->children ? COB_SCREEN_TYPE_GROUP :
+	const int	type = (p->children ? COB_SCREEN_TYPE_GROUP :
 		p->values ? COB_SCREEN_TYPE_VALUE :
 		(p->size > 0) ? COB_SCREEN_TYPE_FIELD : COB_SCREEN_TYPE_ATTRIBUTE);
+
 	output_prefix ();
-	output ("cob_set_screen (&%s%d, ", CB_PREFIX_SCR_FIELD, p->id);
+	output ("COB_SET_SCREEN (%s%d, %d, 0x" CB_FMT_LLX ", ",
+		CB_PREFIX_SCR_FIELD, p->id, type, p->screen_flag);
 
 	if (p->sister && p->sister->level != 1) {
 		output ("&%s%d, ", CB_PREFIX_SCR_FIELD, p->sister->id);
@@ -10376,10 +10379,10 @@ output_screen_init (struct cb_field *p, struct cb_field *previous)
 
 	if (type == COB_SCREEN_TYPE_FIELD) {
 		output_param (cb_build_field_reference (p, NULL), -1);
-		output (", ");
 	} else {
-		output ("NULL, ");
+		output ("NULL");
 	}
+	output (", ");
 
 	output_newline ();
 	output_prefix ();
@@ -10388,53 +10391,51 @@ output_screen_init (struct cb_field *p, struct cb_field *previous)
 	if (type == COB_SCREEN_TYPE_VALUE) {
 		/* Need a field reference here */
 		output_param (cb_build_field_reference (p, NULL), -1);
-		output (", ");
 	} else {
-		output ("NULL, ");
+		output ("NULL");
 	}
+	output (", ");
 
 	if (p->screen_line) {
 		output_param (p->screen_line, 0);
-		output (", ");
 	} else {
-		output ("NULL, ");
+		output ("NULL");
 	}
+	output (", ");
 
 	if (p->screen_column) {
 		output_param (p->screen_column, 0);
-		output (", ");
 	} else {
-		output ("NULL, ");
+		output ("NULL");
 	}
+	output (", ");
 
 	output_newline ();
 	output_prefix ();
 	output ("\t\t  ");
 
 	if (p->screen_foreg) {
 		output_param (p->screen_foreg, 0);
-		output (", ");
 	} else {
-		output ("NULL, ");
+		output ("NULL");
 	}
+	output (", ");
 
 	if (p->screen_backg) {
 		output_param (p->screen_backg, 0);
-		output (", ");
 	} else {
-		output ("NULL, ");
+		output ("NULL");
 	}
+	output (", ");
 
 	if (p->screen_prompt) {
 		output_param (p->screen_prompt, 0);
-		output (", ");
 	} else {
-		output ("NULL, ");
+		output ("NULL");
 	}
+	output (", %d);", p->occurs_min);
 
 	output_newline ();
-	output_line ("\t\t  %d, %d, 0x" CB_FMT_LLX ");",
-		type, p->occurs_min, p->screen_flag);
 
 	/* TODO: pass information for USAGE CONTROL items here */
 
@@ -13489,6 +13490,8 @@ output_internal_function (struct cb_program *prog, cb_tree parameter_list)
 		output_line ("/* Initialize SCREEN items */");
 		/* Initialize items with VALUE */
 		output_initial_values (prog->screen_storage);
+		/* output structure, note: this can be quite complex
+		   and nested, therefore this isn't done in the header */
 		output_screen_init (prog->screen_storage, NULL);
 		output_newline ();
 	}
@@ -14004,7 +14007,6 @@ output_entry_function (struct cb_program *prog, cb_tree entry,
 		}
 	}
 
-
 	/*
 	  We have to cater for sticky-linkage here at the entry point
 	  site. Doing it in the internal function is too late as we then do not

cobc/codeoptim.c

@@ -56,29 +56,22 @@ cob_gen_optim (const enum cb_optim val)
 	switch (val) {
 
 	case COB_SET_SCREEN:
-		output_storage ("static void COB_NOINLINE");
-		output_storage ("cob_set_screen (cob_screen *s, cob_screen *next,");
-		output_storage ("		cob_screen *prev, cob_screen *child, cob_screen *parent,");
-		output_storage ("		cob_field *field, cob_field *value,");
-		output_storage ("		cob_field *line, cob_field *column,");
-		output_storage ("		cob_field *foreg, cob_field *backg, cob_field *prompt,");
-		output_storage ("		const int type, const int occurs, const int attr)");
-		output_storage ("{");
-		output_storage ("	s->next = next;");
-		output_storage ("	s->prev = prev;");
-		output_storage ("	s->child = child;");
-		output_storage ("	s->parent = parent;");
-		output_storage ("	s->field = field;");
-		output_storage ("	s->value = value;");
-		output_storage ("	s->line = line;");
-		output_storage ("	s->column = column;");
-		output_storage ("	s->foreg = foreg;");
-		output_storage ("	s->backg = backg;");
-		output_storage ("	s->prompt = prompt;");
-		output_storage ("	s->type = type;");
-		output_storage ("	s->occurs = occurs;");
-		output_storage ("	s->attr = attr;");
-		output_storage ("}");
+		output_storage ("#define COB_SET_SCREEN(s,typ,att,nxt,prv,chld,p,fld,val,l,c,fg,bg,prmpt,occ) \\");
+		output_storage ("do{	s.next = nxt;     \\");
+		output_storage ("	s.prev = prv;     \\");
+		output_storage ("	s.child = chld;   \\");
+		output_storage ("	s.parent = p;     \\");
+		output_storage ("	s.field = fld;    \\");
+		output_storage ("	s.value = val;    \\");
+		output_storage ("	s.line = l;       \\");
+		output_storage ("	s.column = c;     \\");
+		output_storage ("	s.foreg = fg;     \\");
+		output_storage ("	s.backg = bg;     \\");
+		output_storage ("	s.prompt = prmpt; \\");
+		output_storage ("	s.type = typ;     \\");
+		output_storage ("	s.occurs = occ;   \\");
+		output_storage ("	s.attr = att;     \\");
+		output_storage ("} ONCE_COB");
 		return;
 
 	case COB_SET_REPORT: