WIP - a branch with multiple commits for MF-AIX

cobc/ChangeLog

@@ -1,4 +1,9 @@
 
+2025-11-25  Nicolas Berthier <nicolas.berthier@ocamlpro.com>
+
+	* ppparse.y: error on extraneous periods at the end of SET
+	  directives; turn to a warning in relaxed syntax mode.
+
 2025-11-01  Simon Sobisch <simonsobisch@gnu.org>
 
 	* codegen.c (output_xml_parse): fixed xml state to be static-local

cobc/config.def

@@ -117,6 +117,9 @@ CB_CONFIG_BOOLEAN (cb_complex_odo, "complex-odo",
 CB_CONFIG_BOOLEAN (cb_odoslide, "odoslide",
 	_("adjust items following OCCURS DEPENDING (implies complex-odo)"))
 
+CB_CONFIG_BOOLEAN (cb_odo_redefines, "odo-in-redefines",
+	_("allow ODO in REDEFINES fields"))
+
 CB_CONFIG_BOOLEAN (cb_initial_justify, "init-justify",
 	_("applies JUSTIFY with VALUE clause"))
 

cobc/field.c

@@ -1417,14 +1417,22 @@ validate_redefines (const struct cb_field * const f)
 	}
 
 	/* Check variable occurrence */
-	if (f->depending
-	 || (!f->flag_picture_l && cb_field_variable_size (f))) {
-		cb_error_x (x, _("'%s' cannot be variable length"), f->name);
+	if (cb_odo_redefines) {
+		if (cb_field_variable_size(f->redefines) || f->depending) {
+			return;
+		}
 	}
+
 	if (!f->redefines->flag_picture_l && cb_field_variable_size (f->redefines)) {
 		cb_error_x (x, _("the original definition '%s' cannot be variable length"),
 			    f->redefines->name);
 	}
+
+	if (f->depending
+		|| (!f->flag_picture_l && cb_field_variable_size (f))) {
+		cb_error_x (x, _("'%s' cannot be variable length"), f->name);
+	}
+
 }
 
 /* Perform group-specific validation of f. */

cobc/parser.y

@@ -7053,8 +7053,7 @@ working_storage: WORKING_STORAGE { check_area_a_of ("WORKING-STORAGE SECTION");
 
 _working_storage_section:
   /* empty */
-| working_storage SECTION
-  dot_or_else_end_of_record_description
+| working_storage SECTION _dot
   {
 	check_headers_present (COBC_HD_DATA_DIVISION, 0, 0, 0);
 	header_check |= COBC_HD_WORKING_STORAGE_SECTION;
@@ -7088,7 +7087,7 @@ _record_description_list:
 
 record_description_list:
   data_description dot_or_else_end_of_record_description
-| record_description_list data_description dot_or_else_end_of_record_description
+| record_description_list _extra_dot data_description dot_or_else_end_of_record_description
 ;
 
 data_description:
@@ -20408,6 +20407,15 @@ _dot:
   }
 ;
 
+_extra_dot:
+|  TOK_DOT
+ {
+	if (!cb_verify (cb_missing_period, _("extra period"))) {
+		YYERROR;
+	}
+ }
+;
+
 dot_or_else_end_of_file_control:
   TOK_DOT
 | file_control_end_delimiter
@@ -20419,18 +20427,8 @@ dot_or_else_end_of_file_control:
   }
 ;
 
-level_number_in_area_a:
-  LEVEL_NUMBER_IN_AREA_A
-  {
-	/* No need to raise the error for *_IN_AREA_A tokens */
-	(void) cb_verify (cb_missing_period, _("optional period"));
-	cobc_repeat_last_token = 1;
-  }
-;
-
 dot_or_else_end_of_file_description:
   TOK_DOT
-| level_number_in_area_a	/* repeats last token */
 | file_description_end_delimiter
   {
 	if (!cb_verify (cb_missing_period, _("optional period"))) {
@@ -20451,7 +20449,6 @@ dot_or_else_end_of_record_description;
 
 dot_or_else_end_of_record_description:
   TOK_DOT
-| level_number_in_area_a	/* repeats last token */
 | record_description_end_delimiter
   {
 	if (!cb_verify (cb_missing_period, _("optional period"))) {
@@ -20462,13 +20459,13 @@ dot_or_else_end_of_record_description:
 ;
 
 file_control_end_delimiter:
-  SELECT | I_O_CONTROL | DATA | PROCEDURE;
+  SELECT | I_O_CONTROL | DATA | PROCEDURE | LEVEL_NUMBER | LEVEL_NUMBER_IN_AREA_A;
 
 file_description_end_delimiter:
-  TOK_FILE | PROCEDURE;
+  TOK_FILE | PROCEDURE | FD;
 
 record_description_end_delimiter:
-  PROCEDURE | COMMUNICATION | LOCAL_STORAGE | LINKAGE | REPORT | SCREEN;
+  PROCEDURE | COMMUNICATION | LOCAL_STORAGE | LINKAGE | REPORT | SCREEN | LEVEL_NUMBER_IN_AREA_A | LEVEL_NUMBER ;
 
 _dot_or_else_area_a:		/* in PROCEDURE DIVISION */
   TOK_DOT

cobc/ppparse.y

@@ -894,8 +894,8 @@ if_directive_elif:
 ;
 
 set_directive:
-  set_choice
-| set_directive set_choice
+  set_choice _unexpected_dot
+| set_directive set_choice _unexpected_dot
 ;
 
 /* FIXME: *all* of the choices below should be #PASSED to the scanner
@@ -1377,6 +1377,13 @@ _dot:
 | DOT
 ;
 
+_unexpected_dot:
+| DOT
+  {
+    cb_syntax_check (_("unexpected period"));
+  }
+;
+
 leap_second_directive:
 /* empty (OFF implied) */
 | ON

cobc/scanner.l

@@ -107,12 +107,24 @@
 #define YYSTYPE			cb_tree
 #define _PARSER_H	/* work around bad Windows SDK header */
 #include "parser.h"
+#include "eprintf_token.def"
+
+//#define MUST_PRINT_TOKENS
+#ifdef MUST_PRINT_TOKENS
+#define PRINT_TOK(expr) \
+		fprintf(stderr, "%s:%d:token ", cb_source_file, cb_source_line); \
+		eprintf_token(expr);				\
+		fprintf(stderr, " for '%s'\n", yytext)
+#else
+#define PRINT_TOK(expr)
+#endif
 
 #define RETURN_TOK(expr)			\
 	do {					\
 		last_yylval = yylval;		\
 		second_last_token = last_token;		\
 		last_token = (expr);		\
+		PRINT_TOK(last_token);		\
 		return last_token;		\
 	} ONCE_COB
 
@@ -509,7 +521,9 @@ H#[0-9A-Za-z]+ {
 }
 
 [0-9][0-9]? {
-	int	value;
+        int	value;
+	int return_token1;
+	int return_token2;
 
 	/* We treat integer literals immediately after '.' as labels;
 	   that is, they must be level numbers or section names. */
@@ -520,28 +534,30 @@ H#[0-9A-Za-z]+ {
 			value = atoi (yytext);
 			if (value == 66) {
 				/* level number 66 */
-				RETURN_TOK (SIXTY_SIX);
+				return_token1 = SIXTY_SIX; goto return_token1;
 			} else if (value == 78) {
 				/* level number 78 */
-				RETURN_TOK (SEVENTY_EIGHT);
+				return_token1 = SEVENTY_EIGHT; goto return_token1;
 			} else if (value == 88) {
 				/* level number 88 */
-				RETURN_TOK (EIGHTY_EIGHT);
+				return_token1 = EIGHTY_EIGHT; goto return_token1;
 			} else if ((value >= 1 && value <= 49) || value == 77) {
 				/* level number (1 through 49, 77) */
 				if (cobc_in_area_a) {
-					RETURN_TOK (LEVEL_NUMBER_IN_AREA_A);
+					return_token1 = LEVEL_NUMBER_IN_AREA_A;
+					goto return_token1 ;
 				} else {
-					RETURN_TOK (LEVEL_NUMBER);
+					return_token1 = LEVEL_NUMBER;
+					goto return_token1 ;
 				}
 			}
 		}
 
 		/* Integer label */
 		if (cobc_in_area_a) {
-			RETURN_TOK (WORD_IN_AREA_A);
+			return_token1 = WORD_IN_AREA_A; goto return_token1;
 		} else {
-			RETURN_TOK (WORD);
+		  return_token1 = WORD; goto return_token1;
 		}
 	}
 	/* Numeric literal or referenced integer label
@@ -550,7 +566,125 @@ H#[0-9A-Za-z]+ {
 	   integer label to typeck.c (cb_build_section_name)
 	*/
 	yylval = cb_build_numeric_literal (0, yytext, 0);
-	RETURN_TOK (LITERAL);
+	return_token1 = LITERAL; goto return_token1;
+
+ return_token1:
+
+
+	/* We treat integer literals immediately after '.' as labels;
+	   that is, they must be level numbers or section names. */
+	if (last_token == TOK_DOT || cobc_in_area_a) {
+		yylval = cb_build_reference (yytext);
+
+		if (!cobc_in_procedure) {
+			value = atoi (yytext);
+			if (value == 66) {
+				/* level number 66 */
+				return_token2 = SIXTY_SIX; goto return_token2;
+			} else if (value == 78) {
+				/* level number 78 */
+				return_token2 = SEVENTY_EIGHT; goto return_token2;
+			} else if (value == 88) {
+				/* level number 88 */
+				return_token2 = EIGHTY_EIGHT; goto return_token2;
+			} else if ((value >= 1 && value <= 49) || value == 77) {
+				/* level number (1 through 49, 77) */
+				if (cobc_in_area_a) {
+					return_token2 = LEVEL_NUMBER_IN_AREA_A;
+					goto return_token2 ;
+				} else {
+					return_token2 = LEVEL_NUMBER;
+					goto return_token2 ;
+				}
+			}
+		}
+
+		/* Integer label */
+		if (cobc_in_area_a) {
+			return_token2 = WORD_IN_AREA_A; goto return_token2;
+		} else {
+		  return_token2 = WORD; goto return_token2;
+		}
+	}
+
+	if (!cobc_in_procedure) {
+		// fprintf(stderr, "not in procedure\n");
+		switch(last_token){
+		case TOK_OPEN_PAREN:
+		case BLOCK:
+		case CONTAINS:
+		case IS:
+		case OCCURS:
+		case TO:
+		case THRU:
+		case VALUE:
+		case VARYING:
+		{
+			// fprintf(stderr, "literal '%s' after token:", yytext);
+			// eprintf_token(last_token);
+			// fprintf(stderr, "\n");
+			yylval = cb_build_numeric_literal (0, yytext, 0);
+			return_token2 = LITERAL;
+			goto return_token2;
+		}
+		case LITERAL: {
+			switch (cb_tree_category (last_yylval)){
+			case CB_CATEGORY_NUMERIC: {
+				// fprintf(stderr, "literal after numeric LITERAL\n");
+				yylval = cb_build_numeric_literal (0, yytext, 0);
+				return_token2 = LITERAL;
+				goto return_token2;
+			}
+			default:
+			}
+		}
+		default:
+		}
+		// fprintf(stderr, "probably a level number\n");
+		yylval = cb_build_reference (yytext);
+		value = atoi (yytext);
+		if (value == 66) {
+			/* level number 66 */
+			return_token2 = SIXTY_SIX; goto return_token2;
+		} else if (value == 78) {
+			/* level number 78 */
+			return_token2 = SEVENTY_EIGHT; goto return_token2;
+		} else if (value == 88) {
+			/* level number 88 */
+			return_token2 = EIGHTY_EIGHT; goto return_token2;
+		} else if ((value >= 1 && value <= 49) || value == 77) {
+			/* level number (1 through 49, 77) */
+			if (cobc_in_area_a) {
+				return_token2 = LEVEL_NUMBER_IN_AREA_A;
+				goto return_token2 ;
+			} else {
+				return_token2 = LEVEL_NUMBER;
+				goto return_token2 ;
+			}
+		}
+		return_token2 = WORD; goto return_token2;
+	}
+	/* Numeric literal or referenced integer label
+	   remark: all transformations/checks are postponed:
+	   literals to tree.c,
+	   integer label to typeck.c (cb_build_section_name)
+	*/
+	yylval = cb_build_numeric_literal (0, yytext, 0);
+	return_token2 = LITERAL; goto return_token2;
+
+return_token2:
+
+	if (return_token1 != return_token2){
+		fprintf(stderr, "%s:%d: Number %s translated differently ",
+			cb_source_file, cb_source_line, yytext);
+		eprintf_token(return_token1);
+		fprintf(stderr, " vs ");
+		eprintf_token(return_token2);
+		fprintf(stderr, " (last token was ");
+		eprintf_token(last_token);
+		fprintf(stderr, " )\n");
+	}
+	RETURN_TOK(return_token2);
 }
 
 [0-9]+ {
@@ -1294,7 +1428,7 @@ H#[0-9A-Za-z]+ {
   "IS" {
 	/* Ignore */
   }
-  [^ \n;]+ {
+  ([^ \n;(]|"("[^)]+")")+ {
 	BEGIN INITIAL;
 	scan_picture (yytext);
 	RETURN_TOK (PICTURE);
@@ -2287,19 +2421,23 @@ static void
 scan_picture (const char *text)
 {
 	unsigned char			*p;
+	unsigned char			*dst;
 
 	/* Scan a PICTURE clause */
 	/* Normalize the input */
+	dst = (unsigned char*) text;
 	for (p = (unsigned char *)text; *p; p++) {
 		/* unput trailing '.' or ',' */
 		if (p[1] == 0 && (*p == '.' || *p == ',')) {
 			unput (*p);
-			*p = 0;
 			break;
 		}
-		*p = cb_toupper (*p);
+		/* remove spaces à la MF in pictures */
+		if (*p != ' '){
+			*dst++ = cb_toupper (*p);
+		}
 	}
-
+	*dst = 0;
 	yylval = CB_TREE (cb_build_picture (text));
 }
 

config/default.conf

@@ -85,6 +85,9 @@ complex-odo:			no
 # Adjust position of items following OCCURS DEPENDING
 odoslide:			no
 
+# Allow OCCURS DEPENDING ON in REDEFINES field
+odo-in-redefines:		no
+
 # Allow REDEFINES to other than last equal level number
 indirect-redefines:		no