Z 2023 02 11 medoc contest

NEWS

@@ -41,6 +41,8 @@ NEWS - user visible changes				-*- outline -*-
    * PICTURE strings with L character (variable length fields)
    * CONTROL DIVISION with SUBSTITUTION SECTION (full support) and DEFAULT
      SECTION (partial support)
+   * GCOS-specific handling of ASSIGN clause in SELECT, and ASSIGN
+     statement (support for ASSIGN TO MEMBER is partial)
 
 ** Multiple sequential files may be concatenated by specifying multiple
    files with a separator in its ASSIGN name (either directly or via

cobc/ChangeLog

@@ -126,6 +126,16 @@
 	* reserved.c (SEQUENCE): setting CB_CS_ALPHABET to allow code-name parsing
 	* parser.y, reserved.c: changed reference from 202x to 2023
 
+2023-01-05  Fabrice Le Fessant <[email protected]>
+
+	* cobc.c.c: add `cobc_plex_stradd` and `cobc_plex_strsub` allocation
+	  functions for the pplex phase.
+	* replace.c: new file containing the two-phase COPY-REPLACING and REPLACE
+	  mechanism, conforming to COBOL standard.
+	* pplex.l: remove former `pplex_echo` and `pplex_replace` code. The
+  	  `alt_space` parameter is not used anymore, leading to different listing
+	  code in some cases.
+
 2023-01-16  Simon Sobisch <[email protected]>
 
 	* parser.y (occurs_index): only set VALUE 1 for defaultbyte == INIT
@@ -538,6 +548,14 @@
 	* typeck.c (validate_occurs): change level 01/77 check back to plain
 	  dialect verification fixing #854
 
+2022-10-05  Nicolas Berthier <[email protected]>
+
+	* scanner.l, config.def: Add support for EBCDIC symbolic characters in
+	  alphanumeric literals, which is a GCOS-specific extension; add new
+	  configuration option ebcdic-symbolic-characters
+	* scanner.l, pplex.l: detect and issue a warning when EBCDIC
+	  symbolic character strings include extraneous separators
+
 2022-10-04  Nicolas Berthier <[email protected]>
 
 	* pplex.l, parser.y: fix AREACHECK in DEFAULT SECTION of CONTROL DIVISON
@@ -704,6 +722,27 @@
 	* field.c (has_std_needed_screen_clause), typeck.c (validate_alphabet),
 	  codegen.c (output_initialize_one): minor refactorings
 
+2022-08-02  David Declerck <[email protected]>
+
+	Support GCOS-specific SELECT
+	Support ASSIGN statements (GCOS extension)
+	* config.def: add options interpret-assign-literal, select-external,
+	  select-extra-organization-clauses, select-with
+	* tree.h, typeck.c (cb_build_interpreted_assignment_name,
+	  is_valid_assign_filename): new functions to support tokenization and
+	  parsing of interpreted literals in ASSIGN clause
+	* parser.y: add support for interpreted literals for ASSIGN clause in
+	  SELECT, SELECT EXTERNAL, WITH clause (syntax only), and extra
+	  organization clauses (syntax only)
+	* reserved.c, scanner.l: add reserved keywords for WITH and
+	  organization clauses
+	* codegen.c (output_file_initialization): record default file
+	  assignment
+	* config.def: add option assign-statement
+	* reserved.c: reserved MEMBER keyword
+	* typeck.c (cb_emit_assign_to_file, cb_emit_assign_to_member),
+	  tree.h, parser.y: support ASSIGN statements
+
 2022-08-20  Simon Sobisch <[email protected]>
 
 	* pplex.l: match and ignore editor folding $REGION statement
@@ -949,6 +988,11 @@
 		Initial table values, then clear next,
 		then propagate through remainder of the table
 
+2022-02-04  David Declerck <[email protected]>
+
+	* config.def, typeck.c: allow paragraph names to redefine field
+	  and section names; related to FR#260
+
 2022-05-31  Simon Sobisch <[email protected]>
 
 	* cobc.c (cobc_check_string): replaced single string cache by an array

cobc/Makefile.am

@@ -22,7 +22,8 @@
 bin_PROGRAMS = cobc
 cobc_SOURCES = cobc.c cobc.h ppparse.y pplex.c parser.y scanner.c config.c \
 	reserved.c error.c tree.c tree.h field.c typeck.c codegen.c help.c \
-	config.def flag.def warning.def codeoptim.def ppparse.def codeoptim.c
+	config.def flag.def warning.def codeoptim.def ppparse.def \
+	codeoptim.c replace.h replace.c 
 
 #cobc_SOURCES = cobc.c cobc.h ppparse.y pplex.l parser.y scanner.l config.c
 

cobc/cobc.c

@@ -985,8 +985,8 @@ cobc_strdup (const char *dupstr)
 	return p;
 }
 
-#if	defined (_WIN32) || defined (__CYGWIN__)
-static char *
+#if        defined (_WIN32) || defined (__CYGWIN__)
+char *
 cobc_stradd_dup (const char *str1, const char *str2)
 {
 	char	*p;
@@ -1315,6 +1315,59 @@ cobc_plex_strdup (const char *dupstr)
 	return p;
 }
 
+char *
+cobc_plex_stradd (const char *str1, const char *str2)
+{
+	char	*p;
+	size_t	m, n;
+
+	/* LCOV_EXCL_START */
+	if (unlikely (!str1 || !str2)) {
+		cobc_err_msg (_("call to %s with NULL pointer"),
+			      "cobc_plex_stradd");
+		cobc_abort_terminate (1);
+	}
+	/* LCOV_EXCL_STOP */
+	m = strlen (str1);
+	n = strlen (str2);
+	p = cobc_plex_malloc (m + n + 1);
+	memcpy (p, str1, m);
+	memcpy (p + m, str2, n);
+	return p;
+}
+
+void *
+cobc_plex_strsub (const char *s, const int len)
+{
+	void	*p;
+	int	n;
+
+#ifdef	COB_TREE_DEBUG
+	/* LCOV_EXCL_START */
+	if (unlikely (!s)) {
+		cobc_err_msg (_("call to %s with NULL pointer"),
+			      "cobc_plex_strsub");
+		cobc_abort_terminate (1);
+	}
+	/* LCOV_EXCL_STOP */
+#endif
+	n = strlen (s);
+
+#ifdef	COB_TREE_DEBUG
+	/* LCOV_EXCL_START */
+	if ( len>n ) {
+		cobc_err_msg (_("call to %s with bad argument len=%d>%d=strlen(s)"),
+			      "cobc_plex_strsub", len, n);
+		cobc_abort_terminate (1);
+	}
+	/* LCOV_EXCL_STOP */
+#endif
+
+	p = cobc_plex_malloc (len + 1);
+	memcpy (p, s, len);
+	return p;
+}
+
 /* variant of strcpy which copies max 'max_size' bytes from 'src' to 'dest',
    if the size of 'src' is too long only its last/last bytes are copied and an
    eliding "..." is placed in front or at end depending on 'elide_at_end' */
@@ -6011,6 +6064,7 @@ print_program_trailer (void)
 
 		/* Print file/symbol tables if requested */
 		if (cb_listing_symbols) {
+
 			if (cb_listing_with_header) {
 				set_listing_header_symbols ();
 			}

cobc/cobc.h

@@ -492,6 +492,8 @@ extern struct reserved_word_list	*cob_user_res_list;
 extern void			*cobc_malloc (const size_t);
 extern void			cobc_free (void *);
 extern void			*cobc_strdup (const char *);
+extern char                     *cobc_stradd_dup (const char *str1,
+						  const char *str2);
 extern void			*cobc_realloc (void *, const size_t);
 
 extern void			*cobc_main_malloc (const size_t);
@@ -506,6 +508,9 @@ extern void			cobc_parse_free (void *);
 
 extern void			*cobc_plex_malloc (const size_t);
 extern void			*cobc_plex_strdup (const char *);
+extern void			*cobc_plex_strsub (const char *, const int);
+extern char                     *cobc_plex_stradd (const char *str1,
+						  const char *str2);
 
 extern void			*cobc_check_string (const char *);
 extern void			cobc_err_msg (const char *, ...) COB_A_FORMAT12;

cobc/codegen.c

@@ -9135,6 +9135,16 @@ output_file_initialization (struct cb_file *f)
 	output_param (f->assign, -1);
 	output (";");
 	output_newline ();
+
+	output_prefix ();
+	output ("%s%s->assign_default = ", CB_PREFIX_FILE, f->cname);
+	if (f->assign_default) {
+		output ("\"%s\";", f->assign_default);
+	} else {
+		output ("NULL;");
+	}
+	output_newline ();
+
 	output_prefix ();
 	output ("%s%s->record = ", CB_PREFIX_FILE, f->cname);
 	output_param (CB_TREE (f->record), -1);
@@ -9682,6 +9692,21 @@ output_report_control (struct cb_report *p, int id, cb_tree ctl, cb_tree nx)
 	if(nx) {
 		output_report_control(p, id, nx, CB_CHAIN(nx));
 	}
+	bfound = 0;
+	for(i= p->num_lines-1; i >= 0; i--) {
+		if(p->line_ids[i]->report_control) {
+			struct cb_field *c = cb_code_field (p->line_ids[i]->report_control);
+			if(c == s) {
+				bfound = 1;
+				break;
+			}
+		}
+	}
+	if (!bfound) {
+		ctl = NULL;
+		p->controls = NULL;
+		return ;
+	}
 	output_local("/* Report %s: CONTROL %s */\n",p->name,s->name);
 	prvid = 0;
 	for(i = 0; i < p->num_lines; i++) {

cobc/config.def

@@ -183,6 +183,9 @@ CB_CONFIG_BOOLEAN (cb_move_nonnumlit_to_numeric_is_zero, "move-non-numeric-lit-t
 CB_CONFIG_BOOLEAN (cb_implicit_assign_dynamic_var, "implicit-assign-dynamic-var",
 	_("implicitly define a variable if an ASSIGN DYNAMIC does not match any data item"))
 
+CB_CONFIG_BOOLEAN (cb_interpret_assign_literal, "interpret-assign-literal",
+	_("interpret literal arguments to ASSIGN clause in SELECT"))
+
 CB_CONFIG_BOOLEAN (cb_device_mnemonics, "device-mnemonics",
 	_("specifying device by mnemonic"))
 
@@ -325,6 +328,9 @@ CB_CONFIG_SUPPORT (cb_hp_octal_literals, "hp-octal-literals",
 CB_CONFIG_SUPPORT (cb_acu_literals, "acu-literals",
 	_("ACUCOBOL-GT literals (#B #O #H #X)"))
 
+CB_CONFIG_BOOLEAN (cb_gcos_ebcdic_literals, "ebcdic-symbolic-characters",
+	_("EBCDIC symbolic characters in literals (\" \"135,151,151\"bar\"195, 194\"Z\" for \" foobarBAZ\")"))
+
 CB_CONFIG_SUPPORT (cb_word_continuation, "word-continuation",
 	_("continuation of COBOL words"))
 
@@ -407,6 +413,15 @@ CB_CONFIG_SUPPORT (cb_continue_after, "continue-after",
 CB_CONFIG_SUPPORT (cb_goto_entry, "goto-entry",
 	_("ENTRY FOR GO TO and GO TO ENTRY statements"))
 
+CB_CONFIG_SUPPORT (cb_select_external, "select-external",
+	_("SELECT EXTERNAL"))
+
+CB_CONFIG_SUPPORT (cb_select_extra_oganization_clauses, "select-extra-organization-clauses",
+	_("extra ORGANIZATION clauses in SELECT"))
+
+CB_CONFIG_SUPPORT (cb_select_with, "select-with",
+	_("WITH clause in SELECT"))
+
 CB_CONFIG_SUPPORT (cb_assign_variable, "assign-variable",
 	_("ASSIGN [TO] variable in SELECT"))
 
@@ -419,6 +434,9 @@ CB_CONFIG_SUPPORT (cb_assign_ext_dyn, "assign-ext-dyn",
 CB_CONFIG_SUPPORT (cb_assign_disk_from, "assign-disk-from",
 	_("ASSIGN DISK FROM variable in SELECT"))
 
+CB_CONFIG_SUPPORT (cb_assign_statement, "assign-statement",
+	_("ASSIGN statement"))
+
 CB_CONFIG_SUPPORT (cb_vsam_status, "vsam-status",
 	_("VSAM status in FILE STATUS"))
 
@@ -430,3 +448,7 @@ CB_CONFIG_SUPPORT (cb_record_contains_depending_clause, "record-contains-dependi
 
 CB_CONFIG_SUPPORT (cb_picture_l, "picture-l",
 	_("PICTURE string with 'L' character"))
+
+CB_CONFIG_SUPPORT (cb_non_unique_procedure_names, "non-unique-procedure-names",
+	_("allow paragraph names to redefine field and section names"))
+

cobc/error.c

@@ -63,6 +63,49 @@ print_error_prefix (const char *file, int line, const char *prefix)
 	}
 }
 
+static void
+print_error_context  (const char *file, int line)
+{
+	if ( cb_display_context && file != NULL && line ){
+		FILE* fd = fopen(file, "r");
+		char buffer[74];
+		int line_pos = 1;
+		int char_pos = 0;
+		int printed = 0; /* nothing printed */
+		while(1){
+			int c = fgetc (fd);
+			if ( c == EOF ){
+				if (printed) fprintf(stderr, "\n");
+				fclose(fd); return ; }
+			buffer[char_pos] = c ;
+			if( c == '\n' || char_pos == 73 ){
+				buffer[char_pos] = 0;
+				if (line_pos > line-3 && line_pos < line+3){
+					if (line_pos == line-2) fprintf(stderr, "\n");
+					printed = 1;
+					fprintf (stderr, "  %04d %c %s%s\n",
+						 line_pos,
+						 line == line_pos ? '>' : ' ',
+						 c == '\n' ? "" : ".." ,
+						 buffer);
+					if (line_pos == line+2){
+						fprintf(stderr, "\n");
+						fclose(fd); return;
+					}
+				} 
+				while ( c != '\n' ){ /* skip end of line too long */
+					c = fgetc (fd);
+					if( c == EOF ) { fclose(fd); return ; }
+				}
+				line_pos++;
+				char_pos=0;
+			} else {
+				char_pos++;
+			}
+		}
+	}
+}
+
 static void
 print_error (const char *file, int line, const char *prefix,
 	     const char *fmt, va_list ap, const char *diagnostic_option)
@@ -119,6 +162,7 @@ print_error (const char *file, int line, const char *prefix,
 		}
 		cb_add_error_to_listing (file, line, prefix, errmsg);
 	}
+	print_error_context (file, line);
 }
 
 static void
@@ -930,6 +974,24 @@ cb_verify (const enum cb_support tag, const char *feature)
 	return cb_verify_x (&loc, tag, feature);
 }
 
+/**
+ * tells whether the given compiler option is supported by the current std/configuration
+ * \return	1 = ok/warning/obsolete, 0 = skip/ignore/error/unconformable
+ */
+unsigned int
+cb_is_supported (const enum cb_support tag)
+{
+	switch (tag) {
+	case CB_OK:
+	case CB_WARNING:
+	case CB_ARCHAIC:
+	case CB_OBSOLETE:
+		return 1;
+	default:;
+	}
+	return 0;
+}
+
 enum cb_warn_val
 redefinition_error (cb_tree x)
 {

cobc/flag.def

@@ -235,3 +235,6 @@ CB_FLAG (cb_listing_cmd, 1, "tcmd",
 CB_FLAG_ON (cb_diagnostic_show_option, 1, "diagnostics-show-option",
 	_("  -fno-diagnostics-show-option\tsuppress output of option that directly\n"
 	  "                        controls the diagnostic"))
+
+CB_FLAG (cb_display_context, 1, "display-context",
+	_("  -fdisplay-context display source lines on warning/error"))