https://gcc.gnu.org/g:5a9ed40577701e9374ce2130d7220fa64923b53f
commit r17-4585-g5a9ed40577701e9374ce2130d7220fa64923b53f Author: Xavier Del Campo Romero <[email protected]> Date: Mon Sep 21 22:51:09 2026 +0200 cobol: Fix CBL_GET_PROGRAM_INFO function 2 The previous logic assumed that function 2 only returned the status information and program name for the program associated by cblte-gpi-handle. However, the documentation states function 2 must return the information from the caller program instead, also updating cblte-gpi-handle. [1] Therefore, the previous logic was flawed. For example, assuming program D allocates cblte-gpi-handle by calling function 0, and given the following call stack: A -> B -> C -> D It is then possible for function G, under the following call stack, to extract the call stack for D, one call to CBL_GET_PROGRAM_INFO at a time: A -> E -> F -> G Therefore, function 2 would return the information from function C on the first call, then F and so on, until returning a non-zero status code. [1]: https://docs.rocketsoftware.com/bundle/visualcoboldevhub_ug_110/page/lxm1742952203519.html libgcobol/ChangeLog: * compat/gnu/lib/cbl_gpi.cc (struct gpi_priv): Fix flawed logic. (getlastprog): Likewise. (callstack): Likewise. (cbl_gpi_cur_status): Likewise. (cbl_gpi_handle_status): Likewise. (cbl_gpi_parent_status): Likewise. (cbl_gpi_close_handle): Likewise. gcc/testsuite/ChangeLog: * cobol.dg/group2/CBL_GET_PROGRAM_INFO__get_program_name_-_functions_0_and_2_.cob: Update test to new behaviour. * cobol.dg/group2/CBL_GET_PROGRAM_INFO__get_program_name_-_functions_0_and_2_.out: Likewise. Diff: --- ...INFO__get_program_name_-_functions_0_and_2_.cob | 99 +++++++++++++++------- ...INFO__get_program_name_-_functions_0_and_2_.out | 8 +- libgcobol/compat/gnu/lib/cbl_gpi.cc | 42 ++++----- 3 files changed, 99 insertions(+), 50 deletions(-) diff --git a/gcc/testsuite/cobol.dg/group2/CBL_GET_PROGRAM_INFO__get_program_name_-_functions_0_and_2_.cob b/gcc/testsuite/cobol.dg/group2/CBL_GET_PROGRAM_INFO__get_program_name_-_functions_0_and_2_.cob index 5b2f160397e8..f26b70f39c27 100644 --- a/gcc/testsuite/cobol.dg/group2/CBL_GET_PROGRAM_INFO__get_program_name_-_functions_0_and_2_.cob +++ b/gcc/testsuite/cobol.dg/group2/CBL_GET_PROGRAM_INFO__get_program_name_-_functions_0_and_2_.cob @@ -4,41 +4,65 @@ *> { dg-output-file "group2/CBL_GET_PROGRAM_INFO__get_program_name_-_functions_0_and_2_.out" } copy "cblproto.cpy". + identification division. program-id. prog. data division. working-storage section. copy "cbltypes.cpy". - 01 param-block type cblt-prog-info-params value zeros. + 01 param-block type cblt-prog-info-params. + procedure division. + display "calling a from prog". + call "a" using param-block. + display "calling c from prog". + call "c" using param-block. + end program prog. + + identification division. + program-id. a. + data division. + linkage section. + copy "cbltypes.cpy". + 01 param-block type cblt-prog-info-params. + procedure division using param-block. + display "calling b from a". + call "b" using param-block. + end program a. + + identification division. + program-id. c. + data division. + working-storage section. 77 fn pic x(4) comp-5. - 77 status-code pic x(2) comp-5. + 77 status-code pic x(2) comp-5 value 0. 77 buf pic x(128). 77 buflen pic x(4) comp-5. - procedure division. - move length of param-block to cblte-gpi-size. - - * allocate handle - move 7 to cblte-gpi-flags. - move 0 to fn. + linkage section. + copy "cbltypes.cpy". + 01 param-block type cblt-prog-info-params. + procedure division using param-block. move length of buf to buflen. - call "CBL_GET_PROGRAM_INFO" using - by value fn - by reference param-block - buf - buflen - returning status-code. - - if status-code <> 0 - display "CBL_GET_PROGRAM_INFO failed with " status-code - goback - end-if. + perform until status-code <> 0 + * retrieve program name from handle + move 6 to cblte-gpi-flags + move 2 to fn + move x"00" to buf + call "CBL_GET_PROGRAM_INFO" using + by value fn + by reference param-block + buf + buflen + returning status-code - display "buf is '" buf "'". + if status-code = 0 + display "buf from c is '" buf "'" + end-if + end-perform. - * retrieve program name from handle - move 6 to cblte-gpi-flags. - move 2 to fn. - move x"00" to buf. + close-handle section. + * close handle + move 0 to cblte-gpi-flags. + move 3 to fn. call "CBL_GET_PROGRAM_INFO" using by value fn by reference param-block @@ -50,12 +74,27 @@ display "CBL_GET_PROGRAM_INFO failed with " status-code goback end-if. + end program c. - display "buf from handle is '" buf "'". + identification division. + program-id. b. + data division. + working-storage section. + copy "cbltypes.cpy". + 77 fn pic x(4) comp-5. + 77 status-code pic x(2) comp-5. + 77 buf pic x(128). + 77 buflen pic x(4) comp-5. + linkage section. + copy "cbltypes.cpy". + 01 param-block type cblt-prog-info-params. + procedure division using param-block. + move length of param-block to cblte-gpi-size. - * close handle - move 0 to cblte-gpi-flags. - move 3 to fn. + * allocate handle + move 7 to cblte-gpi-flags. + move 0 to fn. + move length of buf to buflen. call "CBL_GET_PROGRAM_INFO" using by value fn by reference param-block @@ -67,5 +106,7 @@ display "CBL_GET_PROGRAM_INFO failed with " status-code goback end-if. - end program prog. + + display "buf from b is '" buf "'". + end program b. diff --git a/gcc/testsuite/cobol.dg/group2/CBL_GET_PROGRAM_INFO__get_program_name_-_functions_0_and_2_.out b/gcc/testsuite/cobol.dg/group2/CBL_GET_PROGRAM_INFO__get_program_name_-_functions_0_and_2_.out index c86d093d7678..deb2631b3ce3 100644 --- a/gcc/testsuite/cobol.dg/group2/CBL_GET_PROGRAM_INFO__get_program_name_-_functions_0_and_2_.out +++ b/gcc/testsuite/cobol.dg/group2/CBL_GET_PROGRAM_INFO__get_program_name_-_functions_0_and_2_.out @@ -1,3 +1,7 @@ -buf is 'prog' -buf from handle is 'prog' +calling a from prog +calling b from a +buf from b is 'b' +calling c from prog +buf from c is 'a' +buf from c is 'prog' diff --git a/libgcobol/compat/gnu/lib/cbl_gpi.cc b/libgcobol/compat/gnu/lib/cbl_gpi.cc index 5e02ac4bd584..7708767fad73 100644 --- a/libgcobol/compat/gnu/lib/cbl_gpi.cc +++ b/libgcobol/compat/gnu/lib/cbl_gpi.cc @@ -39,8 +39,13 @@ struct gpi_priv { - gpi_priv(const std::string &name) : name(name){} - std::string name; + gpi_priv(const std::vector<std::string> &callstack) : + callstack(callstack), + it(this->callstack.crbegin()) + { + } + const std::vector<std::string> callstack; + std::vector<std::string>::const_reverse_iterator it; }; /* From the COBOL side, we add no padding bytes at all for groups. */ @@ -98,13 +103,13 @@ enum cbl_backtrace_flags CBL_BACKTRACE_DATA31 = 1 << 24 }; -static std::string -getlastprog() +static std::vector<std::string> +callstack() { const std::vector<std::string> &__gg__get_module_names(), &names = __gg__get_module_names(); const char *s = NULL; - std::string ret; + std::vector<std::string> ret; for (const auto &name : names) { @@ -113,14 +118,11 @@ getlastprog() const char *cname = name.c_str() + 1; if (strcasecmp(cname, "CBL_GET_PROGRAM_INFO")) - s = cname; + ret.push_back(cname); else break; } - if (s) - ret = s; - return ret; } @@ -141,15 +143,15 @@ setbasename(const std::string &src, const gpi_param_t &p, char *dst, unsigned n) int16_t cbl_gpi_cur_status(gpi_param_t ¶ms, union retbuf buf, unsigned buflen) { - std::string prog = getlastprog(); + std::vector<std::string> cs = callstack(); - if (prog.empty()) + if (cs.empty()) return -1; else if (params.flags & GPI_PARAM_RET_BASENAME) - setbasename(prog, params, buf.basename, buflen); + setbasename(cs.back(), params, buf.basename, buflen); if (params.flags & GPI_PARAM_RET_HANDLE) - params.handle = new gpi_priv(prog); + params.handle = new gpi_priv(cs); /* TODO: set status bits */ return 0; @@ -165,12 +167,14 @@ cbl_gpi_named_status(gpi_param_t ¶ms, union retbuf buf, unsigned buflen) } int16_t -cbl_gpi_handle_status(gpi_param_t ¶ms, union retbuf buf, unsigned buflen) +cbl_gpi_parent_status(gpi_param_t ¶ms, union retbuf buf, unsigned buflen) { - const gpi_priv *prv = static_cast<const struct gpi_priv *>(params.handle); + gpi_priv *prv = params.handle; - if (params.flags & GPI_PARAM_RET_BASENAME) - setbasename(prv->name.c_str(), params, buf.basename, buflen); + if (prv->it + 1 >= prv->callstack.crend()) + return -1; + else if (params.flags & GPI_PARAM_RET_BASENAME) + setbasename(*++prv->it, params, buf.basename, buflen); /* TODO: set status bits */ return 0; @@ -179,7 +183,7 @@ cbl_gpi_handle_status(gpi_param_t ¶ms, union retbuf buf, unsigned buflen) int16_t cbl_gpi_close_handle(gpi_param_t ¶ms, union retbuf buf, unsigned buflen) { - delete static_cast<gpi_priv *>(params.handle); + delete params.handle; /* TODO: set status bits */ return 0; } @@ -254,7 +258,7 @@ static const struct func }, { - cbl_gpi_handle_status, + cbl_gpi_parent_status, GPI_PARAM_RET_BASENAME | GPI_PARAM_RET_PRGATTR | GPI_PARAM_NULL_TERM | GPI_PARAM_ALL_PROG, GPI_PARAM_RET_HANDLE
