Merge SVN 4712

cobc/ChangeLog

@@ -227,6 +227,19 @@
 	  to clear_local_codegen_vars
 	* cobc.c: ask user for reporting reallocation memory issues
 
+2022-09-26  Nicolas Berthier <[email protected]>
+
+	* error.c (cb_syntax_check, cb_syntax_check_x): add variants of
+	  cb_{error,warning}[_x] functions with explicit va_list, and new helper
+	  functions to dispach to errors or warnings w.r.t
+	  cb_relaxed_syntax_checks
+	* scanner.l, parser.l: make Area A enforcement raise errors instead of
+	  warnings on strict dialects
+	* parser.y: add missing Area A check on SELECT and CD
+	* parser.y, typeck.c: simplify some uses of cb_relaxed_syntax_checks
+	* pplex.l: drop `>>(NO)AREACHECK` directives
+	* config.def: improve documentation for areacheck option
+
 2022-09-20  Simon Sobisch <[email protected]>
 
 	* parser.y (examine_format_variant): fix compiler warning

cobc/config.def

@@ -199,8 +199,12 @@ CB_CONFIG_BOOLEAN (cb_xml_parse_xmlss, "xml-parse-xmlss",
 	"XML PARSE XMLSS")
 
 CB_CONFIG_BOOLEAN (cb_areacheck, "areacheck",
-	_("check contents of Area A in PROCEDURE DIVISION "
-	  "(when reference format supports Area A enforcement)"))
+	_("check contents of Area A (when reference format supports Area A enforcement),\n"
+	  "                        enabled checks include:\n"
+	  "                        * division, section, paragraph names, level indicators (FD, SD, RD, and CD),\n"
+	  "                          and toplevel numbers (01 and 77) must start in Area A;\n"
+	  "                        * statements must not start in Area A; and\n"
+	  "                        * separator periods must not be within Area A."))
 
 /* Support flags */
 

cobc/error.c

@@ -189,7 +189,7 @@ cb_get_strerror (void)
 
 /* set the value for "ignore errors because instruction is
    in a constant FALSE path which gets no codegen at all"
-   if state is -1, don't set the value 
+   if state is -1, don't set the value
 
    returns the value which was active on call
 */
@@ -203,7 +203,7 @@ cb_set_ignore_error (int state)
 	return prev;
 }
 
-void 
+void
 cb_add_error_to_listing (const char *file, int line,
 		const char *prefix, char *errmsg)
 {
@@ -342,23 +342,20 @@ static char *warning_option_text (const enum cb_warn_opt opt, const enum cb_warn
 	return warning_option_buff;
 }
 
-enum cb_warn_val
-cb_warning (const enum cb_warn_opt opt, const char *fmt, ...)
+static enum cb_warn_val
+cb_warning_internal (const enum cb_warn_opt opt, const char *fmt, va_list ap)
 {
 	const enum cb_warn_val pref = cb_warn_opt_val[opt];
-	va_list ap;
 
 	if (pref == COBC_WARN_DISABLED) {
 		return pref;
 	}
 
-	va_start (ap, fmt);
 	if (pref != COBC_WARN_AS_ERROR) {
 		print_error (NULL, 0, _("warning: "),  fmt, ap, warning_option_text (opt, pref));
 	} else {
 		print_error (NULL, 0, _("error: "),  fmt, ap, warning_option_text (opt, pref));
 	}
-	va_end (ap);
 
 	if (sav_lst_file) {
 		return pref;
@@ -373,6 +370,17 @@ cb_warning (const enum cb_warn_opt opt, const char *fmt, ...)
 	return pref;
 }
 
+enum cb_warn_val
+cb_warning (const enum cb_warn_opt opt, const char *fmt, ...)
+{
+	enum cb_warn_val ret;
+	va_list ap;
+	va_start (ap, fmt);
+	ret = cb_warning_internal (opt, fmt, ap);
+	va_end (ap);
+	return ret;
+}
+
 void
 cb_error_always (const char *fmt, ...)
 {
@@ -392,21 +400,19 @@ cb_error_always (const char *fmt, ...)
 }
 
 /* raise error (or warning if current branch is not generated) */
-enum cb_warn_val
-cb_error (const char *fmt, ...)
+static enum cb_warn_val
+cb_error_internal (const char *fmt, va_list ap)
 {
 	const enum cb_warn_opt	opt = cb_warn_ignored_error;
 	const enum cb_warn_val	pref = cb_warn_opt_val[opt];
 	enum cb_warn_val	ret = pref;
-	va_list ap;
 
 	cobc_in_repository = 0;
 
 	if (ignore_error && pref == COBC_WARN_DISABLED) {
 		return pref;
 	}
 
-	va_start (ap, fmt);
 	if (!ignore_error) {
 		print_error (NULL, 0, _("error: "), fmt, ap, NULL);
 		ret = COBC_WARN_AS_ERROR;
@@ -415,7 +421,6 @@ cb_error (const char *fmt, ...)
 	} else {
 		print_error (NULL, 0, _("warning: "), fmt, ap, warning_option_text (opt, pref));
 	}
-	va_end (ap);
 
 	if (sav_lst_file) {
 		return ret;
@@ -430,6 +435,17 @@ cb_error (const char *fmt, ...)
 	return ret;
 }
 
+enum cb_warn_val
+cb_error (const char *fmt, ...)
+{
+	enum cb_warn_val ret;
+	va_list ap;
+	va_start (ap, fmt);
+	ret = cb_error_internal (fmt, ap);
+	va_end (ap);
+	return ret;
+}
+
 void
 cb_perror (const int config_error, const char *fmt, ...)
 {
@@ -611,21 +627,18 @@ configuration_error (const char *fname, const int line,
 }
 
 /* Generic warning/error routines */
-enum cb_warn_val
-cb_warning_x (const enum cb_warn_opt opt, cb_tree x, const char *fmt, ...)
+static enum cb_warn_val
+cb_warning_x_internal (const enum cb_warn_opt opt, cb_tree x, const char *fmt, va_list ap)
 {
-	va_list ap;
 	const enum cb_warn_val pref = cb_warn_opt_val[opt];
 
 	if (pref == COBC_WARN_DISABLED) {
 		return pref;
 	}
 
-	va_start (ap, fmt);
 	print_error (x->source_file, x->source_line,
 		pref == COBC_WARN_AS_ERROR ? _("error: ") : _("warning: "),
 		fmt, ap, warning_option_text (opt, pref));
-	va_end (ap);
 
 	if (sav_lst_file) {
 		return pref;
@@ -640,6 +653,17 @@ cb_warning_x (const enum cb_warn_opt opt, cb_tree x, const char *fmt, ...)
 	return pref;
 }
 
+enum cb_warn_val
+cb_warning_x (const enum cb_warn_opt opt, cb_tree x, const char *fmt, ...)
+{
+	enum cb_warn_val ret;
+	va_list ap;
+	va_start (ap, fmt);
+	ret = cb_warning_x_internal (opt, x, fmt, ap);
+	va_end (ap);
+	return ret;
+}
+
 /* raise a warning (or error, or nothing) depending on a dialect option */
 enum cb_warn_val
 cb_warning_dialect_x (const enum cb_support tag, cb_tree x, const char *fmt, ...)
@@ -748,10 +772,9 @@ cb_note (const enum cb_warn_opt opt, const int suppress_listing, const char *fmt
 	}
 }
 
-enum cb_warn_val
-cb_error_x (cb_tree x, const char *fmt, ...)
+static enum cb_warn_val
+cb_error_x_internal (cb_tree x, const char *fmt, va_list ap)
 {
-	va_list ap;
 	const enum cb_warn_opt	opt = cb_warn_ignored_error;
 	const enum cb_warn_val	pref = cb_warn_opt_val[opt];
 	enum cb_warn_val	ret = COBC_WARN_AS_ERROR;
@@ -760,7 +783,6 @@ cb_error_x (cb_tree x, const char *fmt, ...)
 		return COBC_WARN_DISABLED;
 	}
 
-	va_start (ap, fmt);
 	if (!ignore_error) {
 		print_error (x->source_file, x->source_line, _("error: "),
 			fmt, ap, NULL);
@@ -772,7 +794,6 @@ cb_error_x (cb_tree x, const char *fmt, ...)
 			fmt, ap, warning_option_text (opt, pref));
 		ret = COBC_WARN_ENABLED;
 	}
-	va_end (ap);
 
 	if (sav_lst_file) {
 		return ret;
@@ -787,6 +808,57 @@ cb_error_x (cb_tree x, const char *fmt, ...)
 	return ret;
 }
 
+enum cb_warn_val
+cb_error_x (cb_tree x, const char *fmt, ...)
+{
+	enum cb_warn_val ret;
+	va_list ap;
+	va_start (ap, fmt);
+	ret = cb_error_x_internal (x, fmt, ap);
+	va_end (ap);
+	return ret;
+}
+
+/**
+ * dispatches the given message as a warning if cb_relaxed_syntax_checks holds,
+ * as an error otherwise
+ *
+ * \return 1 if the message is dispatched to a non-ignored warning, 0 otherwise
+ */
+unsigned int
+cb_syntax_check (const char *fmt, ...)
+{
+	enum cb_warn_val ret;
+	va_list ap;
+	va_start (ap, fmt);
+	if (cb_relaxed_syntax_checks)
+		ret = cb_warning_internal (COBC_WARN_FILLER, fmt, ap);
+	else
+		ret = cb_error_internal (fmt, ap);
+	va_end (ap);
+	return cb_relaxed_syntax_checks ? ret != COBC_WARN_DISABLED : 0;
+}
+
+/**
+ * dispatches the given tree and message to cb_warning_x if
+ * cb_relaxed_syntax_checks holds, to cb_error_x otherwise
+ *
+ * \return 1 if the message is dispatched to a non-ignored warning, 0 otherwise
+ */
+unsigned int
+cb_syntax_check_x (cb_tree x, const char *fmt, ...)
+{
+	enum cb_warn_val ret;
+	va_list ap;
+	va_start (ap, fmt);
+	if (cb_relaxed_syntax_checks)
+		ret = cb_warning_x_internal (COBC_WARN_FILLER, x, fmt, ap);
+	else
+		ret = cb_error_x_internal (x, fmt, ap);
+	va_end (ap);
+	return cb_relaxed_syntax_checks ? ret != COBC_WARN_DISABLED : 0;
+}
+
 /**
  * verify if the given compiler option is supported by the current std/configuration
  * \param	x	tree whose position is used for raising warning/errors

cobc/field.c

@@ -830,18 +830,10 @@ copy_into_field_recursive (struct cb_field *source, struct cb_field *target,
 
 
 /* note: same message in parser.y */
-static int
+static void
 duplicate_clause_message (cb_tree x, const char *clause)
 {
-	/* FIXME: replace by a new warning level that is set
-	   to warn/error depending on cb_relaxed_syntax_checks */
-	if (cb_relaxed_syntax_checks) {
-		cb_warning_x (COBC_WARN_FILLER, x, _("duplicate %s clause"), clause);
-		return 0;
-	}
-
-	cb_error_x (x, _("duplicate %s clause"), clause);
-	return 1;
+	(void) cb_syntax_check_x (x, _("duplicate %s clause"), clause);
 }
 
 void