Merge remote-tracking branch 'upstream/gnucobol-3.x' into gcos4gnucob…

…ol-3.x

NEWS

@@ -10,6 +10,9 @@ NEWS - user visible changes				-*- outline -*-
    the error output for format errors (for example invalid indicator column)
    is now limitted to 5 per source file
 
+** support the COLLATING SEQUENCE clause on indexed files
+   (currently only with the BDB backend)
+
   more work in progress
 
 * Important Bugfixes
@@ -41,6 +44,9 @@ NEWS - user visible changes				-*- outline -*-
    build system do not correctly work together to locate files from
    diagnostic output
 
+** New option -fdefault-file-colseq to specify the default
+   file collating sequence
+
 * More notable changes
 
 ** execution times were significantly reduced for the following:

cobc/ChangeLog

@@ -1,4 +1,17 @@
 
+2024-01-25  David Declerck <[email protected]>
+
+	FR #459: support COLLATING SEQUENCE clause on SELECT / INDEXED files
+	* codegen.c (output_file_initialization): output the indexed
+	  file/keys collating sequence (were already present in the AST)
+	* tree.c (validate_indexed_key_field): process postponed
+	  key collating sequences
+	* parser.y (collating_sequence_clause, collating_sequence_clause_key):
+	  replace CB_PENDING by CB_UNFINISHED on file and key collating sequence
+	* flag.def, tree.c, tree.h, cobc.c, parser.y: add and handle a new
+	  -fdefault-file-colseq flag to specify the default collating
+	  sequence to use for files without a collating sequence clause
+
 2023-10-12  Fabrice Le Fessant <[email protected]>
 
 	* cobc.c, codegen.c: new option --include FILE, to #include

cobc/cobc.c

@@ -90,24 +90,25 @@ enum compile_level {
 	CB_LEVEL_EXECUTABLE	= 7
 };
 
-#define	CB_FLAG_GETOPT_STACK_SIZE       1
-#define	CB_FLAG_GETOPT_IF_CUTOFF        2
-#define	CB_FLAG_GETOPT_SIGN             3
-#define	CB_FLAG_GETOPT_FOLD_COPY        4
-#define	CB_FLAG_GETOPT_FOLD_CALL        5
-#define	CB_FLAG_GETOPT_TTITLE           6
-#define	CB_FLAG_GETOPT_MAX_ERRORS       7
-#define	CB_FLAG_GETOPT_DUMP             8
-#define	CB_FLAG_GETOPT_CALLFH           9
-#define	CB_FLAG_GETOPT_INTRINSICS      10
-#define	CB_FLAG_GETOPT_EC              11
-#define	CB_FLAG_GETOPT_NO_EC           12
-#define	CB_FLAG_GETOPT_NO_DUMP         13
-#define	CB_FLAG_GETOPT_EBCDIC_TABLE    14
-#define	CB_FLAG_GETOPT_DEFAULT_COLSEQ  15
-#define	CB_FLAG_GETOPT_MEMORY_CHECK    16
-#define	CB_FLAG_GETOPT_COPY_FILE       17
-#define	CB_FLAG_GETOPT_INCLUDE_FILE    18
+#define	CB_FLAG_GETOPT_STACK_SIZE            1
+#define	CB_FLAG_GETOPT_IF_CUTOFF             2
+#define	CB_FLAG_GETOPT_SIGN                  3
+#define	CB_FLAG_GETOPT_FOLD_COPY             4
+#define	CB_FLAG_GETOPT_FOLD_CALL             5
+#define	CB_FLAG_GETOPT_TTITLE                6
+#define	CB_FLAG_GETOPT_MAX_ERRORS            7
+#define	CB_FLAG_GETOPT_DUMP                  8
+#define	CB_FLAG_GETOPT_CALLFH                9
+#define	CB_FLAG_GETOPT_INTRINSICS           10
+#define	CB_FLAG_GETOPT_EC                   11
+#define	CB_FLAG_GETOPT_NO_EC                12
+#define	CB_FLAG_GETOPT_NO_DUMP              13
+#define	CB_FLAG_GETOPT_EBCDIC_TABLE         14
+#define	CB_FLAG_GETOPT_DEFAULT_COLSEQ       15
+#define	CB_FLAG_GETOPT_DEFAULT_FILE_COLSEQ  16
+#define	CB_FLAG_GETOPT_MEMORY_CHECK         17
+#define	CB_FLAG_GETOPT_COPY_FILE            18
+#define	CB_FLAG_GETOPT_INCLUDE_FILE         19
 
 
 /* Info display limits */
@@ -3819,6 +3820,13 @@ process_command_line (const int argc, char **argv)
 			}
 			break;
 
+		case CB_FLAG_GETOPT_DEFAULT_FILE_COLSEQ: /* 16 */
+			/* -fdefault-file-colseq=<ASCII/EBCDIC/NATIVE> */
+			if (cb_deciph_default_file_colseq_name (cob_optarg)) {
+				cobc_err_exit (COBC_INV_PAR, "-fdefault-file-colseq");
+			}
+			break;
+
 		case CB_FLAG_GETOPT_FOLD_COPY: /* 4 */
 			/* -ffold-copy=<UPPER/LOWER> : COPY fold case */
 			if (!cb_strcasecmp (cob_optarg, "UPPER")) {
@@ -3898,7 +3906,7 @@ process_command_line (const int argc, char **argv)
 			}
 			break;
 
-		case CB_FLAG_GETOPT_MEMORY_CHECK: /* 16 */
+		case CB_FLAG_GETOPT_MEMORY_CHECK: /* 17 */
 			/* -fmemory-check=<scope> :  */
 			if (!cob_optarg) {
 				cb_flag_memory_check = CB_MEMCHK_ALL;
@@ -3907,7 +3915,7 @@ process_command_line (const int argc, char **argv)
 			}
 			break;
 
-		case CB_FLAG_GETOPT_COPY_FILE: /* 17 */
+		case CB_FLAG_GETOPT_COPY_FILE: /* 18 */
 			/* --copy=<file> : COPY file at beginning */
 			if (strlen (cob_optarg) > (COB_MINI_MAX)) {
 				cobc_err_exit (COBC_INV_PAR, "--copy");
@@ -3916,7 +3924,7 @@ process_command_line (const int argc, char **argv)
 					  cobc_strdup (cob_optarg));
 			break;
 
-		case CB_FLAG_GETOPT_INCLUDE_FILE: /* 18 */
+		case CB_FLAG_GETOPT_INCLUDE_FILE: /* 19 */
 			/* -include=<file.h> : add #include "file.h" to 
 			   generated C file */
 			if (strlen (cob_optarg) > (COB_MINI_MAX)) {

cobc/codegen.c

@@ -9271,6 +9271,39 @@ output_key_components (struct cb_file* f, struct cb_key_component* key_component
 	}
 }
 
+
+static void
+output_indexed_file_key_colseq (const struct cb_file *f, const struct cb_alt_key *ak, int idx)
+{
+	const cb_tree	key = ak ? ak->key : f->key;
+	const cb_tree	key_col = ak ? ak->collating_sequence_key : f->collating_sequence_key;
+	const int	type = cb_tree_type (key, cb_code_field (key));
+	cb_tree		col = NULL;
+
+	/* We only apply a collating sequence if the key is alphanumeric / display */
+	if ((type & COB_TYPE_ALNUM) || (type == COB_TYPE_NUMERIC_DISPLAY)) {
+		col = key_col ? key_col : f->collating_sequence;
+#if 0	/* TODO: this should be done for national, when available */
+	} else if (type & COB_TYPE_NATIONAL) {
+		col = key_col_n ? key_col_n : f->collating_sequence_n;
+#endif
+	}
+
+	output_prefix ();
+	if (idx == 0) {
+		output ("%s%s->collating_sequence = ", CB_PREFIX_KEYS, f->cname);
+	} else {
+		output ("(%s%s + %d)->collating_sequence = ", CB_PREFIX_KEYS, f->cname, idx);
+	}
+	if (col != NULL && CB_REFERENCE_P (col)) {
+		output_param (cb_ref(col), -1);
+		output (";");
+	} else {
+		output ("NULL;");
+	}
+	output_newline ();
+}
+
 static void
 output_file_initialization (struct cb_file *f)
 {
@@ -9331,6 +9364,9 @@ output_file_initialization (struct cb_file *f)
 		} else {
 			output_line ("%s%s->offset = 0;", CB_PREFIX_KEYS, f->cname);
 		}
+		if (f->organization == COB_ORG_INDEXED) {
+			output_indexed_file_key_colseq (f, NULL, 0);
+		}
 		nkeys = 1;
 		for (l = f->alt_key_list; l; l = l->next) {
 			output_prefix ();
@@ -9353,6 +9389,9 @@ output_file_initialization (struct cb_file *f)
 					f->cname, nkeys);
 				output_key_components (f, l->component_list, nkeys);
 			}
+			if (f->organization == COB_ORG_INDEXED) {
+				output_indexed_file_key_colseq (f, l, nkeys);
+			}
 			nkeys++;
 		}
 #if 0 /* now done in cob_file_malloc / cob_file_external_addr */

cobc/flag.def

@@ -103,6 +103,10 @@ CB_FLAG_NQ (1, "default-colseq", CB_FLAG_GETOPT_DEFAULT_COLSEQ,
 	_("  -fdefault-colseq=[ASCII|EBCDIC|NATIVE]\tdefine default collating sequence\n"
 	  "                        * default: NATIVE"))
 
+CB_FLAG_NQ (1, "default-file-colseq", CB_FLAG_GETOPT_DEFAULT_FILE_COLSEQ,
+	_("  -fdefault-file-colseq=[ASCII|EBCDIC|NATIVE]\tdefine default file collating sequence\n"
+	  "                        * default: NATIVE"))
+
 /* Binary flags */
 
 /* Flags with suppressed help */

cobc/parser.y

@@ -336,29 +336,6 @@ check_non_area_a (cb_tree stmt) {
 
 /* Collating sequences */
 
-/* Known collating sequences/alphabets */
-enum cb_colseq {
-	CB_COLSEQ_NATIVE,
-	CB_COLSEQ_ASCII,
-	CB_COLSEQ_EBCDIC,
-};
-enum cb_colseq cb_default_colseq = CB_COLSEQ_NATIVE;
-
-/* Decipher character conversion table names */
-int cb_deciph_default_colseq_name (const char * const name)
-{
-	if (!cb_strcasecmp (name, "ASCII")) {
-		cb_default_colseq = CB_COLSEQ_ASCII;
-	} else if (!cb_strcasecmp (name, "EBCDIC")) {
-		cb_default_colseq = CB_COLSEQ_EBCDIC;
-	} else if (!cb_strcasecmp (name, "NATIVE")) {
-		cb_default_colseq = CB_COLSEQ_NATIVE;
-	} else {
-		return 1;
-	}
-	return 0;
-}
-
 static cb_tree
 build_colseq_tree (const char *alphabet_name,
 		      int alphabet_type,
@@ -901,23 +878,34 @@ check_relaxed_syntax (const cob_flags_t lev)
 }
 
 static void
-setup_default_collation (struct cb_program *program) {
-	switch (cb_default_colseq) {
+prepare_default_collation (enum cb_colseq colseq) {
+	switch (colseq) {
 #ifdef COB_EBCDIC_MACHINE
 	case CB_COLSEQ_ASCII:
 #else
 	case CB_COLSEQ_EBCDIC:
 #endif
-		alphanumeric_collation = build_colseq (cb_default_colseq);
+		alphanumeric_collation = build_colseq (colseq);
 		break;
 	default:
 		alphanumeric_collation = NULL;
 	}
 	national_collation = NULL; /* TODO: default national collation */
+}
+
+static void
+setup_default_collation (struct cb_program *program) {
+	prepare_default_collation (cb_default_colseq);
 	program->collating_sequence = alphanumeric_collation;
 	program->collating_sequence_n = national_collation;
 }
 
+static void
+setup_default_file_collation (struct cb_file *file) {
+	prepare_default_collation (cb_default_file_colseq);
+	file->collating_sequence = alphanumeric_collation;
+}
+
 static void
 program_init_without_program_id (void)
 {
@@ -5365,6 +5353,7 @@ file_control_entry:
 
 	}
 	key_type = NO_KEY;
+        setup_default_file_collation (current_file);
   }
   _select_clauses_or_error
   {
@@ -5752,7 +5741,7 @@ collating_sequence_clause:
 	check_repeated ("COLLATING", SYN_CLAUSE_3, &check_duplicate);
 	current_file->collating_sequence = alphanumeric_collation;
 	current_file->collating_sequence_n = national_collation;
-	CB_PENDING ("FILE COLLATING SEQUENCE");
+	CB_UNFINISHED ("FILE COLLATING SEQUENCE"); /* only implemented for BDB */
   }
 ;
 
@@ -5804,7 +5793,7 @@ collating_sequence_clause_key:
 	   and also attached to the correct key later, so just store in a list here: */
 	current_file->collating_sequence_keys =
 		cb_list_add(current_file->collating_sequence_keys, CB_BUILD_PAIR ($6, $4));
-	CB_PENDING ("KEY COLLATING SEQUENCE");
+	CB_UNFINISHED ("KEY COLLATING SEQUENCE"); /* only implemented for BDB */
   }
 ;
 

cobc/tree.c

@@ -4661,9 +4661,12 @@ validate_file (struct cb_file *f, cb_tree name)
 
 static void
 validate_indexed_key_field (struct cb_file *f, struct cb_field *records,
-					cb_tree key, struct cb_key_component *component_list)
+					cb_tree key, struct cb_key_component *component_list,
+					struct cb_alt_key *cbak)
 {
 	cb_tree			key_ref;
+	cb_tree			l;
+
 	struct cb_field		*k;
 	struct cb_field		*p;
 	struct cb_field		*v;
@@ -4730,6 +4733,18 @@ validate_indexed_key_field (struct cb_file *f, struct cb_field *records,
 						  " needs to be at least %d"), f->record_min, k->name, field_end);
 		}
 	}
+
+	/* get key collating sequence, if any */
+	for (l = f->collating_sequence_keys; l; l = CB_CHAIN (l)) {
+		cb_tree alpha_key = CB_VALUE (l);
+		if (key_ref == cb_ref (CB_PAIR_Y (alpha_key))) {
+			if (cbak == NULL) {
+				f->collating_sequence_key = CB_PAIR_X (alpha_key);
+			} else {
+				cbak->collating_sequence_key = CB_PAIR_X (alpha_key);
+			}
+		}
+	}
 }
 
 void
@@ -4771,7 +4786,7 @@ finalize_file (struct cb_file *f, struct cb_field *records)
 		struct cb_alt_key	*cbak;
 		if (f->key) {
 			validate_indexed_key_field (f, records,
-				f->key, f->component_list);
+				f->key, f->component_list, NULL);
 		}
 		for (cbak = f->alt_key_list; cbak; cbak = cbak->next) {
 			if (f->flag_global) {
@@ -4781,7 +4796,7 @@ finalize_file (struct cb_file *f, struct cb_field *records)
 				}
 			}
 			validate_indexed_key_field (f, records,
-				cbak->key, cbak->component_list);
+				cbak->key, cbak->component_list, cbak);
 		}
 	}
 
@@ -7414,6 +7429,38 @@ cb_build_ml_suppress_checks (struct cb_ml_generate_tree *tree)
 }
 
 
+enum cb_colseq cb_default_colseq = CB_COLSEQ_NATIVE;
+enum cb_colseq cb_default_file_colseq = CB_COLSEQ_NATIVE;
+
+/* Decipher character conversion table names */
+static int
+cb_deciph_colseq_name (const char * const name, enum cb_colseq *colseq)
+{
+	if (!cb_strcasecmp (name, "ASCII")) {
+		*colseq = CB_COLSEQ_ASCII;
+	} else if (!cb_strcasecmp (name, "EBCDIC")) {
+		*colseq = CB_COLSEQ_EBCDIC;
+	} else if (!cb_strcasecmp (name, "NATIVE")) {
+		*colseq = CB_COLSEQ_NATIVE;
+	} else {
+		return 1;
+	}
+	return 0;
+}
+
+int
+cb_deciph_default_colseq_name (const char * const name)
+{
+	return cb_deciph_colseq_name (name, &cb_default_colseq);
+}
+
+int
+cb_deciph_default_file_colseq_name (const char * const name)
+{
+	return cb_deciph_colseq_name (name, &cb_default_file_colseq);
+}
+
+
 #ifndef	HAVE_DESIGNATED_INITS
 void
 cobc_init_tree (void)