From 87c728bac07cda3defe1200f4e3363f43dd36285 Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Wed, 18 Jan 2023 17:34:15 +0000 Subject: [PATCH] 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 | 6 +++ cobc/codegen.c | 51 +++++++++++++----------- cobc/parser.y | 47 ++++++++++++++++------- cobc/tree.h | 22 +++++------ cobc/typeck.c | 81 +++++++++++++-------------------------- config/ChangeLog | 10 +++-- config/acu.words | 14 +++---- config/bs2000-strict.conf | 2 +- config/bs2000.words | 24 +++++------- config/ibm.words | 35 +++++++---------- libcob/ChangeLog | 2 + libcob/common.h | 4 +- libcob/mlio.c | 35 ++++++++++------- 13 files changed, 167 insertions(+), 166 deletions(-) diff --git a/cobc/ChangeLog b/cobc/ChangeLog index efb41b0dd..1cfe151b8 100644 --- a/cobc/ChangeLog +++ b/cobc/ChangeLog @@ -248,6 +248,12 @@ only a single value * parser.y (value_clause): improved parsing for table-format +2022-11-18 Simon Sobisch + + * 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 * cobc.c (print_line): fully honor -fmfcomment by suppressing lines diff --git a/cobc/codegen.c b/cobc/codegen.c index 14658116d..11370893d 100644 --- a/cobc/codegen.c +++ b/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 diff --git a/cobc/parser.y b/cobc/parser.y index 99ac1740f..45826bac6 100644 --- a/cobc/parser.y +++ b/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 diff --git a/cobc/tree.h b/cobc/tree.h index f7f7e45fd..5118fb32c 100644 --- a/cobc/tree.h +++ b/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 */ diff --git a/cobc/typeck.c b/cobc/typeck.c index 0d2b9c274..5d05c1678 100644 --- a/cobc/typeck.c +++ b/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 { } diff --git a/config/ChangeLog b/config/ChangeLog index 4bb6685c4..43d06c4cc 100644 --- a/config/ChangeLog +++ b/config/ChangeLog @@ -20,10 +20,14 @@ 2022-11-18 Simon Sobisch - * 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 + + * ibm.words, acu.words, bs2000.words: enabled JSON + XML registers + 2022-10-10 Simon Sobisch * runtime.cfg: add COB_CORE_FILENAME and adjust COB_CORE_ON_ERROR @@ -141,7 +145,7 @@ 2021-09-14 Simon Sobisch - * 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" diff --git a/config/acu.words b/config/acu.words index 7779f597c..e471a270d 100644 --- a/config/acu.words +++ b/config/acu.words @@ -1,6 +1,6 @@ # GnuCOBOL compiler - list of reserved words # -# Copyright (C) 2016-2017,2021 Free Software Foundation, Inc. +# Copyright (C) 2016-2017,2023 Free Software Foundation, Inc. # Written by Simon Sobisch, Edward Hart # # This file is part of GnuCOBOL. @@ -425,8 +425,6 @@ reserved: ITEM-TO-EMPTY* reserved: ITEM-VALUE* reserved: INTERVAL-TIMER # actually a function not supported in GC reserved: JSON -reserved: JSON-CODE # note: this is a register, move as soon as supported -reserved: JSON-STATUS # note: this is a register, move as soon as supported reserved: JUST=JUSTIFIED reserved: JUSTIFIED reserved: KEPT @@ -831,8 +829,6 @@ reserved: WRAP reserved: WRITE reserved: WRITERS reserved: XML -reserved: XML-EVENT # note: this is a register, move as soon as supported -reserved: XML-TEXT # note: this is a register, move as soon as supported reserved: X* reserved: Y* reserved: YYYYDDD @@ -850,8 +846,8 @@ register: "ADDRESS\ OF" # register: ENVIRONMENT-NAME # register: FILE-PREFIX register: "LENGTH\ OF" -# register: JSON-CODE -# register: JSON-STATUS +register: JSON-CODE +register: JSON-STATUS register: RETURN-CODE # register: RETURN-UNSIGNED # SORT-RETURN is only available in IBM mode @@ -860,8 +856,8 @@ register: RETURN-CODE # TIME-OF-DAY is only available in HPUX mode, not yet recognized by GnuCOBOL # WHEN-COMPILED is only available in HPUX mode register: XML-CODE -# register: XML-EVENT -# register: XML-TEXT +register: XML-EVENT +register: XML-TEXT # list of (non-standard) system names: diff --git a/config/bs2000-strict.conf b/config/bs2000-strict.conf index 8921936ad..f580a2396 100644 --- a/config/bs2000-strict.conf +++ b/config/bs2000-strict.conf @@ -186,7 +186,7 @@ implicit-assign-dynamic-var: no device-mnemonics: no # full clauses in XML PARSE - and adjusted XML-EVENTs -xml-parse-xmlss: no # not supported at all +xml-parse-xmlss: no # only XMLPARSE"COMPAT" way # What rules to apply to SCREEN SECTION items clauses screen-section-rules: std diff --git a/config/bs2000.words b/config/bs2000.words index c09be47c8..b5e1ea8b2 100644 --- a/config/bs2000.words +++ b/config/bs2000.words @@ -1,6 +1,6 @@ # GnuCOBOL compiler - list of reserved words # -# Copyright (C) 2016-2017,2021,2023 Free Software Foundation, Inc. +# Copyright (C) 2016-2017,2021-2023 Free Software Foundation, Inc. # Written by Simon Sobisch, Edward Hart # # This file is part of GnuCOBOL. @@ -36,6 +36,7 @@ reserved: ACCEPT reserved: ACCESS reserved: ACTIVE-CLASS reserved: ADD +reserved: ADDR # BS2000 intrinsic function, not known to GnuCOBOL reserved: ADDRESS reserved: ADVANCING reserved: AFTER @@ -545,13 +546,6 @@ reserved: WORDS reserved: WORKING-STORAGE reserved: WRITE reserved: XML -reserved: XML-EVENT # note: this is a register, move as soon as supported -reserved: XML-NAMESPACE # note: this is a register, move as soon as supported -reserved: XML-NAMESPACE-PREFIX # note: this is a register, move as soon as supported -reserved: XML-NNAMESPACE # note: this is a register, move as soon as supported -reserved: XML-NNAMESPACE-PREFIX # note: this is a register, move as soon as supported -reserved: XML-NTEXT # note: this is a register, move as soon as supported -reserved: XML-TEXT # note: this is a register, move as soon as supported reserved: YYYYDDD* reserved: YYYYMMDD* reserved: ZERO @@ -577,13 +571,13 @@ register: RETURN-CODE register: SORT-RETURN register: TALLY register: XML-CODE -# register: XML-EVENT -# register: XML-NAMESPACE -# register: XML-NAMESPACE-PREFIX -# register: XML-NNAMESPACE -# register: XML-NNAMESPACE-PREFIX -# register: XML-NTEXT -# register: XML-TEXT +register: XML-EVENT +register: XML-NAMESPACE +register: XML-NAMESPACE-PREFIX +register: XML-NNAMESPACE +register: XML-NNAMESPACE-PREFIX +register: XML-NTEXT +register: XML-TEXT # TO-DO: Add all printer mnemonics and special variables # (e.g. DATE-ISO4, CPU-TIME). diff --git a/config/ibm.words b/config/ibm.words index 0858c5a25..da0c4dc92 100644 --- a/config/ibm.words +++ b/config/ibm.words @@ -114,7 +114,7 @@ reserved: COMPUTATIONAL-5=COMP-5 reserved: COMPUTE reserved: CONFIGURATION reserved: CONTAINS -reserved: CONTENT +reserved: CONTENT-OF # V6.4 IBM intrinsic function extension conflicting to GC one reserved: CONTINUE reserved: CONTROL reserved: CONTROLS @@ -270,8 +270,6 @@ reserved: IS reserved: JAVA reserved: JNIENVPTR # note: this is a register, move as soon as supported reserved: JSON -reserved: JSON-CODE # note: this is a register, move as soon as supported -reserved: JSON-STATUS # note: this is a register, move as soon as supported reserved: JUST=JUSTIFIED reserved: JUSTIFIED reserved: KANJI @@ -526,15 +524,7 @@ reserved: XML reserved: XML-DECLARATION* # note: not included in IBMs reserved words # list, but as a phrase to be parsed # for XML GENERATE -reserved: XML-EVENT # note: this is a register, move as soon as supported -reserved: XML-INFORMATION # note: this is a register, move as soon as supported -reserved: XML-NAMESPACE # note: this is a register, move as soon as supported -reserved: XML-NAMESPACE-PREFIX # note: this is a register, move as soon as supported -reserved: XML-NNAMESPACE # note: this is a register, move as soon as supported -reserved: XML-NNAMESPACE-PREFIX # note: this is a register, move as soon as supported -reserved: XML-NTEXT # note: this is a register, move as soon as supported reserved: XML-SCHEMA -reserved: XML-TEXT # note: this is a register, move as soon as supported reserved: YYYYDDD* reserved: YYYYMMDD* reserved: ZERO @@ -547,7 +537,8 @@ not-register: DIALECT-ALL register: "ADDRESS\ OF" register: DEBUG-ITEM # register: JNIENVPTR -# register: JSON-CODE +register: JSON-CODE +register: JSON-STATUS register: "LENGTH\ OF" # register: LINAGE-COUNTER register: RETURN-CODE @@ -562,15 +553,14 @@ register: SORT-RETURN register: TALLY register: WHEN-COMPILED register: XML-CODE -# register: XML-EVENT -# register: XML-INFORMATION -# register: XML-NAMESPACE -# register: XML-NAMESPACE-PREFIX -# register: XML-NNAMESPACE -# register: XML-NNAMESPACE-PREFIX -# register: XML-NTEXT -# register: XML-TEXT - +register: XML-EVENT +register: XML-INFORMATION +register: XML-NAMESPACE +register: XML-NAMESPACE-PREFIX +register: XML-NNAMESPACE +register: XML-NNAMESPACE-PREFIX +register: XML-NTEXT +register: XML-TEXT # list of system names: not-system-name: DIALECT-ALL-SWITCHES @@ -583,7 +573,6 @@ system-name: UPSI-5 system-name: UPSI-6 system-name: UPSI-7 - # disable all functions not-intrinsic-function: DIALECT-ALL @@ -600,6 +589,8 @@ intrinsic-function: CHAR intrinsic-function: COMBINED-DATETIME #intrinsic-function: CONTENT-OF # IBM extension - different than GnuCOBOL one reserved: CONTENT-OF # to raise error message +# intrinsic-function: CONTENT-OF # IBM extension conflicting to GC one to +# create a temporary copy intrinsic-function: CURRENT-DATE intrinsic-function: DATE-OF-INTEGER intrinsic-function: DATE-TO-YYYYMMDD diff --git a/libcob/ChangeLog b/libcob/ChangeLog index 141562e58..aa15cb71c 100644 --- a/libcob/ChangeLog +++ b/libcob/ChangeLog @@ -170,6 +170,8 @@ 2022-11-18 Simon Sobisch * screenio.c: fixed compiler warnings related to get_crt3_status + * common.h: XML mode defines + * mlio.c: adjustments for register handling in XML parse stubs 2022-11-26 Simon Sobisch diff --git a/libcob/common.h b/libcob/common.h index 08213d228..bbc74d666 100644 --- a/libcob/common.h +++ b/libcob/common.h @@ -34,7 +34,6 @@ typedef __mpz_struct mpz_t[1]; #endif #endif - /* General type defines */ #define cob_c8_t char #define cob_s8_t signed char @@ -1070,6 +1069,9 @@ enum cob_statement { #define COB_JSON_CJSON 1 #define COB_JSON_JSON_C 2 +#define COB_XML_PARSE_XMLNSS (1U << 0) +#define COB_XML_PARSE_NATIONAL (1U << 1) + /* Structure/union declarations */ diff --git a/libcob/mlio.c b/libcob/mlio.c index 1bed92019..a184ccc8d 100644 --- a/libcob/mlio.c +++ b/libcob/mlio.c @@ -152,7 +152,7 @@ get_xml_code (void) return cob_get_int (COB_MODULE_PTR->xml_code); } -/* set special registers XML-EVENT, if available */ +/* set special register XML-EVENT */ static void set_xml_event (const char *data) { @@ -162,7 +162,7 @@ set_xml_event (const char *data) COB_MODULE_PTR->xml_event->size = strlen (data); } -/* set special registers XML-TEXT / XML-NTEXT, if available +/* set special registers XML-TEXT / XML-NTEXT the size is calculated if not explicit specified (size -> -1) */ static void set_xml_text (const int ntext, const void *data, size_t size) @@ -177,8 +177,11 @@ set_xml_text (const int ntext, const void *data, size_t size) COB_MODULE_PTR->xml_text->data = (unsigned char *) ""; COB_MODULE_PTR->xml_text->size = 0; } else { - COB_MODULE_PTR->xml_ntext->data = (unsigned char *) ""; - COB_MODULE_PTR->xml_ntext->size = 0; + /* XML-NTEXT and other XML-N... special registers are not available with ACUCOBOL */ + if (COB_MODULE_PTR->xml_ntext) { + COB_MODULE_PTR->xml_ntext->data = (unsigned char *) ""; + COB_MODULE_PTR->xml_ntext->size = 0; + } COB_MODULE_PTR->xml_text->data = (unsigned char *) data; COB_MODULE_PTR->xml_text->size = size != -1 ? size : strlen (data); } @@ -1039,16 +1042,22 @@ int cob_xml_parse (cob_field *in, cob_field *encoding, cob_field *validation, /* no state yet ? first call */ if (*saved_state == NULL) { + /* no field */ + if (!in) { +#if 0 /* seems like a codegen error, which should not happen */ + set_xml_exception (XML_INTERNAL_ERROR); + set_xml_event (EVENT_EXCEPTION); + set_xml_text (0, "", 0); + return -1; +#else + cob_fatal_error (COB_FERROR_CODEGEN); +#endif + } *saved_state = cob_malloc (sizeof (struct xml_state)); } state = (struct xml_state *)*saved_state; - /* no field */ - if (!in) { - set_xml_exception (XML_INTERNAL_ERROR); - cob_fatal_error (COB_FERROR_CODEGEN); - } /* LINKAGE or BASED item without data */ if (!in->data) { state->last_xml_code = XML_INTERNAL_ERROR; @@ -1315,14 +1324,14 @@ void xml_parse (cob_field *in, cob_field *encoding, cob_field *validation, set_xml_exception (XML_PARSE_ERROR_MISC_COMPAT); } set_xml_event (EVENT_EXCEPTION); - set_xml_text (flags && 0x01, "", 0); + set_xml_text (0, "", 0); return; } set_xml_event (EVENT_START_OF_DOCUMENT); if (COB_MODULE_PTR->xml_mode == COB_XML_XMLNSS) { - set_xml_text (flags && 0x01, "", 0); + set_xml_text (0, "", 0); } else { - set_xml_text (flags && 0x01, in->data, in->size); + set_xml_text (flags & COB_XML_PARSE_NATIONAL, in->data, in->size); } state->state = XML_PARSER_JUST_STARTED; return; @@ -1350,7 +1359,7 @@ void xml_parse (cob_field *in, cob_field *encoding, cob_field *validation, cob_add_exception (COB_EC_IMP_FEATURE_MISSING); set_xml_event (EVENT_EXCEPTION); /* in case of EXCEPTIONs - should have a pointer to the text already parsed */ - set_xml_text (flags && 0x01, "" , 0); + set_xml_text (flags & COB_XML_PARSE_NATIONAL, "" , 0); state->state = XML_PARSER_HAD_FATAL_ERROR; }