diff --git a/gcc/cobol/genapi.cc b/gcc/cobol/genapi.cc
index 428885fd2c7bfbb58574cc21073e0a6f3dc67ade..b796a4128f60a161265a5e31684e900b3242d946 100644
--- a/gcc/cobol/genapi.cc
+++ b/gcc/cobol/genapi.cc
@@ -3291,6 +3291,7 @@ parser_enter_program( const char *funcname_,
}
enter_program_common(funcname, funcname_);
+ current_function->is_function = is_function;
TRACE1
{
@@ -4727,7 +4728,7 @@ parser_move(size_t ntgt, cbl_refer_t *tgts, cbl_refer_t src, cbl_round_t rounded
static
tree
-field_type_to_tree_type(cbl_field_t *field)
+field_type_to_tree_type(cbl_field_t *field, bool is_function)
{
/* This routine is used to determine what action is taken with type of a
CALL ... USING <var> and the matching PROCEDURE DIVISION USING <var> of
@@ -4735,16 +4736,24 @@ field_type_to_tree_type(cbl_field_t *field)
This routine looks at a field. If that field can be handled as a simple
type of no more than 64-bits, the tree form of that type is is returned.
-
+
+ When a field can't be handled as a 64-bit variant, we return NULL. In
+ that case, our caller will assume the variable being transferred is a
+ 64-bit pointer to a malloced buffer, and will generate code accordingly.
*/
-
// This maps a Fldxxx to a C-style variable type:
switch(field->type)
{
case FldGroup:
case FldAlphanumeric:
case FldAlphaEdited:
+ if( is_function )
+ {
+ // For COBOL functions, these types of variables are treated as malloced
+ // buffers.
+ return NULL;
+ }
return CHAR_P;
case FldNumericEdited:
@@ -4754,9 +4763,17 @@ field_type_to_tree_type(cbl_field_t *field)
case FldNumericBin5:
case FldIndex:
case FldPointer:
+ if( field->data.capacity > 8 )
+ {
+ return NULL;
+ }
return SSIZE_T;
case FldFloat:
+ if( field->data.capacity > 8 )
+ {
+ return NULL;
+ }
return DOUBLE;
case FldInvalid:
@@ -4847,7 +4864,8 @@ parser_exit(void)
if( current_function->returning )
{
- tree return_type = field_type_to_tree_type(current_function->returning);
+ tree return_type = field_type_to_tree_type(current_function->returning,
+ current_function->is_function);
if( return_type == CHAR_P )
{
@@ -10749,7 +10767,7 @@ parser_call( cbl_refer_t name,
member(returned.refer_decl_node, "qual_data"));
gg_assign(returned_length,
member(returned.refer_decl_node, "qual_size"));
- returned_value_type = field_type_to_tree_type(returned.field);
+ returned_value_type = field_type_to_tree_type(returned.field, is_function);
}
else
{
@@ -10758,7 +10776,6 @@ parser_call( cbl_refer_t name,
tree function_handle = function_handle_from_name(name, narg);
-
IF( function_handle,
ne_op,
gg_cast(TREE_TYPE(function_handle), null_pointer_node) )
@@ -10855,19 +10872,26 @@ parser_call( cbl_refer_t name,
tree returned_value;
if( returned.field )
{
- // We are expecting a return value:
- returned_value = gg_define_variable(returned_value_type);
+ // We are expecting a return value.
+
+ // It can come in two flavors: Either it is a castable type of no more
+ // than 64 bits. But when returned_value_type is NULL at this point, we
+ // are expecting a pointer to a malloced memory buffer that we will need
+ // to copy.
+
+ tree rvt = returned_value_type ? returned_value_type : UCHAR_P ;
+ returned_value = gg_define_variable(rvt);
// Before doing the call, we save the COBOL program_state:
push_program_state();
- gg_assign(returned_value, gg_cast(returned_value_type, call_expr));
+ gg_assign(returned_value, gg_cast(rvt, call_expr));
// And after the call, we restore it:
pop_program_state();
- // Because the CALL had a RETURNING clause, RETURN-CODE doesn't return a
- // value. So, we make sure it is zero
- cbl_field_t *return_code = cbl_field_of(symbol_at(return_code_register()));
- gg_call(VOID,
+ // Because the CALL had a RETURNING clause, RETURN-CODE doesn't return a
+ // value. So, we make sure it is zero
+ cbl_field_t *return_code = cbl_field_of(symbol_at(return_code_register()));
+ gg_call(VOID,
"__gg__int128_to_field",
5,
gg_get_address_of(return_code->var_decl_node),
@@ -10876,7 +10900,14 @@ parser_call( cbl_refer_t name,
build_int_cst_type(INT, truncation_e),
null_pointer_node );
- if(returned_value_type == CHAR_P)
+ if( returned_value_type == NULL )
+ {
+ // What we got back from the call was a pointer to a malloced memoryb
+ // buffer. We copy that into our target, and then we free that buffer.
+ gg_memcpy(returned_location, returned_value, returned_length);
+ gg_free(returned_value);
+ }
+ else if(returned_value_type == CHAR_P)
{
// The returned value is to a null-terminated string:
IF( returned_value,
diff --git a/gcc/cobol/gengen.h b/gcc/cobol/gengen.h
index 05e5579dcdec41d6acf908b8bab53e27131584b9..1f65ac9dbe234ced38c7ddf612b62fe3c7ed145a 100644
--- a/gcc/cobol/gengen.h
+++ b/gcc/cobol/gengen.h
@@ -119,6 +119,13 @@ enum gg_variable_scope_t {
struct gg_function_t
{
+ // Nomenclature Alert: The "function" in gg_function_t was chosen
+ // originally because a PROGRAM-ID is implemented as a C-style "function",
+ // and there are numerous tree variables that refer to "functions".
+ // Eventually the COBOL compiler grew to handle not just COBOL PROGRAM-ID
+ // "programs", but also user-defined COBOL FUNCTION-ID "functions". This
+ // inevitably is confusing. Sorry about that.
+
// This structure contains state variables for a single function.
const char *our_unmangled_name;
@@ -223,6 +230,10 @@ struct gg_function_t
// back to the first declarative of its immediate parent.
tree first_declarative_section;
+ // is_function is true when this structure is describing a COBOL FUNCTION-ID
+ // and is false for a PROGRAM-ID
+ bool is_function;
+
};
struct cbl_translation_unit_t