diff options
Diffstat (limited to 'gcc/cobol')
| -rw-r--r-- | gcc/cobol/ChangeLog | 48 | ||||
| -rw-r--r-- | gcc/cobol/genapi.cc | 218 | ||||
| -rw-r--r-- | gcc/cobol/gengen.cc | 12 | ||||
| -rw-r--r-- | gcc/cobol/parse.y | 73 | ||||
| -rw-r--r-- | gcc/cobol/parse_ante.h | 3 | ||||
| -rw-r--r-- | gcc/cobol/symbols.cc | 5 | ||||
| -rw-r--r-- | gcc/cobol/symbols.h | 6 | ||||
| -rw-r--r-- | gcc/cobol/symfind.cc | 9 |
8 files changed, 211 insertions, 163 deletions
diff --git a/gcc/cobol/ChangeLog b/gcc/cobol/ChangeLog index 58f9f5e..9f16500 100644 --- a/gcc/cobol/ChangeLog +++ b/gcc/cobol/ChangeLog @@ -1,3 +1,51 @@ +2025-04-04 Bob Dubner <rdubner@symas.com> + + * cobol1.cc: Eliminate cobol_langhook_post_options. + * symbols.cc: Definition of RETURN-CODE special register sets + ::attr member to signable_e. + +2025-04-04 Bob Dubner <rdubner@symas.com> + + * cobol1.cc: (cobol_langhook_post_options): Implemented in order to set + flag_strict_aliasing to zero. + * genapi.cc: (set_user_status): Add comment. + (parser_intrinsic_subst): Expand SHOW_PARSE information. + (psa_global): Change names of return-code and upsi globals, + (psa_FldLiteralA): Set DECL_PRESERVE_P for FldLiteralA. + * gengen.cc: (show_type): Add POINTER type. + (gg_define_function_with_no_parameters): Set DECL_PRESERVE_P for COBOL- + style nested programs. (gg_array_of_bytes): Fix bad cast. + +2025-04-03 Jakub Jelinek <jakub@redhat.com> + + PR cobol/119242 + * genapi.cc (binary_initial_from_float128): Use + native_encode_wide_int. + +2025-04-02 Bob Dubner <rdubner@symas.com> + + PR cobol/119521 + * genapi.cc: (parser_division): Change comment. + (parser_symbol_add): Change intermediate_t handling. + * parse.y: Multiple changes to new_alphanumeric() calls. + * parse_ante.h: Establish named constant for date function + calls. Change declaration of new_alphanumeric() function. + * symbols.cc: (new_temporary_impl): Use named constant + for default size of temporary alphanumerics. + * symbols.h: Establish MAXIMUM_ALPHA_LENGTH constant. + +2025-04-02 Jonathan Wakely <jwakely@redhat.com> + + * symfind.cc (finalize_symbol_map2): Use std::list::remove_if + instead of std::remove_if. + +2025-04-01 Bob Dubner <rdubner@symas.com> + + * genapi.cc: (section_label): Use xasprintf() instead of sprintf(). + (paragraph_label): Likewise. (leave_procedure): Likewise. + (find_procedure): Likewise. (parser_goto): Likewise. + (parser_enter_file): Likewise. + 2025-03-28 Jakub Jelinek <jakub@redhat.com> * Make-lang.in (cobol/charmaps.cc, cobol/valconv.cc): Used sed -e diff --git a/gcc/cobol/genapi.cc b/gcc/cobol/genapi.cc index be463f2..fbe0bbc 100644 --- a/gcc/cobol/genapi.cc +++ b/gcc/cobol/genapi.cc @@ -2354,34 +2354,25 @@ section_label(struct cbl_proc_t *procedure) cbl_label_t *label = procedure->label; // The _initialize_program section isn't relevant. - static size_t psz_length = 256; - static char *psz = (char *)xmalloc(psz_length); - sprintf(psz, - "# SECTION %s in %s (%ld)", - label->name, - current_function->our_unmangled_name, - deconflictor); + char *psz = xasprintf("# SECTION %s in %s (%ld)", + label->name, + current_function->our_unmangled_name, + deconflictor); gg_insert_into_assembler(psz); + free(psz); // The label has to start with an underscore. I tried a period, but those // don't seem to show up in GDB's internal symbol tables. - char *combined = combined_name(procedure->label); - if( psz_length < strlen(combined) + 36 + 1 ) - { - free(psz); - psz_length = strlen(combined) + 36 + 1; - psz = (char *)xmalloc(psz_length); - } - sprintf(psz, - "_sect.%s", - combined_name(procedure->label)); + char *psz2 = xasprintf( "_sect.%s", + combined_name(procedure->label)); SHOW_PARSE { SHOW_PARSE_HEADER - SHOW_PARSE_TEXT(psz); + SHOW_PARSE_TEXT(psz2); SHOW_PARSE_END } - assembler_label(psz); + assembler_label(psz2); + free(psz2); gg_assign(var_decl_nop, build_int_cst_type(INT, 108)); } @@ -2410,40 +2401,32 @@ paragraph_label(struct cbl_proc_t *procedure) char *para_name = paragraph->name; char *section_name = section ? section->name : nullptr; - static size_t psz_length = 256; - static char *psz = (char *)xmalloc(psz_length); - - static size_t deconflictor = symbol_label_id(procedure->label); - - sprintf(psz, + size_t deconflictor = symbol_label_id(procedure->label); + + char *psz1 = + xasprintf( "# PARAGRAPH %s of %s in %s (%ld)", - para_name, - section_name, - current_function->our_unmangled_name, - deconflictor); - gg_insert_into_assembler(psz); + para_name ? para_name: "" , + section_name ? section_name: "(null)" , + current_function->our_unmangled_name ? current_function->our_unmangled_name: "" , + deconflictor ); + + gg_insert_into_assembler(psz1); SHOW_PARSE { SHOW_PARSE_HEADER - SHOW_PARSE_TEXT(psz); + SHOW_PARSE_TEXT(psz1); SHOW_PARSE_END } + free(psz1); // The label has to start with an underscore. I tried a period, but those // don't seem to show up in GDB's internal symbol tables. - char *combined = combined_name(procedure->label); - if( psz_length < strlen(combined) + 36 + 1 ) - { - free(psz); - psz_length = strlen(combined) + 36 + 1; - psz = (char *)xmalloc(psz_length); - } - - sprintf(psz, - "_para.%s", - combined_name(procedure->label)); - assembler_label(psz); + char *psz2 = xasprintf( "_para.%s", + combined_name(procedure->label)); + assembler_label(psz2); + free(psz2); gg_assign(var_decl_nop, build_int_cst_type(INT, 109)); } @@ -2537,11 +2520,11 @@ leave_procedure(struct cbl_proc_t *procedure, bool /*section*/) // new program, or after somebody else has cleared it out. gg_append_statement(procedure->exit.label); - char ach[256]; - sprintf(ach, - "_procret.%ld:", - symbol_label_id(procedure->label)); - gg_insert_into_assembler(ach); + char *psz; + psz = xasprintf("_procret.%ld:", + symbol_label_id(procedure->label)); + gg_insert_into_assembler(psz); + free(psz); pseudo_return_pop(procedure); gg_append_statement(procedure->bottom.label); } @@ -2650,7 +2633,6 @@ find_procedure(cbl_label_t *label) if( !retval ) { static int counter=1; - char ach[2*sizeof(cbl_name_t)]; // This is a new section or paragraph; we need to create its values: retval = (struct cbl_proc_t *)xmalloc(sizeof(struct cbl_proc_t)); @@ -2681,8 +2663,9 @@ find_procedure(cbl_label_t *label) // If this procedure is a paragraph, and it becomes the target of // an ALTER statement, alter_location will be used to make that change - sprintf(ach, "_%s_alter_loc_%d", label->name, counter); - retval->alter_location = gg_define_void_star(ach, vs_static); + char *psz = xasprintf("_%s_alter_loc_%d", label->name, counter); + retval->alter_location = gg_define_void_star(psz, vs_static); + free(psz); DECL_INITIAL(retval->alter_location) = null_pointer_node; counter +=1 ; @@ -2884,10 +2867,10 @@ parser_goto( cbl_refer_t value_ref, size_t narg, cbl_label_t * const labels[] ) // We need to create a static array of pointers to locations: static int comp_gotos = 1; - char ach[32]; - sprintf(ach, "_comp_goto_%d", comp_gotos++); + char *psz = xasprintf("_comp_goto_%d", comp_gotos++); tree array_of_pointers_type = build_array_type_nelts(VOID_P, narg); - tree array_of_pointers = gg_define_variable(array_of_pointers_type, ach, vs_static); + tree array_of_pointers = gg_define_variable(array_of_pointers_type, psz, vs_static); + free(psz); // We have the array. Now we need to build the constructor for it tree constr = make_node(CONSTRUCTOR); @@ -3342,9 +3325,10 @@ parser_enter_file(const char *filename) SHOW_PARSE { SHOW_PARSE_HEADER - char ach[32]; - sprintf(ach, " entering level:%d %s", file_level+1, filename); - SHOW_PARSE_TEXT(ach); + char *psz; + psz = xasprintf(" entering level:%d %s", file_level+1, filename); + SHOW_PARSE_TEXT(psz); + free(psz); SHOW_PARSE_END } @@ -6663,7 +6647,10 @@ parser_division(cbl_division_t division, if( args[i].refer.field->attr & any_length_e ) { - //gg_printf("side channel 0x%lx\n", gg_array_value(var_decl_call_parameter_lengths, rt_i), NULL_TREE); + // gg_printf("side channel: Length of \"%s\" is %ld\n", + // member(args[i].refer.field->var_decl_node, "name"), + // gg_array_value(var_decl_call_parameter_lengths, rt_i), + // NULL_TREE); // Get the length from the global lengths[] side channel. Don't // forget to use the length mask on the table value. @@ -8819,6 +8806,10 @@ static void set_user_status(struct cbl_file_t *file) { // This routine sets the user_status, if any, to the cblc_file_t::status + + // We have to do it this way, because in the case where the file->user_status + // is in linkage, the memory addresses can end up pointing to the wrong + // places if(file->user_status) { cbl_field_t *user_status = cbl_field_of(symbol_at(file->user_status)); @@ -10124,6 +10115,13 @@ parser_intrinsic_subst( cbl_field_t *f, SHOW_PARSE { SHOW_PARSE_HEADER + SHOW_PARSE_FIELD(" TO ", f) + for(size_t i=0; i<argc; i++) + { + SHOW_PARSE_INDENT + SHOW_PARSE_FIELD(" ", argv[i].orig.field) + SHOW_PARSE_FIELD(" ", argv[i].replacement.field) + } SHOW_PARSE_END } TRACE1 @@ -15232,25 +15230,19 @@ binary_initial_from_float128(cbl_field_t *field, int rdigits, FIXED_WIDE_INT(128) i = FIXED_WIDE_INT(128)::from (real_to_integer (&value, &fail, 128), SIGNED); - /* ??? Use native_encode_* below. */ retval = (char *)xmalloc(field->data.capacity); switch(field->data.capacity) { + tree type; case 1: - *(signed char *)retval = (signed char)i.slow (); - break; case 2: - *(signed short *)retval = (signed short)i.slow (); - break; case 4: - *(signed int *)retval = (signed int)i.slow (); - break; case 8: - *(signed long *)retval = (signed long)i.slow (); - break; case 16: - *(unsigned long *)retval = (unsigned long)i.ulow (); - *((signed long *)retval + 1) = (signed long)i.shigh (); + type = build_nonstandard_integer_type (field->data.capacity + * BITS_PER_UNIT, 0); + native_encode_wide_int (type, i, (unsigned char *)retval, + field->data.capacity); break; default: fprintf(stderr, @@ -15927,12 +15919,12 @@ psa_global(cbl_field_t *new_var) if( strcmp(new_var->name, "RETURN-CODE") == 0 ) { - strcpy(ach, "__gg___11_return_code6"); + strcpy(ach, "__gg__return_code"); } if( strcmp(new_var->name, "UPSI-0") == 0 ) { - strcpy(ach, "__gg___6_upsi_04"); + strcpy(ach, "__gg__upsi"); } new_var->var_decl_node = gg_declare_variable(cblc_field_type_node, ach, NULL, vs_external_reference); @@ -16175,6 +16167,10 @@ psa_FldLiteralA(struct cbl_field_t *field ) field->data.initial, NULL_TREE, field->var_decl_node); + TREE_READONLY(field->var_decl_node) = 1; + TREE_USED(field->var_decl_node) = 1; + TREE_STATIC(field->var_decl_node) = 1; + DECL_PRESERVE_P (field->var_decl_node) = 1; nvar += 1; } TRACE1 @@ -16769,55 +16765,47 @@ parser_symbol_add(struct cbl_field_t *new_var ) if( bytes_to_allocate ) { - if( new_var->attr & (intermediate_e) - && new_var->type != FldLiteralN - && new_var->type != FldLiteralA ) + // We need a unique name for the allocated data for this COBOL variable: + char achDataName[256]; + if( new_var->attr & external_e ) { - // We'll malloc() data in initialize_variable - data_area = null_pointer_node; + sprintf(achDataName, "%s", new_var->name); + } + else if( new_var->name[0] == '_' ) + { + // Avoid doubling up on leading underscore + sprintf(achDataName, + "%s_data_%lu", + new_var->name, + sv_data_name_counter++); } else { - // We need a unique name for the allocated data for this COBOL variable: - char achDataName[256]; - if( new_var->attr & external_e ) - { - sprintf(achDataName, "%s", new_var->name); - } - else if( new_var->name[0] == '_' ) - { - // Avoid doubling up on leading underscore - sprintf(achDataName, - "%s_data_%lu", - new_var->name, - sv_data_name_counter++); - } - else - { - sprintf(achDataName, - "_%s_data_%lu", - new_var->name, - sv_data_name_counter++); - } + sprintf(achDataName, + "_%s_data_%lu", + new_var->name, + sv_data_name_counter++); + } - if( new_var->attr & external_e ) - { - tree array_type = build_array_type_nelts(UCHAR, bytes_to_allocate); - new_var->data_decl_node = gg_define_variable( - array_type, - achDataName, - vs_external); - data_area = gg_get_address_of(new_var->data_decl_node); - } - else - { - tree array_type = build_array_type_nelts(UCHAR, bytes_to_allocate); - new_var->data_decl_node = gg_define_variable( - array_type, - achDataName, - vs_static); - data_area = gg_get_address_of(new_var->data_decl_node); - } + if( new_var->attr & external_e ) + { + tree array_type = build_array_type_nelts(UCHAR, bytes_to_allocate); + new_var->data_decl_node = gg_define_variable( + array_type, + achDataName, + vs_external); + data_area = gg_get_address_of(new_var->data_decl_node); + } + else + { + gg_variable_scope_t vs_scope = (new_var->attr & intermediate_e) + ? vs_stack : vs_static ; + tree array_type = build_array_type_nelts(UCHAR, bytes_to_allocate); + new_var->data_decl_node = gg_define_variable( + array_type, + achDataName, + vs_scope); + data_area = gg_get_address_of(new_var->data_decl_node); } } } diff --git a/gcc/cobol/gengen.cc b/gcc/cobol/gengen.cc index ffb64c8..e7a4e3c 100644 --- a/gcc/cobol/gengen.cc +++ b/gcc/cobol/gengen.cc @@ -375,6 +375,10 @@ show_type(tree type) static char ach[1024]; switch( TREE_CODE(type) ) { + case POINTER_TYPE: + sprintf(ach, "POINTER"); + break; + case VOID_TYPE: sprintf(ach, "VOID"); break; @@ -2548,6 +2552,10 @@ gg_define_function_with_no_parameters(tree return_type, DECL_CONTEXT (function_decl) = gg_trans_unit.trans_unit_decl; TREE_PUBLIC(function_decl) = 0; + // This function is file static, but nobody calls it, so without + // intervention -O1+ optimizations will discard it. + DECL_PRESERVE_P (function_decl) = 1; + // Append this function to the list of functions and variables // associated with the computation module. gg_append_var_decl(function_decl); @@ -3358,8 +3366,8 @@ gg_array_of_size_t( size_t N, size_t *values) tree gg_array_of_bytes( size_t N, unsigned char *values) { - tree retval = gg_define_variable(build_pointer_type(UCHAR)); - gg_assign(retval, gg_cast(build_pointer_type(UCHAR), gg_malloc( build_int_cst_type(UCHAR, N * sizeof(unsigned char))))); + tree retval = gg_define_variable(UCHAR_P); + gg_assign(retval, gg_cast(UCHAR_P, gg_malloc( build_int_cst_type(SIZE_T, N * sizeof(unsigned char))))); for(size_t i=0; i<N; i++) { gg_assign(gg_array_value(retval, i), build_int_cst_type(UCHAR, values[i])); diff --git a/gcc/cobol/parse.y b/gcc/cobol/parse.y index 538e56f..3f28201 100644 --- a/gcc/cobol/parse.y +++ b/gcc/cobol/parse.y @@ -9983,7 +9983,7 @@ intrinsic: function_udf } $$ = is_numeric(args[0].field)? new_tempnumeric_float() : - new_alphanumeric(args[0].field->data.capacity); + new_alphanumeric(); parser_intrinsic_callv( $$, intrinsic_cname($1), args.size(), args.data() ); @@ -10013,7 +10013,7 @@ intrinsic: function_udf } | BIT_OF '(' expr[r1] ')' { location_set(@1); - $$ = new_alphanumeric(8 * $r1->field->data.capacity); + $$ = new_alphanumeric(); if( ! intrinsic_call_1($$, BIT_OF, $r1, @r1)) YYERROR; } | CHAR '(' expr[r1] ')' { @@ -10031,27 +10031,24 @@ intrinsic: function_udf | DISPLAY_OF '(' varg[r1] ')' { location_set(@1); - uint32_t len = $r1->field->data.capacity; - $$ = new_alphanumeric(4 * len); + $$ = new_alphanumeric(); if( ! intrinsic_call_2($$, DISPLAY_OF, $r1, NULL) ) YYERROR; } | DISPLAY_OF '(' varg[r1] varg[r2] ')' { location_set(@1); - uint32_t len = $r1->field->data.capacity - + $r2->field->data.capacity; - $$ = new_alphanumeric(4 * len); + $$ = new_alphanumeric(); if( ! intrinsic_call_2($$, DISPLAY_OF, $r1, $r2) ) YYERROR; } | EXCEPTION_FILE filename { location_set(@1); - $$ = new_alphanumeric(256); + $$ = new_alphanumeric(); parser_exception_file( $$, $filename ); } | FIND_STRING '(' varg[r1] last start_after anycase ')' { location_set(@1); - $$ = new_alphanumeric($r1->field->data.capacity); + $$ = new_alphanumeric(); /* auto r1 = new_reference(new_literal(strlen($r1), $r1, quoted_e)); */ cbl_unimplemented("FIND_STRING"); /* if( ! intrinsic_call_4($$, FIND_STRING, r1, $r2) ) YYERROR; */ @@ -10163,7 +10160,7 @@ intrinsic: function_udf | HEX_OF '(' varg[r1] ')' { location_set(@1); - $$ = new_alphanumeric(2 * $r1->field->data.capacity); + $$ = new_alphanumeric(); if( ! intrinsic_call_1($$, HEX_OF, $r1, @r1)) YYERROR; } | LENGTH '(' tableish[val] ')' { @@ -10241,7 +10238,7 @@ intrinsic: function_udf | SUBSTITUTE '(' varg[r1] subst_inputs[inputs] ')' { location_set(@1); - $$ = new_alphanumeric(64); + $$ = new_alphanumeric(); std::vector <cbl_substitute_t> args($inputs->size()); std::transform( $inputs->begin(), $inputs->end(), args.begin(), []( const substitution_t& arg ) { @@ -10284,14 +10281,14 @@ intrinsic: function_udf YYERROR; break; } - $$ = new_alphanumeric($r1->field->data.capacity); + $$ = new_alphanumeric(); cbl_refer_t * how = new_reference($trim_trailing); if( ! intrinsic_call_2($$, TRIM, $r1, how) ) YYERROR; } | USUBSTR '(' alpha_val[r1] expr[r2] expr[r3] ')' { location_set(@1); - $$ = new_alphanumeric(32); // how long? + $$ = new_alphanumeric(); if( ! intrinsic_call_3($$, FORMATTED_DATETIME, $r1, $r2, $r3) ) YYERROR; } @@ -10316,7 +10313,7 @@ intrinsic: function_udf auto type = intrinsic_return_type($1); switch(type) { case FldAlphanumeric: - $$ = new_alphanumeric($r1->field->data.capacity); + $$ = new_alphanumeric(); break; default: if( $1 == NUMVAL || $1 == NUMVAL_F ) @@ -10352,7 +10349,7 @@ intrinsic: function_udf static auto one = new cbl_refer_t( new_literal("1") ); static auto four = new cbl_refer_t( new_literal("4") ); cbl_span_t year(one, four); - auto r3 = new_reference(new_alphanumeric(21)); + auto r3 = new_reference(new_alphanumeric(MAXLENGTH_CALENDAR_DATE)); r3->refmod = year; parser_intrinsic_call_0( r3->field, "__gg__current_date" ); @@ -10368,7 +10365,7 @@ intrinsic: function_udf static auto one = new cbl_refer_t( new_literal("1") ); static auto four = new cbl_refer_t( new_literal("4") ); cbl_span_t year(one, four); - auto r3 = new_reference(new_alphanumeric(21)); + auto r3 = new_reference(new_alphanumeric(MAXLENGTH_CALENDAR_DATE)); r3->refmod = year; parser_intrinsic_call_0( r3->field, "__gg__current_date" ); @@ -10394,7 +10391,7 @@ intrinsic: function_udf static auto one = new cbl_refer_t( new_literal("1") ); static auto four = new cbl_refer_t( new_literal("4") ); cbl_span_t year(one, four); - auto r3 = new_reference(new_alphanumeric(21)); + auto r3 = new_reference(new_alphanumeric(MAXLENGTH_CALENDAR_DATE)); r3->refmod = year; parser_intrinsic_call_0( r3->field, "__gg__current_date" ); @@ -10410,7 +10407,7 @@ intrinsic: function_udf static auto one = new cbl_refer_t( new_literal("1") ); static auto four = new cbl_refer_t( new_literal("4") ); cbl_span_t year(one, four); - auto r3 = new_reference(new_alphanumeric(21)); + auto r3 = new_reference(new_alphanumeric(MAXLENGTH_CALENDAR_DATE)); r3->refmod = year; parser_intrinsic_call_0( r3->field, "__gg__current_date" ); @@ -10436,7 +10433,7 @@ intrinsic: function_udf static auto one = new cbl_refer_t( new_literal("1") ); static auto four = new cbl_refer_t( new_literal("4") ); cbl_span_t year(one, four); - auto r3 = new_reference(new_alphanumeric(21)); + auto r3 = new_reference(new_alphanumeric(MAXLENGTH_CALENDAR_DATE)); r3->refmod = year; parser_intrinsic_call_0( r3->field, "__gg__current_date" ); @@ -10452,7 +10449,7 @@ intrinsic: function_udf static auto one = new cbl_refer_t( new_literal("1") ); static auto four = new cbl_refer_t( new_literal("4") ); cbl_span_t year(one, four); - auto r3 = new_reference(new_alphanumeric(21)); + auto r3 = new_reference(new_alphanumeric(MAXLENGTH_CALENDAR_DATE)); r3->refmod = year; parser_intrinsic_call_0( r3->field, "__gg__current_date" ); @@ -10492,7 +10489,7 @@ intrinsic: function_udf | intrinsic_X2 '(' varg[r1] varg[r2] ')' { location_set(@1); - $$ = new_alphanumeric($r1->field->data.capacity); + $$ = new_alphanumeric(); if( ! intrinsic_call_2($$, $1, $r1, $r2) ) YYERROR; } | intrinsic_locale @@ -10540,54 +10537,54 @@ intrinsic_locale: LOCALE_COMPARE '(' varg[r1] varg[r2] ')' { location_set(@1); - $$ = new_alphanumeric($r1->field->data.capacity); + $$ = new_alphanumeric(); cbl_refer_t dummy = {}; if( ! intrinsic_call_3($$, LOCALE_COMPARE, $r1, $r2, &dummy) ) YYERROR; } | LOCALE_COMPARE '(' varg[r1] varg[r2] varg[r3] ')' { location_set(@1); - $$ = new_alphanumeric($r1->field->data.capacity); + $$ = new_alphanumeric(); if( ! intrinsic_call_3($$, LOCALE_COMPARE, $r1, $r2, $r3) ) YYERROR; } | LOCALE_DATE '(' varg[r1] ')' { location_set(@1); - $$ = new_alphanumeric($r1->field->data.capacity); + $$ = new_alphanumeric(); cbl_refer_t dummy = {}; if( ! intrinsic_call_2($$, LOCALE_DATE, $r1, &dummy) ) YYERROR; } | LOCALE_DATE '(' varg[r1] varg[r2] ')' { location_set(@1); - $$ = new_alphanumeric($r1->field->data.capacity); + $$ = new_alphanumeric(); if( ! intrinsic_call_2($$, LOCALE_DATE, $r1, $r2) ) YYERROR; } | LOCALE_TIME '(' varg[r1] ')' { location_set(@1); - $$ = new_alphanumeric($r1->field->data.capacity); + $$ = new_alphanumeric(); cbl_refer_t dummy = {}; if( ! intrinsic_call_2($$, LOCALE_TIME, $r1, &dummy) ) YYERROR; } | LOCALE_TIME '(' varg[r1] varg[r2] ')' { location_set(@1); - $$ = new_alphanumeric($r1->field->data.capacity); + $$ = new_alphanumeric(); if( ! intrinsic_call_2($$, LOCALE_TIME, $r1, $r2) ) YYERROR; } | LOCALE_TIME_FROM_SECONDS '(' varg[r1] ')' { location_set(@1); - $$ = new_alphanumeric($r1->field->data.capacity); + $$ = new_alphanumeric(); cbl_refer_t dummy = {}; if( ! intrinsic_call_2($$, LOCALE_TIME_FROM_SECONDS, $r1, &dummy) ) YYERROR; } | LOCALE_TIME_FROM_SECONDS '(' varg[r1] varg[r2] ')' { location_set(@1); - $$ = new_alphanumeric($r1->field->data.capacity); + $$ = new_alphanumeric(); if( ! intrinsic_call_2($$, LOCALE_TIME_FROM_SECONDS, $r1, $r2) ) YYERROR; } ; @@ -10603,7 +10600,7 @@ trim_trailing: %empty { $$ = new_literal("0"); } // Remove both intrinsic0: CURRENT_DATE { location_set(@1); - $$ = new_alphanumeric(21); + $$ = new_alphanumeric(MAXLENGTH_CALENDAR_DATE); parser_intrinsic_call_0( $$, "__gg__current_date" ); } | E { @@ -10614,33 +10611,33 @@ intrinsic0: CURRENT_DATE { | EXCEPTION_FILE_N { location_set(@1); - $$ = new_alphanumeric(256); + $$ = new_alphanumeric(); intrinsic_call_0( $$, EXCEPTION_FILE_N ); } | EXCEPTION_FILE { location_set(@1); - $$ = new_alphanumeric(256); + $$ = new_alphanumeric(); parser_exception_file( $$ ); } | EXCEPTION_LOCATION_N { location_set(@1); - $$ = new_alphanumeric(256); + $$ = new_alphanumeric(); intrinsic_call_0( $$, EXCEPTION_LOCATION_N ); } | EXCEPTION_LOCATION { location_set(@1); - $$ = new_alphanumeric(256); + $$ = new_alphanumeric(); intrinsic_call_0( $$, EXCEPTION_LOCATION ); } | EXCEPTION_STATEMENT { location_set(@1); - $$ = new_alphanumeric(63); + $$ = new_alphanumeric(); intrinsic_call_0( $$, EXCEPTION_STATEMENT ); } | EXCEPTION_STATUS { location_set(@1); - $$ = new_alphanumeric(31); + $$ = new_alphanumeric(); intrinsic_call_0( $$, EXCEPTION_STATUS ); } @@ -10656,12 +10653,12 @@ intrinsic0: CURRENT_DATE { } | UUID4 { location_set(@1); - $$ = new_alphanumeric(32); // don't know correct size + $$ = new_alphanumeric(); parser_intrinsic_call_0( $$, "__gg__uuid4" ); } | WHEN_COMPILED { location_set(@1); - $$ = new_alphanumeric(21); // Returns YYYYMMDDhhmmssss-0500 + $$ = new_alphanumeric(MAXLENGTH_CALENDAR_DATE); // Returns YYYYMMDDhhmmssss-0500 parser_intrinsic_call_0( $$, "__gg__when_compiled" ); } ; diff --git a/gcc/cobol/parse_ante.h b/gcc/cobol/parse_ante.h index 8ae51c5..aa36628 100644 --- a/gcc/cobol/parse_ante.h +++ b/gcc/cobol/parse_ante.h @@ -41,6 +41,7 @@ #define MAXLENGTH_FORMATTED_DATE 10 #define MAXLENGTH_FORMATTED_TIME 19 +#define MAXLENGTH_CALENDAR_DATE 21 #define MAXLENGTH_FORMATTED_DATETIME 30 #pragma GCC diagnostic push @@ -220,7 +221,7 @@ namcpy(const YYLTYPE& loc, cbl_name_t tgt, const char *src ) { } cbl_field_t * -new_alphanumeric( size_t capacity ); +new_alphanumeric( size_t capacity = MAXIMUM_ALPHA_LENGTH ); static inline cbl_refer_t * new_reference( enum cbl_field_type_t type, const char *initial ) { diff --git a/gcc/cobol/symbols.cc b/gcc/cobol/symbols.cc index a4fc82c..5043125 100644 --- a/gcc/cobol/symbols.cc +++ b/gcc/cobol/symbols.cc @@ -2350,7 +2350,7 @@ symbol_table_init(void) { 0, {}, {2,2,2,0, NULL}, NULL }, { 0, FldNumericBin5, FldInvalid, 0, 0, 0, 0, nonarray, 0, "UPSI-0", 0, {}, {2,2,4,0, NULL}, NULL }, - { 0, FldNumericBin5, FldInvalid, 0, 0, 0, 0, nonarray, 0, "RETURN-CODE", + { 0, FldNumericBin5, FldInvalid, signable_e, 0, 0, 0, nonarray, 0, "RETURN-CODE", 0, {}, {2,2,4,0, NULL}, NULL }, { 0, FldNumericBin5, FldInvalid, 0, 0, 0, 0, nonarray, 0, "LINAGE-COUNTER", 0, {}, {2,2,4,0, NULL}, NULL }, @@ -3237,7 +3237,8 @@ new_temporary_impl( enum cbl_field_type_t type ) 0, FldAlphanumeric, FldInvalid, intermediate_e, 0, 0, 0, nonarray, 0, "", 0, cbl_field_t::linkage_t(), - {}, NULL }; + {MAXIMUM_ALPHA_LENGTH, MAXIMUM_ALPHA_LENGTH, + 0, 0, NULL}, NULL }; static const struct cbl_field_t empty_float = { 0, FldFloat, FldInvalid, intermediate_e, diff --git a/gcc/cobol/symbols.h b/gcc/cobol/symbols.h index d5acf16..c231763 100644 --- a/gcc/cobol/symbols.h +++ b/gcc/cobol/symbols.h @@ -224,6 +224,12 @@ enum symbol_type_t { SymDataSection, }; +// The ISO specification says alphanumeric literals have a maximum length of +// 8,191 characters. It seems to be silent on the length of alphanumeric data +// items. Our implementation requires a maximum length, so we chose to make it +// the same. +#define MAXIMUM_ALPHA_LENGTH 8192 + struct cbl_field_data_t { uint32_t memsize; // nonzero if larger subsequent redefining field uint32_t capacity, // allocated space diff --git a/gcc/cobol/symfind.cc b/gcc/cobol/symfind.cc index 2687fdb..8995715 100644 --- a/gcc/cobol/symfind.cc +++ b/gcc/cobol/symfind.cc @@ -128,11 +128,10 @@ finalize_symbol_map2() { for( auto& elem : symbol_map2 ) { auto& fields( elem.second ); - std::remove_if( fields.begin(), fields.end(), - []( auto isym ) { - auto f = cbl_field_of(symbol_at(isym)); - return f->type == FldInvalid; - } ); + fields.remove_if( []( auto isym ) { + auto f = cbl_field_of(symbol_at(isym)); + return f->type == FldInvalid; + } ); if( fields.empty() ) empties.insert(elem.first); } |