diff options
Diffstat (limited to 'gcc/cobol/genapi.cc')
| -rw-r--r-- | gcc/cobol/genapi.cc | 172 |
1 files changed, 67 insertions, 105 deletions
diff --git a/gcc/cobol/genapi.cc b/gcc/cobol/genapi.cc index fdf76aa..e44364a 100644 --- a/gcc/cobol/genapi.cc +++ b/gcc/cobol/genapi.cc @@ -34,6 +34,7 @@ #include "tree-iterator.h" #include "stringpool.h" #include "diagnostic-core.h" +#include "target.h" #include "../../libgcobol/ec.h" #include "../../libgcobol/common-defs.h" @@ -75,7 +76,7 @@ static int pseudo_label = 1; static bool suppress_cobol_entry_point = false; static char ach_cobol_entry_point[256] = ""; -bool bSHOW_PARSE = getenv("SHOW_PARSE"); +bool bSHOW_PARSE = getenv("GCOBOL_SHOW"); bool show_parse_sol = true; int show_parse_indent = 0; @@ -198,7 +199,7 @@ trace1_init() trace_handle = gg_define_variable(INT, "trace_handle", vs_static); trace_indent = gg_define_variable(INT, "trace_indent", vs_static); - bTRACE1 = getenv("TRACE1") ? getenv("TRACE1") : gv_trace_switch; + bTRACE1 = getenv("GCOBOL_TRACE") ? getenv("GCOBOL_TRACE") : gv_trace_switch; if( bTRACE1 && strcmp(bTRACE1, "0") != 0 ) { @@ -1228,7 +1229,40 @@ initialize_variable_internal( cbl_refer_t refer, } else { - TRACE1_FIELD_VALUE("", parsed_var, "") + // Convert strings of spaces to "<SPACES>" + tree spaces = gg_define_int(0); + if( parsed_var->type == FldGroup + || parsed_var->type == FldAlphanumeric + || parsed_var->type == FldAlphaEdited + || parsed_var->type == FldLiteralA ) + { + gg_assign(spaces, integer_one_node); + tree counter = gg_define_int(parsed_var->data.capacity); + WHILE(counter, gt_op, integer_zero_node) + { + gg_decrement(counter); + IF( gg_indirect(member(parsed_var->var_decl_node, "data"), counter), + ne_op, + build_int_cst_type(UCHAR, ' ') ) + { + gg_assign(spaces, integer_zero_node); + } + ELSE + { + } + ENDIF + } + WEND + } + IF(spaces, eq_op, integer_one_node) + { + TRACE1_TEXT(" <SPACES>") + } + ELSE + { + TRACE1_FIELD_VALUE("", parsed_var, "") + } + ENDIF } TRACE1_END } @@ -2357,7 +2391,8 @@ section_label(struct cbl_proc_t *procedure) cbl_label_t *label = procedure->label; // The _initialize_program section isn't relevant. - char *psz = xasprintf("# SECTION %s in %s (%ld)", + char *psz = xasprintf("%s SECTION %s in %s (%ld)", + ASM_COMMENT_START, label->name, current_function->our_unmangled_name, deconflictor); @@ -2408,7 +2443,8 @@ paragraph_label(struct cbl_proc_t *procedure) char *psz1 = xasprintf( - "# PARAGRAPH %s of %s in %s (%ld)", + "%s PARAGRAPH %s of %s in %s (%ld)", + ASM_COMMENT_START, para_name ? para_name: "" , section_name ? section_name: "(null)" , current_function->our_unmangled_name ? current_function->our_unmangled_name: "" , @@ -3006,7 +3042,8 @@ parser_perform(cbl_label_t *label, bool suppress_nexting) para_name = label->name; sect_name = section_label->name; sprintf(ach, - "# PERFORM %s of %s of %s (%ld)", + "%s PERFORM %s of %s of %s (%ld)", + ASM_COMMENT_START, para_name, sect_name, program_name, @@ -3018,7 +3055,8 @@ parser_perform(cbl_label_t *label, bool suppress_nexting) { sect_name = label->name; sprintf(ach, - "# PERFORM %s of %s (%ld)", + "%s PERFORM %s of %s (%ld)", + ASM_COMMENT_START, sect_name, program_name, deconflictor); @@ -3170,8 +3208,8 @@ internal_perform_through( cbl_label_t *proc_1, pseudo_return_push(proc2, return_addr); // Create the code that will launch the first procedure - gg_insert_into_assembler("# PERFORM %s THROUGH %s", - proc_1->name, proc_2->name); + gg_insert_into_assembler("%s PERFORM %s THROUGH %s", + ASM_COMMENT_START, proc_1->name, proc_2->name); if( !suppress_nexting ) { @@ -6632,22 +6670,6 @@ parser_division(cbl_division_t division, } gg_assign(base, gg_cast(UCHAR_P, parameter)); - IF( gg_call_expr( CHAR_P, - "getenv", - gg_string_literal("PARAMETERS_ON_ENTRY"), - NULL_TREE), - ne_op, - gg_cast(CHAR_P, null_pointer_node)); - { - gg_printf("parameter_on_entry: %s(): %d %p\n", - gg_string_literal(current_function->our_unmangled_name), - build_int_cst_type(INT, i+1), - base, - NULL_TREE); - } - ELSE - ENDIF - if( args[i].refer.field->attr & any_length_e ) { // gg_printf("side channel: Length of \"%s\" is %ld\n", @@ -12352,7 +12374,7 @@ create_and_call(size_t narg, // Because the CALL had a RETURNING clause, RETURN-CODE doesn't return a // value. So, we make sure it is zero - gg_assign(var_decl_return_code, build_int_cst_type(SHORT, 0)); +//// gg_assign(var_decl_return_code, build_int_cst_type(SHORT, 0)); if( returned_value_type == CHAR_P ) { @@ -12363,7 +12385,7 @@ create_and_call(size_t narg, gg_add( member(returned.field->var_decl_node, "data"), refer_offset_dest(returned))); gg_assign(returned_length, - refer_size_dest(returned)); + gg_cast(TREE_TYPE(returned_length), refer_size_dest(returned))); // The returned value is a string of nbytes, which by specification // has to be at least as long as the returned_length of the target: @@ -12453,28 +12475,9 @@ create_and_call(size_t narg, } else { - // Because no explicit returning value is expected, we switch to - // the IBM default behavior, where the returned INT value is assigned - // to our RETURN-CODE: - returned_value = gg_define_variable(SHORT); - - // Before doing the call, we save the COBOL program_state: - push_program_state(); - gg_assign(returned_value, gg_cast(SHORT, call_expr)); - // And after the call, we restore it: - pop_program_state(); - - // We know that the returned value is a 2-byte little-endian INT: - gg_assign( var_decl_return_code, - returned_value); - TRACE1 - { - TRACE1_HEADER - gg_printf("returned value: %d", - gg_cast(INT, var_decl_return_code), - NULL_TREE); - TRACE1_END - } + // Because no explicit returning value is expected, we just call it. We + // expect COBOL routines to set RETURN-CODE when they think it necessary. + gg_append_statement(call_expr); } for( size_t i=0; i<narg; i++ ) @@ -13622,7 +13625,7 @@ hijack_for_development(const char *funcname) // Assume that funcname is lowercase with no hyphens enter_program_common(funcname, funcname); parser_display_literal("You have been hijacked by a program named \"dubner\""); - gg_insert_into_assembler("# HIJACKED DUBNER CODE START"); + gg_insert_into_assembler("%s HIJACKED DUBNER CODE START", ASM_COMMENT_START); for(int i=0; i<10; i++) { @@ -13635,7 +13638,7 @@ hijack_for_development(const char *funcname) NULL_TREE); } - gg_insert_into_assembler("# HIJACKED DUBNER CODE END"); + gg_insert_into_assembler("%s HIJACKED DUBNER CODE END", ASM_COMMENT_START); gg_return(0); } @@ -14821,7 +14824,7 @@ mh_source_is_group( cbl_refer_t &destref, tree dbytes = refer_size_dest(destref); tree sbytes = tsrc.length; - IF( sbytes, ge_op, dbytes ) + IF( sbytes, ge_op, gg_cast(TREE_TYPE(sbytes), dbytes) ) { // There are too many source bytes gg_memcpy(tdest, tsource, dbytes); @@ -15871,38 +15874,6 @@ psa_global(cbl_field_t *new_var) sprintf(ach, "__gg__%s", mname); free(mname); - if( getenv("SHOW_GLOBAL_VARIABLES") ) - { - char ach_type[32]; - strcpy(ach_type, cbl_field_type_str(new_var->type)); - - fprintf(stderr, "struct cblc_field_t %s = {\n", ach); - fprintf(stderr, " .data = NULL ,\n" ); - fprintf(stderr, " .capacity = %d ,\n", new_var->data.capacity ); - fprintf(stderr, " .offset = %ld ,\n" , new_var->offset ); - fprintf(stderr, " .name = \"%s\" ,\n" , new_var->name ); - fprintf(stderr, " .picture = \"%s\" ,\n" , new_var->data.picture ? new_var->data.picture : "" ); - if( new_var->data.initial || new_var->type == FldPointer ) - { - fprintf(stderr, " .initial = \"%s\" ,\n" , new_var->data.picture ? new_var->data.picture : "" ); - } - else - { - fprintf(stderr, " .initial = NULL ,\n" ); - } - fprintf(stderr, " .parent = NULL,\n" ); - fprintf(stderr, " .depending_on = NULL ,\n" ); - fprintf(stderr, " .depends_on = NULL ,\n" ); - fprintf(stderr, " .occurs_lower = 0 ,\n" ); - fprintf(stderr, " .occurs_upper = 0 ,\n" ); - fprintf(stderr, " .attr = 0x%lx ,\n" , new_var->attr ); - fprintf(stderr, " .type = %s ,\n" , ach_type); - fprintf(stderr, " .level = %d ,\n" , new_var->level ); - fprintf(stderr, " .digits = %d ,\n" , new_var->data.digits ); - fprintf(stderr, " .rdigits = %d ,\n" , new_var->data.rdigits ); - fprintf(stderr, " };\n"); - } - if( strcmp(new_var->name, "_VERY_TRUE") == 0 ) { new_var->var_decl_node = boolean_true_node; @@ -16183,12 +16154,12 @@ psa_FldLiteralA(struct cbl_field_t *field ) DECL_PRESERVE_P (field->var_decl_node) = 1; nvar += 1; } - TRACE1 - { - TRACE1_INDENT - TRACE1_TEXT("Finished") - TRACE1_END - } +// TRACE1 +// { +// TRACE1_INDENT +// TRACE1_TEXT("Finished") +// TRACE1_END +// } } #endif @@ -16578,24 +16549,15 @@ parser_symbol_add(struct cbl_field_t *new_var ) size_t our_index = new_var->our_index; - // During the early stages of implementing cbl_field_t::our_index, there - // were execution paths in parse.y and parser.cc that resulted in our_index - // not being set. I hereby try to use field_index() to find the index - // of this field to resolve those. I note that field_index does a linear - // search of the symbols[] table to find that index. That's why I don't - // use it routinely; it results in O(N^squared) computational complexity - // to do a linear search of the symbol table for each symbol - if( !our_index && new_var->type != FldLiteralN && !(new_var->attr & intermediate_e)) { - our_index = field_index(new_var); - if( our_index == (size_t)-1 ) - { - // Hmm. Couldn't find it. Seems odd. - our_index = 0; - } + // During the early stages of implementing cbl_field_t::our_index, there + // were execution paths in parse.y and parser.cc that resulted in + // our_index not being set. Those should be gone. + fprintf(stderr, "our_index is NULL under unanticipated circumstances"); + gcc_assert(false); } // When we create the cblc_field_t structure, we need a data pointer @@ -16604,7 +16566,7 @@ parser_symbol_add(struct cbl_field_t *new_var ) // we calculate data as the pointer to our parent's data plus our // offset. - // declare and define the structure. This code *must* match + // Declare and define the structure. This code *must* match // the C structure declared in libgcobol.c. Towards that end, the // variables are declared in descending order of size in order to // make the packing match up. |