cobc:

* tree.h, typeck.c, parser.y, codegen.c: module-locale registers referenced as cb_field
* codegen.c: pass XML mode to module

config:
* ibm.words, acu.words, bs2000.words: enabled JSON + XML registers

libcob
* common.h: XML mode defines
* mlio.c: adjustments for register handling in XML parse stubs

cobc/ChangeLog

@@ -248,6 +248,12 @@
 	  only a single value
 	* parser.y (value_clause): improved parsing for table-format
 
+2022-11-18  Simon Sobisch <[email protected]>
+
+	* tree.h, typeck.c, parser.y, codegen.c: module-locale registers
+	  referenced as cb_field
+	* codegen.c: pass XML mode to module
+
 2022-11-18  Nicolas Berthier <[email protected]>
 
 	* cobc.c (print_line): fully honor -fmfcomment by suppressing lines

cobc/codegen.c

@@ -6947,11 +6947,19 @@ output_set_attribute (const struct cb_field *f, cob_flags_t val_on,
 static void
 output_xml_parse (struct cb_xml_parse *p)
 {
+	int flags = 0;
+	if (cb_xml_parse_xmlss) {
+		flags &= COB_XML_PARSE_XMLNSS;
+	}
+	if (p->returning_national && current_prog->xml_ntext) {
+		flags &= COB_XML_PARSE_NATIONAL;
+	}
+
 	output_block_open ();
 	output_line ("void *xml_state = NULL;");
 	output_prefix ();
 	output ("cob_set_int ("),
-	output_param (current_program->xml_code, 0);
+	output_param (CB_TREE (current_program->xml_code), 0);
 	output (", 0);");
 	output_newline ();
 
@@ -6967,7 +6975,7 @@ output_xml_parse (struct cb_xml_parse *p)
 	output_param (p->encoding, 1);
 	output (", ");
 	output_param (p->validating, 2);
-	output (", %d, &xml_state)) break;", p->returning_national);
+	output (", %d, &xml_state)) break;", flags);
 
 	/* COBOL callback function -> PROCESSING PROCEDURE */
 	/* note: automatic source reference */
@@ -10868,21 +10876,18 @@ static void
 output_module_register_init (cb_tree reg, const char *name)
 {
 	if (!reg) {
+		output_line ("module->%s = NULL;", name);
 		return;
 	}
 
 	if (CB_REFERENCE_P (reg)) {
 		reg = cb_ref (reg);
-		if (CB_FIELD_P (reg) && !CB_FIELD (reg)->count) {
-			return;
-		}
-	} else {
-		struct cb_field *field = CB_FIELD (reg);
-		if (!field->count) {
-			return;
-		}
-		reg = cb_build_field_reference (field, NULL);
 	}
+	if (CB_FIELD_P (reg) && !CB_FIELD (reg)->count) {
+		output_line ("module->%s = NULL;", name);
+		return;
+	}
+
 	output_prefix ();
 	output ("module->%s = ", name);
 	output_param (reg, -1);
@@ -11023,18 +11028,18 @@ output_module_init_non_static (struct cb_program *prog)
 	   of module local registers to cob_module structure */
 	output_module_register_init (prog->cursor_pos, "cursor_pos");
 
-	output_module_register_init (prog->xml_code, "xml_code");
-	output_module_register_init (prog->xml_event, "xml_event");
-	output_module_register_init (prog->xml_information, "xml_information");
-	output_module_register_init (prog->xml_namespace, "xml_namespace");
-	output_module_register_init (prog->xml_namespace_prefix, "xml_namespace_prefix");
-	output_module_register_init (prog->xml_nnamespace, "xml_nnamespace");
-	output_module_register_init (prog->xml_nnamespace_prefix, "xml_nnamespace_prefix");
-	output_module_register_init (prog->xml_ntext, "xml_ntext");
-	output_module_register_init (prog->xml_text, "xml_text");
-
-	output_module_register_init (prog->json_code, "json_code");
-	output_module_register_init (prog->json_status, "json_status");
+	output_module_register_init (CB_TREE (prog->xml_code), "xml_code");
+	output_module_register_init (CB_TREE (prog->xml_event), "xml_event");
+	output_module_register_init (CB_TREE (prog->xml_information), "xml_information");
+	output_module_register_init (CB_TREE (prog->xml_namespace), "xml_namespace");
+	output_module_register_init (CB_TREE (prog->xml_namespace_prefix), "xml_namespace_prefix");
+	output_module_register_init (CB_TREE (prog->xml_nnamespace), "xml_nnamespace");
+	output_module_register_init (CB_TREE (prog->xml_nnamespace_prefix), "xml_nnamespace_prefix");
+	output_module_register_init (CB_TREE (prog->xml_ntext), "xml_ntext");
+	output_module_register_init (CB_TREE (prog->xml_text), "xml_text");
+
+	output_module_register_init (CB_TREE (prog->json_code), "json_code");
+	output_module_register_init (CB_TREE (prog->json_status), "json_status");
 }
 
 static void

cobc/parser.y

@@ -1024,6 +1024,25 @@ check_conf_section_order (const cob_flags_t part)
 
 #undef MESSAGE_LEN
 
+/* check if a given register is available; if it is,
+   enforce code generation and add a
+   "receiving" entry for it when xref is requested */
+static void
+cb_set_register_receiving (struct cb_field *reg_field, int mandatory)
+{
+	if (!reg_field) {
+		if (mandatory) {
+			cb_error ("missing register definition");
+		}
+		return;
+	}
+	reg_field->count++;
+
+	if (cb_listing_xref) {
+		cobc_xref_set_receiving (CB_TREE (reg_field));
+	}
+}
+
 static enum cb_handler_type
 get_handler_type_from_statement (struct cb_statement *statement)
 {
@@ -14890,7 +14909,7 @@ json_generate_statement:
 	begin_statement (STMT_JSON_GENERATE, TERM_JSON);
 	cobc_in_json_generate_body = 1;
 	cobc_cs_check = CB_CS_JSON_GENERATE;
-	cobc_xref_set_receiving (current_program->json_code);
+	cb_set_register_receiving (current_program->json_code, 1);
   }
   json_generate_body
   _end_json
@@ -14950,8 +14969,8 @@ json_parse_statement:
   {
 	begin_statement (STMT_JSON_PARSE, TERM_JSON);
 	CB_PENDING ("JSON PARSE");
-	cobc_xref_set_receiving (current_program->json_code);
-	cobc_xref_set_receiving (current_program->json_status);
+	cb_set_register_receiving (current_program->json_code, 1);
+	cb_set_register_receiving (current_program->json_status, 1);
   }
   json_parse_body
   _end_json
@@ -17248,7 +17267,7 @@ xml_generate_statement:
 	begin_statement (STMT_XML_GENERATE, TERM_XML);
 	cobc_in_xml_generate_body = 1;
 	cobc_cs_check = CB_CS_XML_GENERATE;
-	cobc_xref_set_receiving (current_program->xml_code);
+	cb_set_register_receiving (current_program->xml_code, 1);
   }
   xml_generate_body
   _end_xml
@@ -17536,16 +17555,18 @@ xml_parse_statement:
 	begin_statement (STMT_XML_PARSE, TERM_XML);
 	CB_PENDING ("XML PARSE");
 	cobc_cs_check = CB_CS_XML_PARSE;
-	cobc_xref_set_receiving (current_program->xml_code);
-	cobc_xref_set_receiving (current_program->xml_event);
-	cobc_xref_set_receiving (current_program->xml_text);
-	cobc_xref_set_receiving (current_program->xml_ntext);
+	cb_set_register_receiving (current_program->xml_code, 1);
+	cb_set_register_receiving (current_program->xml_event, 1);
+	cb_set_register_receiving (current_program->xml_text, 1);
+	cb_set_register_receiving (current_program->xml_ntext, 0);
+	if (cb_xml_parse_xmlss) {
+		cb_set_register_receiving (current_program->xml_namespace, 1);
+		cb_set_register_receiving (current_program->xml_namespace_prefix, 1);
+		cb_set_register_receiving (current_program->xml_nnamespace, 1);
+		cb_set_register_receiving (current_program->xml_nnamespace_prefix, 1);
+	}
 	if (cb_xml_parse_xmlss) {
-		cobc_xref_set_receiving (current_program->xml_information);
-		cobc_xref_set_receiving (current_program->xml_namespace);
-		cobc_xref_set_receiving (current_program->xml_namespace_prefix);
-		cobc_xref_set_receiving (current_program->xml_nnamespace);
-		cobc_xref_set_receiving (current_program->xml_nnamespace_prefix);
+		cb_set_register_receiving (current_program->xml_information, 0);
 	}
   }
   xml_parse_body

cobc/tree.h

@@ -1847,17 +1847,17 @@ struct cb_program {
 	cb_tree			apply_commit;		/* APPLY COMMIT file- and data-items */
 	cb_tree			cursor_pos;		/* CURSOR */
 	cb_tree			crt_status;		/* CRT STATUS */
-	cb_tree			xml_code;		/* XML-CODE */
-	cb_tree			xml_event;		/* XML-EVENT */
-	cb_tree			xml_information;	/* XML-INFORMATION */
-	cb_tree			xml_namespace;		/* XML-NAMESPACE */
-	cb_tree			xml_nnamespace;		/* XML-NNAMESPACE */
-	cb_tree			xml_namespace_prefix;	/* XML-NAMESPACE-PREFIX */
-	cb_tree			xml_nnamespace_prefix;	/* XML-NNAMESPACE-PREFIX */
-	cb_tree			xml_ntext;		/* XML-NTEXT */
-	cb_tree			xml_text;		/* XML-TEXT */
-	cb_tree			json_code;		/* JSON-CODE */
-	cb_tree			json_status;		/* JSON-STATUS */
+	struct cb_field	*xml_code;		/* XML-CODE */
+	struct cb_field	*xml_event;		/* XML-EVENT */
+	struct cb_field	*xml_information;	/* XML-INFORMATION */
+	struct cb_field	*xml_namespace;		/* XML-NAMESPACE */
+	struct cb_field	*xml_nnamespace;		/* XML-NNAMESPACE */
+	struct cb_field	*xml_namespace_prefix;	/* XML-NAMESPACE-PREFIX */
+	struct cb_field	*xml_nnamespace_prefix;	/* XML-NNAMESPACE-PREFIX */
+	struct cb_field	*xml_ntext;		/* XML-NTEXT */
+	struct cb_field	*xml_text;		/* XML-TEXT */
+	struct cb_field	*json_code;		/* JSON-CODE */
+	struct cb_field	*json_status;		/* JSON-STATUS */
 	cb_tree			returning;		/* RETURNING */
 	struct cb_label		*all_procedure;		/* DEBUGGING */
 	struct cb_call_xref	call_xref;		/* CALL Xref list */

cobc/typeck.c

@@ -1812,7 +1812,15 @@ cb_build_generic_register (const char *name, const char *external_definition,
 	return 0;
 }
 
-static cb_tree
+static COB_INLINE COB_A_INLINE struct cb_field *
+cb_build_generic_register_field (const char *name, const char *external_definition)
+{
+	struct cb_field *field = NULL;
+	cb_build_generic_register (name, external_definition, &field);
+	return field;
+}
+
+static struct cb_field *
 cb_build_register_internal_code (const char* name, const char* definition)
 {
 	cb_tree tfield;
@@ -1841,7 +1849,7 @@ cb_build_register_internal_code (const char* name, const char* definition)
 	field->flag_internal_register = 1;
 	field->level = 77;
 
-	return tfield;
+	return field;
 }
 
 
@@ -1879,87 +1887,47 @@ cb_build_single_register (const char *name, const char *definition)
 		return;
 	}
 	if (!cb_strcasecmp (name, "XML-CODE")) {
-		cb_tree tfield = cb_build_register_internal_code (name, definition);
-		if (tfield) {
-			current_program->xml_code = tfield;
-		}
+		current_program->xml_code = cb_build_register_internal_code (name, definition);
 		return;
 	}
 	if (!cb_strcasecmp (name, "XML-EVENT")) {
-		struct cb_field *field = NULL;
-		cb_build_generic_register (name, definition, &field);
-		if (field) {
-			current_program->xml_event = CB_TREE (field);
-		}
+		current_program->xml_event = cb_build_generic_register_field (name, definition);
 		return;
 	}
 	if (!cb_strcasecmp (name, "XML-INFORMATION")) {
-		cb_tree tfield = cb_build_register_internal_code (name, definition);
-		if (tfield) {
-			current_program->xml_information = tfield;
-		}
+		current_program->xml_information = cb_build_register_internal_code (name, definition);
 		return;
 	}
 	if (!cb_strcasecmp (name, "XML-TEXT")) {
-		struct cb_field *field = NULL;
-		cb_build_generic_register (name, definition, &field);
-		if (field) {
-			current_program->xml_text = CB_TREE (field);
-		}
+		current_program->xml_text = cb_build_generic_register_field (name, definition);
 		return;
 	}
 	if (!cb_strcasecmp (name, "XML-NTEXT")) {
-		struct cb_field *field = NULL;
-		cb_build_generic_register (name, definition, &field);
-		if (field) {
-			current_program->xml_ntext = CB_TREE (field);
-		}
+		current_program->xml_ntext = cb_build_generic_register_field (name, definition);
 		return;
 	}
 	if (!cb_strcasecmp (name, "XML-NAMESPACE")) {
-		struct cb_field *field = NULL;
-		cb_build_generic_register (name, definition, &field);
-		if (field) {
-			current_program->xml_namespace = CB_TREE (field);
-		}
+		current_program->xml_namespace = cb_build_generic_register_field (name, definition);
 		return;
 	}
 	if (!cb_strcasecmp (name, "XML-NNAMESPACE")) {
-		struct cb_field *field = NULL;
-		cb_build_generic_register (name, definition, &field);
-		if (field) {
-			current_program->xml_nnamespace = CB_TREE (field);
-		}
+		current_program->xml_nnamespace = cb_build_generic_register_field (name, definition);
 		return;
 	}
 	if (!cb_strcasecmp (name, "XML-NAMESPACE-PREFIX")) {
-		struct cb_field *field = NULL;
-		cb_build_generic_register (name, definition, &field);
-		if (field) {
-			current_program->xml_namespace_prefix = CB_TREE (field);
-		}
+		current_program->xml_namespace_prefix = cb_build_generic_register_field (name, definition);
 		return;
 	}
 	if (!cb_strcasecmp (name, "XML-NNAMESPACE-PREFIX")) {
-		struct cb_field *field = NULL;
-		cb_build_generic_register (name, definition, &field);
-		if (field) {
-			current_program->xml_nnamespace_prefix = CB_TREE (field);
-		}
+		current_program->xml_nnamespace_prefix = cb_build_generic_register_field (name, definition);
 		return;
 	}
 	if (!cb_strcasecmp (name, "JSON-CODE")) {
-		cb_tree tfield = cb_build_register_internal_code (name, definition);
-		if (tfield) {
-			current_program->json_code = tfield;
-		}
+		current_program->json_code =  cb_build_register_internal_code (name, definition);
 		return;
 	}
 	if (!cb_strcasecmp (name, "JSON-STATUS")) {
-		cb_tree tfield = cb_build_register_internal_code (name, definition);
-		if (tfield) {
-			current_program->json_status = tfield;
-		}
+		current_program->json_status = cb_build_register_internal_code (name, definition);
 		return;
 	}
 
@@ -4750,6 +4718,8 @@ cb_validate_program_data (struct cb_program *prog)
 			cb_error_x (prog->cursor_pos, _("'%s' CURSOR must be 4 or 6 characters long"),
 				    cb_name (prog->cursor_pos));
 			prog->cursor_pos = NULL;
+		} else {
+			prog->cursor_pos = x;
 		}
 	}
 	if (prog->crt_status) {
@@ -14732,8 +14702,9 @@ cb_emit_xml_parse (cb_tree data, cb_tree proc,
 	ref = cb_ref (data);
 	if (CB_FIELD_P (ref)) {
 		struct cb_field * field = CB_FIELD (ref);
-		/* type checks here */
-		cb_emit (cb_build_xml_parse (data, proc, returning_national,
+		/* TODO: type checks here */
+		cb_emit (cb_build_xml_parse (data, proc,
+			returning_national | (field->usage == CB_USAGE_NATIONAL),
 			encoding, validation));
 	} else {
 	}

config/ChangeLog

@@ -20,10 +20,14 @@
 
 2022-11-18  Simon Sobisch <[email protected]>
 
-	* ibm.words, mvs.words: removed words only reserved with EXEC SQL coprocessor,
-	  fixing bug #810
+	* ibm.words, mvs.words: removed words only reserved with EXEC SQL
+	  coprocessor, fixing bug #810
 	* ibm.words: update for Enterprise COBOL 6.4 (added FUNCTION-ID)
 
+2022-11-18  Simon Sobisch <[email protected]>
+
+	* ibm.words, acu.words, bs2000.words: enabled JSON + XML registers
+
 2022-10-10  Simon Sobisch <[email protected]>
 
 	* runtime.cfg: add COB_CORE_FILENAME and adjust COB_CORE_ON_ERROR
@@ -141,7 +145,7 @@
 
 2021-09-14  Simon Sobisch <[email protected]>
 
-	* general: added odoslide, active in bs200, ibm, mvs (previously a
+	* general: added odoslide, active in bs2000, ibm, mvs (previously a
 	  compile flag only)
 	* bs2000-strict.conf: adjusted complex-odo to "yes"