Revision(en) 5075-5077 von branches/gnucobol-3.x zusammengeführt:

minor cleanup and SORT/MERGE adjustments

libcob:
* fsqlxfd.c (cob_findkey_attr), fileio.c, fisam.c: extracted identical logic from cob_findkey, indexed_findkey and db_findkey; dropping the later two and set mapkey after calling it
* Makefile.am: link fsqlxfd into all libraries (may be adjusted later)
* fileio.c (cob_file_create), common.h: prefer relevant enums over int
* fileio.c (cob_file_sort_using, cob_file_sort_giving): raise COB_EC_SORT_MERGE_FILE_OPEN when applicable
* fileio.c (cob_copy_check, cob_file_sort_submit, cob_file_sort_retrieve): pass most matching argument type instead of the structures containing it
* fileio.c (cobsort): new attribute flag_merge
* fileio.c (cob_file_sort_options), common.h: new function to pass more options, so far only used to set flag_merge

cobc:

* tree.h (cb_file), parser.y: organization and access_mode as enums
* typeck.c (cb_emit_sort_init, cb_emit_sort_using, cb_emit_sort_giving), parser.y: extended syntax checks, distinguish MERGE and SORT within diagnostics
* parser.y, typeck.c (cb_emit_sort_init): move all syntax checks from code-emitter to parser
* tree.h (cb_statement), parser.y, typeck.c: drop flag_merge, instead check by "statement == STMT_MERGE"
* typeck.c (cb_emit_sort_init): generate call to cob_file_sort_options

tests/cobol85/report.pl: place stderr from test runs into .out file

cobc/ChangeLog

@@ -1,4 +1,16 @@
 
+2023-06-02  Simon Sobisch <simonsobisch@gnu.org>
+
+	* tree.h (cb_file), parser.y: organization and access_mode as enums
+	* typeck.c (cb_emit_sort_init, cb_emit_sort_using, cb_emit_sort_giving),
+	  parser.y: extended syntax checks, distinguish MERGE and SORT within
+	  diagnostics
+	* parser.y, typeck.c (cb_emit_sort_init): move all syntax checks from
+	  code-emitter to parser
+	* tree.h (cb_statement), parser.y, typeck.c: drop flag_merge,
+	  instead check by "statement == STMT_MERGE"
+	* typeck.c (cb_emit_sort_init): generate call to cob_file_sort_options
+
 2023-02-26  Ron Norman <rjn@inglenet.com>
 
 	* field.c: Emit warning if COMP-X has PIC S9 as COMP-X is always unsigned

cobc/codegen.c

@@ -2808,16 +2808,16 @@ output_emit_one_field (struct cb_field *f, const char *cmt, int sub)
 	else
 		output ("static cob_field %s%d\t= ", CB_PREFIX_FIELD, f->id);
 	output_field_sub (f, cb_build_field_reference (f, NULL), sub);
-	output_local(";\t/* ");
+	output_local (";\t/* ");
 	output_local ("%s ", get_field_name (f));
 	if ((f->report_flag & COB_REPORT_COLUMN_RIGHT)) {
-		output_local(", RIGHT %d",f->report_column);
+		output_local (", RIGHT %d",f->report_column);
 	} else
 	if ((f->report_flag & COB_REPORT_COLUMN_LEFT)) {
-		output_local(", LEFT %d",f->report_column);
+		output_local (", LEFT %d",f->report_column);
 	} else
 	if ((f->report_flag & COB_REPORT_COLUMN_CENTER)) {
-		output_local(", CENTER %d",f->report_column);
+		output_local (", CENTER %d",f->report_column);
 	} else
 	if (f->report_column > 0) {
 		if (sub > 0 
@@ -2832,12 +2832,12 @@ output_emit_one_field (struct cb_field *f, const char *cmt, int sub)
 		}
 	}
 	if ((f->report_flag & COB_REPORT_COLUMN_RIGHT)) {
-		output_local(", GROUP INDICATE");
+		output_local (", GROUP INDICATE");
 	}
 	if (cmt) {
 		output_local (" : %s ", cmt);
 	}
-	output_local("*/\n");
+	output_local ("*/\n");
 }
 
 /*
@@ -9826,6 +9826,12 @@ output_file_initialization (struct cb_file *f)
 	case COB_ORG_SORT:
 		org_name = "COB_ORG_SORT";
 		break;
+	/* LCOV_EXCL_START */
+	default:
+		cobc_err_msg ("unexpected file type: %d",
+			 (int)f->organization);
+		COBC_ABORT ();
+	/* LCOV_EXCL_STOP */
 	}
 	switch (f->access_mode) {
 	case COB_ACCESS_SEQUENTIAL:
@@ -9837,6 +9843,12 @@ output_file_initialization (struct cb_file *f)
 	case COB_ACCESS_DYNAMIC:
 		acc_name = "COB_ACCESS_DYNAMIC";
 		break;
+	/* LCOV_EXCL_START */
+	default:
+		cobc_err_msg ("unexpected access type: %d",
+			 (int)f->access_mode);
+		COBC_ABORT ();
+	/* LCOV_EXCL_STOP */
 	}
 	if (!f->flag_line_adv
 	 && !f->flag_has_organization
@@ -9891,6 +9903,7 @@ output_file_initialization (struct cb_file *f)
 	} else {
 		strcpy (extname, "NULL");
 	}
+	/* TODO: generate enum names here */
 	output_line ("cob_file_create (&%s, %s, \"%s\",", file_name, extname, f->name);
 	output_indent_level += 17;
 	output_line ("%s,%s,%d,",org_name,acc_name,f->optional);

cobc/parser.y

@@ -747,7 +747,7 @@ setup_use_file (struct cb_file *fileptr)
 	struct cb_file	*newptr;
 
 	if (fileptr->organization == COB_ORG_SORT) {
-		cb_error (_("USE statement invalid for SORT file"));
+		cb_error (_("USE statement invalid for SD file"));
 	}
 	if (fileptr->flag_global) {
 		newptr = cobc_parse_malloc (sizeof(struct cb_file));
@@ -1603,7 +1603,7 @@ setup_prototype (cb_tree prototype_name, cb_tree ext_name,
 }
 
 static void
-error_if_record_delimiter_incompatible (const int organization,
+error_if_record_delimiter_incompatible (const enum cob_file_org organization,
 					const char *organization_name)
 {
 	int	is_compatible;
@@ -14256,9 +14256,8 @@ merge_statement:
   MERGE
   {
 	begin_statement (STMT_MERGE, 0);
-	current_statement->flag_merge = 1;
   }
-  sort_body
+  sort_merge_body
 ;
 
 
@@ -15453,19 +15452,24 @@ sort_statement:
   {
 	begin_statement (STMT_SORT, 0);
   }
-  sort_body
+  sort_merge_body
 ;
 
-sort_body:
-  table_identifier _sort_key_list _sort_duplicates _sort_collating
+sort_merge_body:
+  table_identifier	/* may reference a file or a table */
+  _sort_key_list _sort_duplicates _sort_collating
   {
 	cb_tree		x = cb_ref ($1);
 
 	$$ = NULL;
 	if (CB_VALID_TREE (x)) {
-		if ($2 == NULL || CB_VALUE($2) == NULL) {
+		if ($2 == NULL || CB_VALUE ($2) == NULL) {
+			if (current_statement->statement == STMT_MERGE) {
+				cb_error (_("MERGE requires KEY phrase"));
+				$2 = cb_error_node;
+			} else
 			if (CB_FILE_P (x)) {
-				cb_error (_("file sort requires KEY phrase"));
+				cb_error (_("file SORT requires KEY phrase"));
 				$2 = cb_error_node;
 			} else {
 				struct cb_field	*f = CB_FIELD_PTR (x);
@@ -15493,6 +15497,9 @@ sort_body:
 					$2 = cb_error_node;
 				}
 			}
+		} else if (CB_FILE_P (x) && CB_FILE (x)->organization != COB_ORG_SORT) {
+			cb_error_x (x, _("must be an SD filename"));
+			$2 = cb_error_node;
 		}
 		if (CB_VALID_TREE ($2)) {
 			cb_emit_sort_init ($1, $2, alphanumeric_collation, national_collation);
@@ -15551,7 +15558,11 @@ sort_input:
   /* empty */
   {
 	if ($0 && CB_FILE_P (cb_ref ($0))) {
-		cb_error (_("file sort requires USING or INPUT PROCEDURE"));
+		if (current_statement->statement == STMT_MERGE) {
+			cb_error (_("MERGE requires USING files"));
+		} else {
+			cb_error (_("file SORT requires USING or INPUT PROCEDURE"));
+		}
 	}
   }
 | USING file_name_list
@@ -15569,7 +15580,7 @@ sort_input:
 	if ($0) {
 		if (!CB_FILE_P (cb_ref ($0))) {
 			cb_error (_("INPUT PROCEDURE invalid with table SORT"));
-		} else if (current_statement->flag_merge) {
+		} else if (current_statement->statement == STMT_MERGE) {
 			cb_error (_("INPUT PROCEDURE invalid with MERGE"));
 		} else {
 			cb_emit_sort_input ($4);
@@ -15583,7 +15594,11 @@ sort_output:
   /* empty */
   {
 	if ($-1 && CB_FILE_P (cb_ref ($-1))) {
-		cb_error (_("file sort requires GIVING or OUTPUT PROCEDURE"));
+		if (current_statement->statement == STMT_MERGE) {
+			cb_error (_("MERGE requires GIVING or OUTPUT PROCEDURE"));
+		} else {
+			cb_error (_("file SORT requires GIVING or OUTPUT PROCEDURE"));
+		}
 	}
   }
 | GIVING file_name_list
@@ -16011,7 +16026,7 @@ unlock_body:
 	if (CB_VALID_TREE ($1)) {
 		if (CB_FILE (cb_ref ($1))->organization == COB_ORG_SORT) {
 			cb_error_x (CB_TREE (current_statement),
-				    _("UNLOCK invalid for SORT files"));
+				    _("UNLOCK invalid for SD files"));
 		} else {
 			cb_emit_unlock ($1);
 		}

cobc/scanner.l

@@ -360,7 +360,7 @@ static void	make_synonym (void);
 "FUNCTION" {
 	if (cobc_in_repository || cobc_cs_check == CB_CS_EXIT) {
 		yylval = NULL;
-	        RETURN_TOK (FUNCTION);
+		RETURN_TOK (FUNCTION);
 	}
 	BEGIN FUNCTION_STATE;
 }
@@ -896,8 +896,8 @@ H#[0-9A-Za-z]+ {
 	/* FIXME: move the code for filling "name" here and first
 	          check with "lookup_system_name (name) != NULL"
 	          if we actually want to do this,
-			  otherwise return 2 (!) WORD tokens (by adding a queue
-			  of tokens to be returned)
+	          otherwise return 2 (!) WORD tokens (by adding a queue
+	          of tokens to be returned)
 	*/
 	if (cobc_in_procedure) {
 		 /* unput characters */

cobc/tree.h

@@ -1121,8 +1121,8 @@ struct cb_file {
 	int			record_min;		/* RECORD CONTAINS */
 	int			record_max;		/* RECORD CONTAINS */
 	int			optional;		/* OPTIONAL */
-	int			organization;		/* ORGANIZATION - FIXME: use enum */
-	int			access_mode;		/* ACCESS MODE - FIXME: use enum */
+	enum cob_file_org		organization;		/* ORGANIZATION */
+	enum cob_file_access		access_mode;		/* ACCESS MODE */
 	int			lock_mode;		/* LOCK MODE */
 	int			fd_share_mode;		/* SHARING mode */
 	int			special;		/* Special file */
@@ -1487,7 +1487,6 @@ struct cb_statement {
 	enum cb_handler_type	handler_type;		/* Handler type */
 	unsigned int		flag_no_based	: 1;	/* Check BASED */
 	unsigned int		flag_in_debug	: 1;	/* In DEBUGGING */
-	unsigned int		flag_merge	: 1;	/* Is MERGE */
 	unsigned int		flag_callback	: 1;	/* DEBUG Callback */
 	unsigned int		flag_implicit	: 1;	/* Is an implicit statement */
 	unsigned int		flag_retry_times: 1;	/* RETRY exp TIMES */

cobc/typeck.c

@@ -12708,7 +12708,7 @@ cb_emit_set_last_exception_to_off (void)
 	cb_emit (CB_BUILD_FUNCALL_1 ("cob_set_exception", cb_int0));
 }
 
-/* SORT statement */
+/* SORT + MERGE statements */
 
 void
 cb_emit_sort_init (cb_tree name, cb_tree keys, cb_tree col, cb_tree nat_col)
@@ -12731,7 +12731,7 @@ cb_emit_sort_init (cb_tree name, cb_tree keys, cb_tree col, cb_tree nat_col)
 	}
 
 	/* note: the reference to the program's collation,
-	   if not explicit specified in SORT is done within libcob */
+	   if not explicit specified in SORT/MERGE, is done within libcob */
 	if (col == NULL) {
 		col = cb_null;
 	} else {
@@ -12746,28 +12746,30 @@ cb_emit_sort_init (cb_tree name, cb_tree keys, cb_tree col, cb_tree nat_col)
 	COB_UNUSED (nat_col);
 
 	if (CB_FILE_P (rtree)) {
-		if (CB_FILE (rtree)->organization != COB_ORG_SORT) {
-			cb_error_x (name, _("invalid SORT filename"));
-		}
+		cb_tree sort_return;
+		const struct cb_file *sd_file = CB_FILE (rtree);
 		if (current_program->cb_sort_return) {
 			CB_FIELD_PTR (current_program->cb_sort_return)->count++;
-			cb_emit (CB_BUILD_FUNCALL_5 ("cob_file_sort_init", rtree,
-						     cb_int ((int)cb_list_length (keys)), col,
-						     CB_BUILD_CAST_ADDRESS (current_program->cb_sort_return),
-						     CB_FILE(rtree)->file_status));
+			sort_return = CB_BUILD_CAST_ADDRESS (current_program->cb_sort_return);
 		} else {
-			cb_emit (CB_BUILD_FUNCALL_5 ("cob_file_sort_init", rtree,
-						     cb_int ((int)cb_list_length (keys)), col,
-						     cb_null, CB_FILE(rtree)->file_status));
-
+			sort_return = cb_null;
+		}
+		cb_emit (CB_BUILD_FUNCALL_5 ("cob_file_sort_init", rtree,
+						    cb_int ((int)cb_list_length (keys)), col,
+						    sort_return, sd_file->file_status));
+		if (current_statement->statement == STMT_MERGE) {
+			/* note: this  function can be used later to set more options */
+			cb_emit (CB_BUILD_FUNCALL_2 ("cob_file_sort_options", rtree,
+				cb_build_string (cobc_parse_strdup ("M"), 1)));
 		}
 		/* TODO: pass key-specific collation to libcob */
 		for (l = keys; l; l = CB_CHAIN (l)) {
+			cb_tree fref = CB_VALUE (l);
 			cb_emit (CB_BUILD_FUNCALL_4 ("cob_file_sort_init_key",
 						     rtree,
-						     CB_VALUE (l),
+						     fref,
 						     CB_PURPOSE (l),
-						     cb_int (CB_FIELD_PTR (CB_VALUE(l))->offset)));
+						     cb_int (CB_FIELD_PTR (fref)->offset)));
 		}
 	} else {
 		cb_emit (CB_BUILD_FUNCALL_2 ("cob_table_sort_init",
@@ -12806,60 +12808,67 @@ cb_emit_sort_using (cb_tree file, cb_tree l)
 	}
 	/* LCOV_EXCL_STOP */
 	for (; l; l = CB_CHAIN (l)) {
-		if (CB_FILE (cb_ref(CB_VALUE(l)))->organization == COB_ORG_SORT) {
+		cb_tree use_ref = cb_ref (CB_VALUE (l));
+		const struct cb_file *use_file = CB_FILE (use_ref);
+		if (use_file->organization == COB_ORG_SORT) {
 			cb_error_x (CB_TREE (current_statement),
-				    _("invalid SORT USING parameter"));
+				    _("invalid %s parameter"),
+					current_statement->statement == STMT_MERGE ?
+					"MERGE USING" : "SORT USING");
 		}
 		cb_emit (CB_BUILD_FUNCALL_2 ("cob_file_sort_using",
-			rtree, cb_ref (CB_VALUE (l))));
+			rtree, use_ref));
 	}
 }
 
 void
 cb_emit_sort_input (cb_tree proc)
 {
-	if (current_program->flag_debugging &&
-	    !current_statement->flag_in_debug) {
+	if (current_program->flag_debugging
+	 && !current_statement->flag_in_debug) {
 		cb_emit (cb_build_debug (cb_debug_contents, "SORT INPUT", NULL));
 	}
 	cb_emit (cb_build_perform_once (proc));
 }
 
 void
-cb_emit_sort_giving (cb_tree file, cb_tree l)
+cb_emit_sort_giving (cb_tree sd_file, cb_tree l)
 {
 	cb_tree		p;
-	int		listlen;
 
 	if (cb_validate_list (l)) {
 		return;
 	}
 	for (p = l; p; p = CB_CHAIN (p)) {
-		if (CB_FILE (cb_ref(CB_VALUE(p)))->organization == COB_ORG_SORT) {
+		/* TODO: let parser create a list of files, not their references */
+		const struct cb_file *giving_file = CB_FILE (cb_ref (CB_VALUE (p)));
+		if (giving_file->organization == COB_ORG_SORT) {
 			cb_error_x (CB_TREE (current_statement),
-				    _("invalid SORT GIVING parameter"));
+				    _("invalid %s parameter"),
+					current_statement->statement == STMT_MERGE ?
+					"MERGE GIVING" : "SORT GIVING");
+
 		}
 	}
-	p = cb_ref (file);
+	p = cb_ref (sd_file);
 	/* LCOV_EXCL_START */
 	if (p == cb_error_node) {
 		cobc_err_msg (_("call to '%s' with invalid parameter '%s'"),
-			"cb_emit_sort_giving", "file");
+			"cb_emit_sort_giving", "sd_file");
 		COBC_ABORT ();
 	}
 	/* LCOV_EXCL_STOP */
-	listlen = cb_list_length (l);
 	p = CB_BUILD_FUNCALL_2 ("cob_file_sort_giving", p, l);
-	CB_FUNCALL(p)->varcnt = listlen;
+	CB_FUNCALL(p)->varcnt = cb_list_length (l);
 	cb_emit (p);
 }
 
 void
 cb_emit_sort_output (cb_tree proc)
 {
-	if (current_program->flag_debugging &&
-	    !current_statement->flag_in_debug) {
-		if (current_statement->flag_merge) {
+	if (current_program->flag_debugging
+	 && !current_statement->flag_in_debug) {
+		if (current_statement->statement == STMT_MERGE) {
 			cb_emit (cb_build_debug (cb_debug_contents,
 						 "MERGE OUTPUT", NULL));
 		} else {