From: Robert Dubner Date: Fri, 29 May 2026 13:43:07 +0000 (-0400) Subject: cobol: Speed improvements; function prototypes; POSIX compatibility. X-Git-Url: http://git.ipfire.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=cc432cc1fc03dffe134d52a03bf709c38590cc12;p=thirdparty%2Fgcc.git cobol: Speed improvements; function prototypes; POSIX compatibility. 1) The execution speed of ADD N TO VAR and SUBTRACT N FROM VAR where N is an integer in the range -9 through +9 and VAR is of type Numeric Display is improved through specialized code in genmath.cc 2) The execution speed of FILE READ of line-sequential files is improved by using a 64K read buffer. 3) COBOL function prototypes are implemented. 4) These changes include the beginning of implementing the POSIX compatibility layer. 5) Added the ability to detect GOTO_EXPR that lack matching LABEL_EXPR. Co-authored-by: Robert Dubner Co-authored-by: James K. Lowden Co-authored-by: Xavier Del Campo gcc/cobol/ChangeLog: * Make-lang.in: Include gcobc script. * cdf.y: Change formal parameters of cdf_literalize(). * cobol1.cc (cobol_langhook_handle_option): Add OPT_ftrunc option. * compare.cc (total_digits_tree): Remove debugging statements. (float_compare): Likewise. * copybook.h (class copybook_elem_t): Update conditional close(). * dts.h: Change copyright notice. * gcobc: Likewise. * gcobol.1: Likewise. * gcobol.3: Likewise. * gcobolspec.cc (COMPAT_LIBRARY): POSIX compatibility. (POSIX_LIBRARY): Likewise. (lang_specific_driver): Likewise. * genapi.cc (section_label): Missing LABEL_EXPR detection. (paragraph_label): Likewise. (internal_perform_through): Likewise. (enter_program_common): Add comment. (parser_enter_program): Change current_program_index() handling. (build_alter_switch): Missing LABEL_EXPR detection. (parser_display_internal): Handle REFER_T_ADDRESS_OF flag. (create_and_call): ADDRESS OF is passed BY VALUE. * gengen.cc (LOOK_FOR_MISSING_LABELS_not): Missing LABEL_EXPR detection. (dump_missing_labels): Likewise. (gg_append_statement): Likewise. (gg_struct_field_ref): Likewise. (LABEL_ROOT): Likewise. (gg_create_goto_pair): Likewise. (scm_dump_generic_nodes): Forward declaration. (gg_leaving_the_source_code_file): Missing LABEL_EXPR detection. (label_decl_text_from_expr): New function. * gengen.h (gg_create_assembler_name): New declaration. (label_decl_text_from_expr): New declaration. * genmath.cc (uchar_f_node): Fast ADD N TO NUMERIC-DISPLAY. (uchar_ten_node): Likewise. (fast_add): Likewise. (fast_subtract): Likewise. (parser_add): Likewise. (add_floats): Likewise. (ordinary_add_format_1): Likewise. (ordinary_subtract_format_1): Likewise. (add_case_1): Likewise. (add_case_2): Likewise. (add_case_3): Likewise. (parser_multiply): Likewise. (add_case_4): Likewise. (add_litN_to_numdisp): Likewise. (add_format_1): Likewise. (add_format_2): Likewise. (add_format_3): Likewise. (subtract_floats): Likewise. (subtract_format_1): Likewise. (subtract_format_2): Likewise. (subtract_format_3): Likewise. (parser_subtract): Likewise. * genutil.cc (refer_has_depends): False when type == FldIndex. * lang-specs.h: Add fdefaultbyte, fstatic-call, ftrunc. * lang.opt: Add ftrunc. * lexio.cc (cdftext::open_input): Improved error message. * parse.y: CDF support, POSIX support. * parse_ante.h (cbl_division_t): Different enum. (mode_syntax_only): New implementation of syntax_only. (parse_error_inc): Likewise. (resume_parsing): Likewise. (successful_parse): Likewise. (name_of): Formal parameter is now const. (nice_name_of): Likewise. (ast_op): Chanage formal parameters. (prototype_ok): COBOL function prototypes. (struct prototype_type_t): Likewise. (is_allowed_name): Likewise. (prototype_add): Likewise. (prototype_args): Likewise. (verify_args): Likewise. (valid_pointer_relop): New function. (field_value_all): Eliminate. (current_field): COBOL function prototypes. (ast_enter_exit_section): Improved error messages. (data_division_ready): Improved mode_syntax_only. (file_section_fd_set): Change "return false" to "return 0". (ast_end_program): Improved mode_syntax_only. * scan_ante.h (symbol_function_token): Use symbol_function_any(). (symbol_exists): Change for() loop termination. (typed_name): COBOL function prototypes. * structs.cc: Support for buffered FILE READ. * symbols.cc (symbol_field_location): Use field_locs[] map. (symbol_table_extend): Likewise. (is_prototypical): COBOL function prototypes. (symbol_elem_cmp): Likewise. (symbol_program): Likewise. (struct symbol_elem_t): Likewise. (symbol_function): Likewise. (enum protoreq_t): Likewise. (symbol_function_impl): Likewise. (struct cbl_label_t): Likewise. (symbol_function_any): Likewise. (symbols_dump): Likewise. (cbl_field_t::attr_str): Likewise. (field_str): Likewise. (symbols_update): Likewise. (symbol_field_add): Likewise. (symbol_field_same_as): Likewise. (cbl_alphabet_t::reencode): Detect iconv() errors. (symbol_program_add): COBOL function prototypes. * symbols.h (enum dspc_t): Enum for Division, Section, Paragraph, Clause. (cbl_prototype_ok): COBOL function prototypes. (valid_move): Handle strong typing. (struct parameter_t): Improved function parameter handling. (struct cbl_ffi_arg_t): Likewise. (struct cbl_label_t): COBOL function prototypes. (struct function_descr_t): Likewise. (struct cbl_alphabet_t): Detect iconv() errors. (struct cbl_file_t): Support for LINAGE and the like. (prototype_args):COBOL function prototypes. (is_prototypical):COBOL function prototypes. (is_numeric): Refmods are not numeric. (struct symbol_elem_t): Additional declarations. * symfind.cc (update_symbol_map2): Use symbols map. * token_names.h: New comment. * util.cc (cbl_prototype_ok): COBOL function prototypes. (cdf_literalize): New formal parameters. (effective_type): New function. (valid_move): Handle strong typing. (cobol_trunc_binary): Handle new ftrunc option. (parse_error_reset): Forward declaration. (parse_file): Formatting. * util.h (cobol_trunc_binary): New declaration. libgcobol/ChangeLog: * Makefile.am: Add AM_COBC and AM_COBFLAGS; update toolexeclib_LTLIBRARIES with libgcobol_posix.la and libgcobol_compat_gnu.la. * Makefile.in: POSIX compatibility support. * aclocal.m4: Regenerate. * charmaps.cc (__gg__iconverter): Restore map of encoding pairs. (__gg__get_charmap): Change how encodings are mapped. * charmaps.h (CHARMAPS_H): Include #include . (DEFAULT_32_ENCODING): Wrap in __FreeBSD__ conditional. (error_msg_direct): Wrap in IN_TARGET_LIBS. (class cbl_iconv_t): Wrapper for iconv() calls. (class charmap_t): Explicit constructor. * compat/README.md: POSIX compatibility layer. * compat/gnu/lib/CBL_ALLOC_MEM.cbl: Likewise. * compat/gnu/lib/CBL_CHECK_FILE_EXIST.cbl: Likewise. * compat/gnu/lib/CBL_DELETE_FILE.cbl: Likewise. * compat/gnu/lib/CBL_FREE_MEM.cbl: Likewise. * compat/gnu/udf/stored-char-length.cbl: Likewise. * compat/t/Makefile: Likewise. * compat/t/smoke.cbl: Likewise. * configure: Regenerate. * configure.ac: New macros * configure.tgt: Likewise. * ec.h (enum ec_type_t): New implementor-defined ec_imp_iconv_open_e exception. * encodings.h (_ENCODINGS_H_): #include for mapping the cbl_encoding_t values. (struct cbl_encoding_t_hash): Likewise. * exceptl.h (ec_type_of): Remove "extern" from declaration. * gcobolio.h (FILE_BUFFER_SIZE): READ FILE buffer size. * gfileio.cc (sequential_file_write): Honor non-ascii encodings. (line_sequential_file_read): Buffered FILE READ. (line_sequential_file_read_sbc): Buffered FILE READ. * intrinsic.cc (string_to_dest): Eliminate function. (get_all_time): Replace __gg__convert_encoding() with __gg__iconverter(). (__gg__when_compiled): Likewise. * io.cc (__compat_file_status_word): POSIX compatibility layer. * io.h (enum file_high_t): Likewise. (enum file_status_t): Likewise. * libgcobol.cc (init_var_both): Eliminate call to initialize_program_state(). (__gg__move): Eliminate call to __gg__convert_encoding_length; handle REFER_T_ADDRESS_OF. (display_both): Handle REFER_T_ADDRESS_OF. (__gg__display_clean): Likewise. (__gg__convert_encoding): Eliminate function. (__gg__convert_encoding_length): Likewise. (default_exception_handler): Improve exception handling. (ec_type_descr): Likewise. (ec_type_disposition): Likewise. (ec_is_fatal): Likewise. (__gg__check_fatal_exception): Likewise. (__gg__set_env_value): Remove call to __gg__convert_encoding. * libgcobol.h (__gg__convert_encoding): Eliminate. (__gg__convert_encoding_length): Eliminate. * posix/bin/udf-gen: POSIX compatibility. * posix/cpy/posix-errno.cbl: Likewise. * posix/cpy/psx-lseek.cpy: Likewise. * posix/cpy/psx-open.cpy: Likewise. * posix/cpy/statbuf.cpy: Likewise. * posix/cpy/tm.cpy: Likewise. * posix/shim/lseek.cc (offsetof): Likewise. (posix_lseek): Likewise. * posix/shim/open.cc (posix_open): Likewise. * posix/t/errno.cbl: Likewise. * posix/t/exit.cbl: Likewise. * posix/t/localtime.cbl: Likewise. * posix/t/stat.cbl: Likewise. * posix/udf/posix-exit.cbl: Likewise. * posix/udf/posix-ftruncate.cbl: Likewise. * posix/udf/posix-localtime.cbl: Likewise. * posix/udf/posix-lseek.cbl: Likewise. * posix/udf/posix-mkdir.cbl: Likewise. * posix/udf/posix-open.cbl: Likewise. * posix/udf/posix-read.cbl: Likewise. * posix/udf/posix-stat.cbl: Likewise. * posix/udf/posix-unlink.cbl: Likewise. * posix/udf/posix-write.cbl: Likewise. * valconv.cc: New exceptions. * compat/gnu/cpy/cblproto.cpy: New file. * compat/gnu/cpy/cbltypes.cpy: New file. * compat/gnu/cpy/stored-char-length.cpy: New file. * compat/gnu/lib/CBL_CLOSE_FILE.cbl: New file. * compat/gnu/lib/CBL_CREATE_FILE.cbl: New file. * compat/gnu/lib/CBL_OPEN_FILE.cbl: New file. * compat/gnu/lib/CBL_READ_FILE.cbl: New file. * compat/gnu/lib/CBL_WRITE_FILE.cbl: New file. * compat/gnu/lib/cbl_alloc_mem.3: New file. * compat/gnu/lib/cbl_alloc_mem.cbl3: New file. * compat/gnu/lib/cbl_check_file_exist.3: New file. * compat/gnu/lib/cbl_close_file.3: New file. * compat/gnu/lib/cbl_create_file.3: New file. * compat/gnu/lib/cbl_delete_file.3: New file. * compat/gnu/lib/cbl_free_mem.3: New file. * compat/gnu/lib/cbl_open_file.3: New file. * compat/gnu/lib/cbl_read_file.3: New file. * compat/gnu/lib/cbl_write_file.3: New file. * compat/gnu/udf/cobrt-file-status.cbl: New file. * posix/cpy/posix-close.cpy: New file. * posix/cpy/posix-errno.cpy: New file. * posix/cpy/posix-exit.cpy: New file. * posix/cpy/posix-fstat.cpy: New file. * posix/cpy/posix-ftruncate.cpy: New file. * posix/cpy/posix-localtime.cpy: New file. * posix/cpy/posix-lseek.cpy: New file. * posix/cpy/posix-mkdir.cpy: New file. * posix/cpy/posix-open.cpy: New file. * posix/cpy/posix-read.cpy: New file. * posix/cpy/posix-stat.cpy: New file. * posix/cpy/posix-unlink.cpy: New file. * posix/cpy/posix-write.cpy: New file. * posix/shim/fstat.cc: New file. * posix/udf/posix-close.cbl: New file. * posix/udf/posix-errno.cbl: New file. * posix/udf/posix-fstat.cbl: New file. gcc/testsuite/ChangeLog: * cobol.dg/group2/37-digit_Initialization_of_fundamental_types.cob: Updated compiler error message. * cobol.dg/group2/BINARY_and_COMP-5.cob: Likewise. * cobol.dg/group2/Check_for_equality_of_COMP-1___COMP-2.cob: Likewise. * cobol.dg/group2/Multi-target_MOVE_with_subscript_re-evaluation.cob: Likewise. * cobol.dg/group2/Named_conditionals_-_fixed__float__and_alphabetic.cob: Likewise. * cobol.dg/group2/Simple_p-scaling.cob: Likewise. * cobol.dg/group2/access_to_OPTIONAL_LINKAGE_item_not_passed.cob: Likewise. * cobol.dg/group2/compare_national_to_display.cob: Likewise. * cobol.dg/group2/comprensive_compare_comp-1_comp-5.cob: Likewise. * cobol.dg/group2/CBL_ALLOC_MEM___CBL_FREE_MEM.cob: New test. * cobol.dg/group2/CBL_ALLOC_MEM___CBL_FREE_MEM.out: New test. * cobol.dg/group2/CBL_CHECK_FILE_EXIST.cob: New test. * cobol.dg/group2/CBL_CHECK_FILE_EXIST.out: New test. * cobol.dg/group2/CBL_CREATE_FILE___CBL_WRITE_FILE___CBL_CLOSE_FILE.cob: New test. * cobol.dg/group2/CBL_DELETE_FILE.cob: New test. * cobol.dg/group2/CBL_DELETE_FILE.out: New test. * cobol.dg/group2/CBL_OPEN_FILE___CBL_CLOSE_FILE.cob: New test. * cobol.dg/group2/CBL_OPEN_FILE___CBL_CLOSE_FILE.out: New test. * cobol.dg/group2/CBL_OPEN_FILE___CBL_READ_FILE___CBL_CLOSE_FILE.cob: New test. * cobol.dg/group2/CBL_OPEN_FILE___CBL_READ_FILE___CBL_CLOSE_FILE.out: New test. * cobol.dg/group2/CBL_READ_FILE__check_file_size_with_flags___128.cob: New test. * cobol.dg/group2/Complex_HEX__VALUE_and_MOVE_-_UTF-16.cob: New test. * cobol.dg/group2/Complex_HEX__VALUE_and_MOVE_-_UTF-16.out: New test. * cobol.dg/group2/MOVE_LEVEL_78.cob: New test. * cobol.dg/group2/MOVE_LEVEL_78.out: New test. * cobol.dg/group2/add_-1_to_negative_pic_S9999.cob: New test. * cobol.dg/group2/add_-1_to_negative_pic_S9999.out: New test. * cobol.dg/group2/add_-1_to_pic_9999.cob: New test. * cobol.dg/group2/add_-1_to_pic_9999.out: New test. * cobol.dg/group2/add_-1_to_positive_pic_S9999.cob: New test. * cobol.dg/group2/add_-1_to_positive_pic_S9999.out: New test. * cobol.dg/group2/add_1_to_pic_9999.cob: New test. * cobol.dg/group2/add_1_to_pic_9999.out: New test. * cobol.dg/group2/add_1_to_positive_pic_S9999.cob: New test. * cobol.dg/group2/add_1_to_positive_pic_S9999.out: New test. * cobol.dg/group2/add__1_to_negative_pic_S9999.cob: New test. * cobol.dg/group2/add__1_to_negative_pic_S9999.out: New test. * cobol.dg/group2/ambiguous_PERFORM.cob: New test. * cobol.dg/group2/ambiguous_PERFORM.out: New test. * cobol.dg/group2/cbltypes.cpy: New test. * cobol.dg/group2/compare_float_to_other_types.cob: New test. * cobol.dg/group2/compare_float_to_other_types.out: New test. * cobol.dg/group2/move_numeric_to_alphanumeric.cob: New test. * cobol.dg/group2/move_numeric_to_alphanumeric.out: New test. --- diff --git a/gcc/cobol/Make-lang.in b/gcc/cobol/Make-lang.in index f890ea1075a..637cf753e56 100644 --- a/gcc/cobol/Make-lang.in +++ b/gcc/cobol/Make-lang.in @@ -165,7 +165,6 @@ cobol/scan.cc: cobol/scan.l $(FLEX) -o$@ $(LFLAGS) $< 2>$@~ || { cat $@~ >&1; exit 1; } awk '! /$(FLEX_WARNING)/ {print > "/dev/stderr"; nerr++} \ END {print "$(FLEX):", NR, "messages" > "/dev/stderr"}' $@~ - @rm $@~ # To establish prerequisites for parse.o, cdf.o, and scan.o, @@ -244,6 +243,14 @@ cobol/scan.o: cobol/scan.cc \ cobol/cdf.cc \ cobol/parse.cc +# As opposed to other objects, gcobc is a shell script and therefore +# is only installed. In other words,no build step is necessary. +# However, some tests rely on gcobc being available from the build tree. +gcobc$(exeext): $(srcdir)/cobol/gcobc + cp $< $@ + +cobol: gcobc$(exeext) + # Update token names if the generator script is installed # (by a developer) and there's been a change. $(srcdir)/cobol/token_names.h: cobol/parse.cc diff --git a/gcc/cobol/cdf.y b/gcc/cobol/cdf.y index e4f69b1627c..967952538d1 100644 --- a/gcc/cobol/cdf.y +++ b/gcc/cobol/cdf.y @@ -154,8 +154,8 @@ void input_file_status_notify(); cdfval_t negate( cdfval_base_t lhs ); cbl_field_t - cdf_literalize( const std::string& name, const cdfval_t& value ); - + cdf_literalize( const cbl_loc_t& loc, + const std::string& name, const cdfval_t& value, bool init = true ); } %{ @@ -359,7 +359,7 @@ cdf_define: CDF_DEFINE cdf_constant NAME as cdf_expr[value] override YYERROR; } if( symbols_begin() < symbols_end() ) { - cbl_field_t field = cdf_literalize($NAME, $value); + cbl_field_t field = cdf_literalize(@NAME, $NAME, $value); symbol_field_add(current_program_index(), &field); } diff --git a/gcc/cobol/cobol1.cc b/gcc/cobol/cobol1.cc index 3bdda333d01..bf60b0b664e 100644 --- a/gcc/cobol/cobol1.cc +++ b/gcc/cobol/cobol1.cc @@ -412,6 +412,10 @@ cobol_langhook_handle_option (size_t scode, } return true; + case OPT_ftrunc: + cobol_trunc_binary(cobol_trunc_bin); + return true; + case OPT_M: cobol_set_pp_option('M'); return true; diff --git a/gcc/cobol/compare.cc b/gcc/cobol/compare.cc index 77dcbb11347..f1e4713aa02 100644 --- a/gcc/cobol/compare.cc +++ b/gcc/cobol/compare.cc @@ -301,9 +301,6 @@ total_digits_tree( tree &left_rdigits, right_side.field->data.digits))); } - // gg_printf("KILROY LEFT %d\n", left_rdigits, NULL_TREE); - // gg_printf("KILROY RIGHT %d\n", right_rdigits, NULL_TREE); - // We can reduce the two rdigits values by the common portion of both. This // will leave one of them at zero IF( left_rdigits, gt_op, right_rdigits ) @@ -1294,11 +1291,6 @@ float_compare(tree &left, right = gg_define_variable(type); gg_assign(right, gg_cast(type, rightv)); -// gg_printf("KILROY %f %f\n", -// gg_cast(DOUBLE, left), -// gg_cast(DOUBLE, right), -// NULL_TREE); - if( right_side.field->attr & intermediate_e ) { tree rdigits = gg_define_variable(INT); diff --git a/gcc/cobol/copybook.h b/gcc/cobol/copybook.h index 2b3f0a20534..bead78eef74 100644 --- a/gcc/cobol/copybook.h +++ b/gcc/cobol/copybook.h @@ -83,7 +83,7 @@ class copybook_elem_t { void clear() { suppress = false; nsubexpr = 0; - if( fd ) close(fd); + if( fd >= 0 ) close(fd); fd = -1; // TODO: free src & tgt replacements.clear(); diff --git a/gcc/cobol/dts.h b/gcc/cobol/dts.h index c900c4515a7..3b444dcb83b 100644 --- a/gcc/cobol/dts.h +++ b/gcc/cobol/dts.h @@ -1,5 +1,35 @@ /* - * Contributed to the public domain by James K. Lowden + * + * Copyright (c) 2021-2026 Symas Corporation + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are + * met: + * + * * Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * * Redistributions in binary form must reproduce the above + * copyright notice, this list of conditions and the following disclaimer + * in the documentation and/or other materials provided with the + * distribution. + * * Neither the name of the Symas Corporation nor the names of its + * contributors may be used to endorse or promote products derived from + * this software without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + * A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + * OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + * LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + */ + +/* Contributed by James K. Lowden * Tuesday October 17, 2023 * * This stand-in for std::regex was written because the implementation provided diff --git a/gcc/cobol/gcobc b/gcc/cobol/gcobc index 049f91836fb..8bc78f79aaf 100755 --- a/gcc/cobol/gcobc +++ b/gcc/cobol/gcobc @@ -1,8 +1,34 @@ #! /bin/sh -e # -# COPYRIGHT -# The gcobc program is in public domain. +# Copyright (c) 2021-2026 Symas Corporation +# +# Redistribution and use in source and binary forms, with or without +# modification, are permitted provided that the following conditions are +# met: +# +# * Redistributions of source code must retain the above copyright +# notice, this list of conditions and the following disclaimer. +# * Redistributions in binary form must reproduce the above +# copyright notice, this list of conditions and the following disclaimer +# in the documentation and/or other materials provided with the +# distribution. +# * Neither the name of the Symas Corporation nor the names of its +# contributors may be used to endorse or promote products derived from +# this software without specific prior written permission. +# +# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +# "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +# LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +# A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +# OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +# SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +# LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +# DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +# THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +# (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +# OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +# # If it breaks then you get to keep both pieces. # # This file emulates the GnuCOBOL cobc compiler to a limited degree. @@ -207,10 +233,12 @@ do -echo) echo="echo" ;; - -fec=* | -fno-ec=*) + -fec=*) opt="$(echo "$opt" | sed -E 's/-f(no-)?ec=/-f\1cobol-exceptions=EC-/g')" opts="$opts $opt" ;; + -fno-ec=*) + ;; # just ignore for now to work around "sorry unimplemented" errors -ext) pending_arg="-copyext " ;; @@ -423,11 +451,13 @@ do # # Options that may have a space before the argument, or not # - -I | -L | -MF | -MT ) + # Note that -B is not supported as per cobc syntax, but it might + # still be required by gcc users. + -B | -I | -L | -MF | -MT ) pending_arg=$opt ;; # no-space version: just concatenate - -I* | -L* | -MF* | -MT* ) + -B* | -I* | -L* | -MF* | -MT* ) opts="$opts $opt" ;; @@ -467,7 +497,7 @@ do -std=mf | -std=mf-strict) dialect=mf ;; # GnuCOBOL's default and GCC's dialect for GnuCOBOL - -std=default) dialect=gnu + -std=default) dialect="mf gnu" ;; # GCC COBOL targets COBOL2024 "mostly backward to COBOL85" -std=cobol*) dialect="" @@ -497,7 +527,9 @@ do # opts="$opts --version" ;; # pass through, strangely -Wall is not supported - -w | -W | -Wextra) opts="$opts $opt" + # note that cobc does not support gcc's -Wl options, but they + # might be passed anyway for different reasons e.g.: -Wl,rpath. + -w | -W | -Wextra | -Wl,*) opts="$opts $opt" ;; -Wno-*) no_warn "$opt" ;; @@ -549,7 +581,7 @@ fi if [ "$echo" ] then - echo $gcobol $mode $opts + echo $gcobol $mode $dialect $opts exit fi diff --git a/gcc/cobol/gcobol.1 b/gcc/cobol/gcobol.1 index d574f7f888c..2fed7b713ce 100644 --- a/gcc/cobol/gcobol.1 +++ b/gcc/cobol/gcobol.1 @@ -1,7 +1,7 @@ .ds lang COBOL .ds gcobol GCC\ \*[lang]\ Front-end .ds isostd ISO/IEC 1989:2023 -.Dd \& February 2025 +.Dd \& May 2026 .Dt GCOBOL 1\& "GCC \*[lang] Compiler" .Os Linux .Sh NAME @@ -24,9 +24,10 @@ .Op Fl fcobol-exceptions Ar exception Ns Op Ns \/, Ns Ar exception Ns ... .Op Fl copyext Ar ext .Op Fl ffixed-form | Fl ffree-form -.Op Fl findicator-column +.Op Fl findicator-column Ns Ar column .Op Fl fexec-charset= Ns Ar encoding .Op Fl fexec-national-charset= Ns Ar encoding +.Op Fl fno-trunc .ig .Op Fl collseq Ar encoding Ns \/, Fl ncolseq Ar encoding .. @@ -358,7 +359,20 @@ is an encoding name as defined by .Xr iconv 3 . To use an EBCDIC encoding for data items, one might use .D1 Fl fexec-national-charset= Ns Li CP1140 -for example. +for example. +.It Fl fno-trunc +Affects +.Sy BINARY +data-items. +For arithmetic assignment and +.Sy MOVE , +limit the value to the number of digits specified in the +.Sy PICTURE , +not the capacity that the size of the binary storage would otherwise allow. +Truncation happens from the left, meaning that +.D1 77 RECEIVER PICTURE 9(3). +.D1 MOVE 1000 TO RECEIVER. +results in 0, not 100. . .It Fl dialect Ar dialect-name By default, @@ -799,7 +813,7 @@ alphanumeric literal, or a data item. .Pp .Nm -supports static linking where possible, unless defeated by +uses static linking unless defeated by .Fl fno-static-call . If the parameter value is known at compile time, the compiler produces an external reference to be resolved by the linker. The referenced @@ -876,8 +890,7 @@ ends with a call to .Xr abort 3 and process termination. .Pp -Not all Exception Conditions are implemented. Any attempt to enable -an EC that that is not implemented produces a warning message. +Not all Exception Conditions are implemented. The following are implemented: .Pp .Bl -tag -offset 5n -compact @@ -1077,6 +1090,62 @@ or Name of the start element tag or empty element tag. .El . +.Ss MicroFocus and GnuCOBOL Runtime Library +GnuCOBOL emulates some of the +.Dq "runtime library" +functions defined originally by MicroFocus COBOL (now owned by Rocket Software). +.Nm +includes a library, +.Pa libgcobol-compat-gnu , +that +.Dq "emulates the emulation" , +i.e., mimic the GnuCOBOL implementation. This version includes these functions: +.Bl -tag -compact +.It Sy CBL_ALLOC_MEM +.It Sy CBL_CHECK_FILE_EXIST +.It Sy CBL_CLOSE_FILE +.It Sy CBL_CREATE_FILE +.It Sy CBL_DELETE_FILE +.It Sy CBL_FREE_MEM +.It Sy CBL_OPEN_FILE +.It Sy CBL_READ_FILE +.It Sy CBL_WRITE_FILE +.El +These functions are implemented in COBOL as User Defined Functions. +They are documented in man pages included with this distribution of +.Nm . +. +.Ss POSIX Bindings +To facilitate access to POSIX functions (in particular for the above +compatibility functions), +.Nm +includes +.Pa libgcobol-posix.so . +This library is written in COBOL as User Defined Functions. The +following functions are included: +.Bl -tag -compact +.It Sy posix-close +.It Sy posix-exit +.It Sy posix-fstat +.It Sy posix-ftruncate +.It Sy posix-localtime +.It Sy posix-lseek +.It Sy posix-mkdir +.It Sy posix-open +.It Sy posix-read +.It Sy posix-stat +.It Sy posix-unlink +.It Sy posix-write +.El +These functions have the same signature as defined by POSIX: the same +parameters, and the same return status. If a string is NUL-terminated +according to POSIX, the COBOL functions accept ordinary COBOL +.Sy "PIC X" +data-items, and supply the NUL as needed. +.Pp +The POSIX bindings are not documented separately on the theory that +the POSIX definition suffices. +. .Sh ISO \*[lang] Implementation Status .Ss USAGE Data Types .Nm @@ -1232,7 +1301,7 @@ suite has been identified. . .Ss CDF Text Manipulation .Bl -tag -width >>DEFINE -.It Sy COPY Ar copybook Li Oo OF|BY Ar library Oc Oo Sy REPLACING ... Oc +.It Sy COPY Ar copybook Li Oo OF|IN Ar library Oc Oo Sy REPLACING ... Oc If .Ar copybook is a literal, it treated a literal filename, which either does or does not exist. If @@ -1996,4 +2065,34 @@ are not compatible with that of any other \*[lang] compiler. Enhancements to the I/O support will be readily available to the paying customer. .El . +.Sh COPYRIGHT +.Bd -unfilled -indent +Copyright (c) 2021-2026 Symas Corporation + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + +* Redistributions of source code must retain the above copyright +notice, this list of conditions and the following disclaimer. +* Redistributions in binary form must reproduce the above +copyright notice, this list of conditions and the following disclaimer +in the documentation and/or other materials provided with the +distribution. +* Neither the name of the Symas Corporation nor the names of its +contributors may be used to endorse or promote products derived from +this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +.Ed .\" .Sh BUGS diff --git a/gcc/cobol/gcobol.3 b/gcc/cobol/gcobol.3 index adc141a7aad..516529507ad 100644 --- a/gcc/cobol/gcobol.3 +++ b/gcc/cobol/gcobol.3 @@ -326,3 +326,33 @@ structure is to allow the use of other I/O implementations with other ODF repres The library is not well tested, not least because it is not implemented. .Sh BUGS The future is yet to come. +.Sh COPYRIGHT +.Bd -unfilled -indent +Copyright (c) 2021-2026 Symas Corporation + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + +* Redistributions of source code must retain the above copyright +notice, this list of conditions and the following disclaimer. +* Redistributions in binary form must reproduce the above +copyright notice, this list of conditions and the following disclaimer +in the documentation and/or other materials provided with the +distribution. +* Neither the name of the Symas Corporation nor the names of its +contributors may be used to endorse or promote products derived from +this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +.Ed diff --git a/gcc/cobol/gcobolspec.cc b/gcc/cobol/gcobolspec.cc index 899bf0cb0d7..c28173c4185 100644 --- a/gcc/cobol/gcobolspec.cc +++ b/gcc/cobol/gcobolspec.cc @@ -69,6 +69,14 @@ int lang_specific_extra_outfiles = 0; #define COBOL_LIBRARY "gcobol" #endif +#ifndef COMPAT_LIBRARY +#define COMPAT_LIBRARY "gcobol_compat_gnu" +#endif + +#ifndef POSIX_LIBRARY +#define POSIX_LIBRARY "gcobol_posix" +#endif + #define SPEC_FILE "libgcobol.spec" /* The original argument list and related info is copied here. */ @@ -78,6 +86,8 @@ static const struct cl_decoded_option *original_options; static std::vectornew_opt; static bool need_libgcobol = true; +static bool need_libcompat = false; // This one need for dialect mf or ibm +static bool need_libposix = false; // #define NOISY 1 @@ -160,6 +170,8 @@ lang_specific_driver (struct cl_decoded_option **in_decoded_options, // Separate flags for a couple of static libraries bool static_libgcobol = false; + bool static_libcompat = false; + bool static_libposix = false; bool static_in_general = false; /* WEIRDNESS ALERT: @@ -350,6 +362,16 @@ lang_specific_driver (struct cl_decoded_option **in_decoded_options, cool facility for handling --help and --verbose --help. */ return; + case OPT_dialect: + if( strstr(decoded_options[i].arg, "ibm") + || strstr(decoded_options[i].arg, "mf") ) + { + need_libcompat = true; + // libcompat depends on libposix. + need_libposix = true; + } + break; + default: break; } @@ -485,6 +507,11 @@ lang_specific_driver (struct cl_decoded_option **in_decoded_options, } } + char dir_separator[] = {DIR_SEPARATOR, 0}, + *tooldir = concat (STANDARD_EXEC_PREFIX, DEFAULT_TARGET_MACHINE, + dir_separator, DEFAULT_TARGET_VERSION, + dir_separator, "cobol", NULL); + /* As described above, we have empirically noticed that when the command line explicitly specifies libgcobol.a as an input, a following -lgcobol causes the "on exit" functions of the library to be executed twice. This can @@ -514,6 +541,24 @@ lang_specific_driver (struct cl_decoded_option **in_decoded_options, { add_arg_lib(COBOL_LIBRARY, static_libgcobol); } + if( need_libcompat ) + { + char *gnu = concat(tooldir, dir_separator, "compat", dir_separator, "gnu", NULL); + add_arg_lib(COMPAT_LIBRARY, static_libcompat); + + // Inject the installation prefix paths to the libcompat copybooks. + // Note that these paths are inevitably leaked as append_option + // takes a const char *, but does not copy the string. + // Ideally, these paths could be constructed at preprocessor-time, + // but unfortunately DIR_SEPARATOR defines an integer, not a string. + // Maybe a DIR_SEPARATOR-like macro could be defined instead, but that + // can be fragile in terms of portability, and the usual practice in + // gcc is to dynamically define it as a 2-element array, anyway. + append_option(OPT_I, concat(gnu, dir_separator, "lib", NULL), 1); + append_option(OPT_I, concat(gnu, dir_separator, "cpy", NULL), 1); + append_option(OPT_I, concat(gnu, dir_separator, "udf", NULL), 1); + free(gnu); + } if( need_libdl ) { add_arg_lib(DL_LIBRARY, false); @@ -522,6 +567,17 @@ lang_specific_driver (struct cl_decoded_option **in_decoded_options, { add_arg_lib(STDCPP_LIBRARY, false); } + if( need_libposix ) + { + char *posix = concat(tooldir, dir_separator, "posix", NULL); + + add_arg_lib(POSIX_LIBRARY, static_libposix); + // Inject the paths to the libposix copybooks. + // As explained above, note that these paths are inevitably leaked. + append_option(OPT_I, concat(posix, dir_separator, "cpy", NULL), 1); + append_option(OPT_I, concat(posix, dir_separator, "udf", NULL), 1); + free(posix); + } if( prior_main ) { @@ -529,6 +585,8 @@ lang_specific_driver (struct cl_decoded_option **in_decoded_options, fatal_error(input_location, "%s", ach); } + free(tooldir); + // We now take the new_opt vector, and turn it into an array of // cl_decoded_option diff --git a/gcc/cobol/genapi.cc b/gcc/cobol/genapi.cc index ea28bdaf776..32865f82946 100644 --- a/gcc/cobol/genapi.cc +++ b/gcc/cobol/genapi.cc @@ -2081,6 +2081,12 @@ section_label(struct cbl_proc_t *procedure) // Go see if there was an ALTER statement targeting this procedure gg_append_statement(procedure->alter_switch_goto); // Lay down the label we will return to if there is no ALTER in play +#if 0 + fprintf(stderr, + "section_label for %s %s\n", + procedure->label->name, + label_decl_text_from_expr(procedure->no_alter_label)); +#endif gg_append_statement(procedure->no_alter_label); } @@ -2159,6 +2165,12 @@ paragraph_label(struct cbl_proc_t *procedure) // Go see if there was an ALTER statement targeting this procedure gg_append_statement(procedure->alter_switch_goto); // Lay down the label we will return to if there is no ALTER in play +#if 0 + fprintf(stderr, + "paragraph_label for %s %s\n", + procedure->label->name, + label_decl_text_from_expr(procedure->no_alter_label)); +#endif gg_append_statement(procedure->no_alter_label); } @@ -2746,14 +2758,20 @@ internal_perform_through( cbl_label_t *proc_1, size_t dispatch_index = proc2->pseudo_return_decls.size(); - // We need to create the unnamed return address that we + // We need to create the return address that we // will instantiate right after the goto: + + static int id = 1; + char *psz; + psz = xasprintf("_perfret%d", id++); + tree return_address_decl = build_decl( UNKNOWN_LOCATION, LABEL_DECL, - NULL_TREE, + gg_create_assembler_name(psz), void_type_node); DECL_CONTEXT(return_address_decl) = current_function->function_decl; TREE_USED(return_address_decl) = 1; + free(psz); tree return_label_expr = build1(LABEL_EXPR, void_type_node, @@ -3147,8 +3165,11 @@ enter_program_common(const char *funcname, const char *funcname_) trace1_init(); } -/* Creates a function for program-id 'funcname_'. Returns 1 when funcname_ - is "main" and the -main compiler switch is active for this moudle */ +/* Creates a function for program-id 'funcname_'. Returns 1 when funcname_ is + "main" and the -main compiler switch is active for this moudle symbol_table + has been initialized, and the current program has been entered into it. For + a top-level program, the program's program is 0, else it is the symbol + table index of the containing program. */ void parser_enter_program( const char *funcname_, @@ -3163,7 +3184,10 @@ parser_enter_program( const char *funcname_, char *mangled_name = cobol_name_mangler(funcname_); - size_t parent_index = current_program_index(); + size_t iprog = current_program_index(); + assert(iprog); + + size_t parent_index = symbol_at(iprog)->program; char *funcname; if( parent_index ) { @@ -3398,6 +3422,13 @@ build_alter_switch(cbl_proc_t *proc, const std::vector &label_decls) // And follow up with a goto expression for the pseudo-return location. if( i == 0 ) { +#if 0 + fprintf(stderr, + "build_alter_switch(1) for %s %s %p\n", + proc->label->name, + label_decl_text_from_expr(proc->no_alter_goto), + (void *)GOTO_DESTINATION(proc->no_alter_goto)); +#endif gg_append_statement(proc->no_alter_goto); } else @@ -3419,8 +3450,14 @@ build_alter_switch(cbl_proc_t *proc, const std::vector &label_decls) current_function->statement_list_stack.pop_back(); } +#if 0 + fprintf(stderr, + "build_alter_switch(2) for %s %s %p\n", + proc->label->name, + label_decl_text_from_expr(proc->no_alter_goto), + (void *)GOTO_DESTINATION(proc->no_alter_goto)); +#endif gg_append_statement(proc->no_alter_goto); - } static void @@ -5065,13 +5102,15 @@ parser_display_internal(tree file_descriptor, } else { + int flags = advance ? 1 : 0; + flags |= refer.addr_of ? REFER_T_ADDRESS_OF : 0; if( refer_is_clean(refer) ) { gg_call(VOID, "__gg__display_clean", gg_get_address_of(refer.field->var_decl_node), file_descriptor, - advance ? integer_one_node : integer_zero_node, + build_int_cst_type(INT, flags), NULL_TREE ); } else @@ -5087,7 +5126,7 @@ parser_display_internal(tree file_descriptor, refer_offset(refer), refer_size_source( refer), file_descriptor, - advance ? integer_one_node : integer_zero_node, + build_int_cst_type(INT, flags), NULL_TREE ); if( refer.refmod.from || refer.refmod.len ) { @@ -13112,6 +13151,13 @@ create_and_call(size_t narg, if( args[i].refer.field && args[i].refer.field->type == FldLiteralN ) { + // Literals have to be passed by value + crv = by_value_e; + } + + if( args[i].attr == address_of_e || args[i].refer.addr_of ) + { + // ADDRESS OF has to be passed by value. crv = by_value_e; } @@ -13232,12 +13278,20 @@ create_and_call(size_t narg, // For BY VALUE, we take whatever we've been given and do our best to // make a 64-bit value out of it, although we move to 128 bits when // necessary. - switch(args[i].attr) + + cbl_ffi_arg_attr_t attr = args[i].attr; + if( args[i].refer.addr_of ) + { + attr = address_of_e; + } + + switch(attr) { case address_of_e: { arguments[i] = gg_define_size_t(); gg_assign(arguments[i], gg_cast(SIZE_T, location )); + gg_assign(length, build_int_cst_type(SIZE_T, 8)); break; } @@ -13245,6 +13299,7 @@ create_and_call(size_t narg, { arguments[i] = gg_define_size_t(); gg_assign(arguments[i], gg_cast(SIZE_T, length)); + gg_assign(length, build_int_cst_type(SIZE_T, 8)); break; } @@ -13283,6 +13338,7 @@ create_and_call(size_t narg, refer_offset(args[i].refer), refer_size_source(args[i].refer), NULL_TREE))); + gg_assign(length, build_int_cst_type(SIZE_T, 16)); } else { @@ -13296,6 +13352,7 @@ create_and_call(size_t narg, refer_offset(args[i].refer), refer_size_source(args[i].refer), NULL_TREE))); + gg_assign(length, build_int_cst_type(SIZE_T, 8)); } break; } @@ -13306,7 +13363,7 @@ create_and_call(size_t narg, // variable. This value is used both to handle ANY LENGTH formal // parameters, and to provide information to the called program when being // passed expressions BY VALUE and BY CONTENT - gg_assign(gg_array_value(var_decl_call_parameter_lengths, i),length); + gg_assign(gg_array_value(var_decl_call_parameter_lengths, i), length); } // Let the called program know how many parameters we are passing @@ -13314,6 +13371,7 @@ create_and_call(size_t narg, build_int_cst_type(INT, narg)); tree call_expr = NULL_TREE; + if( function_pointer ) { gg_assign(var_decl_call_parameter_signature, diff --git a/gcc/cobol/gengen.cc b/gcc/cobol/gengen.cc index 6a19ac6a2e1..71d8177466a 100644 --- a/gcc/cobol/gengen.cc +++ b/gcc/cobol/gengen.cc @@ -265,6 +265,34 @@ gg_append_var_decl(tree var_decl) } } +#define LOOK_FOR_MISSING_LABELS_not +#ifdef LOOK_FOR_MISSING_LABELS +static std::set missing_labels; +static std::map missing_gotos; +void +dump_missing_labels() + { + for(auto g : missing_gotos) + { + auto l = missing_labels.find(g.first); + if( l == missing_labels.end() ) + { + const char *name_text = label_decl_text_from_expr(g.first); + error_msg_direct( "% %qs (%p) " + "at line %d has no matching label", + name_text, + reinterpret_cast(g.first), + g.second); + } + } + } +#else +void +dump_missing_labels() + { + } +#endif + void gg_append_statement(tree stmt) { @@ -295,10 +323,46 @@ gg_append_statement(tree stmt) // ./libcpp/include/line-map.h // ./libcpp/location-example.txt -#if 0 +#ifdef LOOK_FOR_MISSING_LABELS + const char *name_text = label_decl_text_from_expr(stmt); if( TREE_CODE(stmt) == GOTO_EXPR ) { - fprintf(stderr, "Laying down a GOTO\n"); + // When dump_missing_labels reports a name, you can edit it in here and + // recompile, and then set a trap here to backtrace to whoever is creating + // the orphan goto in the first place. + + if( strcmp(name_text, "") == 0 ) + { + fprintf(stderr, "HULL_BREACH! Label %s!\n", name_text); + } + + tree dest = GOTO_DESTINATION (stmt); + + tree label_decl = NULL_TREE; + if (TREE_CODE (dest) == LABEL_DECL) + { + label_decl = dest; /* direct goto label */ + } + else + { + /* computed goto or other expression-valued destination */ + } + //fprintf(stderr, + // "Laying down a GOTO_EXPR %s %p at line %d\n", + // name_text, + // reinterpret_cast(label_decl), + // cobol_location().first_line); + missing_gotos[label_decl] = cobol_location().first_line; + } + if( TREE_CODE(stmt) == LABEL_EXPR ) + { + tree label_decl = LABEL_EXPR_LABEL(stmt); /* This is a LABEL_DECL. */ + //fprintf(stderr, + // "Laying down a LABEL_EXPR %s %p at line %d\n", + // name_text, + // reinterpret_cast(label_decl), + // cobol_location().first_line); + missing_labels.insert(label_decl); } #endif @@ -704,7 +768,7 @@ gg_struct_field_ref(const tree base, const char *field) return retval; } -static tree +tree gg_create_assembler_name(const char *cobol_name) { char *psz = cobol_name_mangler(cobol_name); @@ -1796,6 +1860,9 @@ gg_build_logical_expression(tree operand_a, return logical_expression; } +static int label_identifier = 1; +#define LABEL_ROOT "_label%d" + void gg_create_goto_pair(tree *goto_expr, tree *label_expr, @@ -1805,9 +1872,19 @@ gg_create_goto_pair(tree *goto_expr, // We are going to create a pair of expressions for our // caller. They are a matched set of goto/label expressions, // to be included in a statement list + char *psz; + if(name && *name) + { + psz = xstrdup(name); + } + else + { + psz = xasprintf(LABEL_ROOT, label_identifier++); + } + tree label_decl = build_decl( UNKNOWN_LOCATION, LABEL_DECL, - gg_create_assembler_name(name), + gg_create_assembler_name(psz), void_type_node); DECL_CONTEXT(label_decl) = current_function->function_decl; TREE_USED(label_decl) = 1; @@ -1819,6 +1896,7 @@ gg_create_goto_pair(tree *goto_expr, *goto_expr = build1(GOTO_EXPR, void_type_node, label_decl); *label_expr = build1(LABEL_EXPR, void_type_node, label_decl); *label_addr = gg_get_address_of(label_decl); + free(psz); } void @@ -1827,9 +1905,11 @@ gg_create_goto_pair(tree *goto_expr, tree *label_expr, tree *label_addr) // We are going to create a pair of expressions for our // caller. They are a matched set of goto/label expressions, // to be included in a statement list + char *psz; + psz = xasprintf(LABEL_ROOT, label_identifier++); tree label_decl = build_decl( UNKNOWN_LOCATION, LABEL_DECL, - NULL_TREE, + gg_create_assembler_name(psz), void_type_node); DECL_CONTEXT(label_decl) = current_function->function_decl; TREE_USED(label_decl) = 1; @@ -1837,6 +1917,7 @@ gg_create_goto_pair(tree *goto_expr, tree *label_expr, tree *label_addr) *goto_expr = build1(GOTO_EXPR, void_type_node, label_decl); *label_expr = build1(LABEL_EXPR, void_type_node, label_decl); *label_addr = gg_get_address_of(label_decl); + free(psz); } void @@ -1848,9 +1929,11 @@ gg_create_goto_pair(tree *goto_expr, // We are going to create a pair of expressions for our // caller. They are a matched set of goto/label expressions, // to be included in a statement list + char *psz; + psz = xasprintf(LABEL_ROOT, label_identifier++); *label_decl = build_decl( UNKNOWN_LOCATION, LABEL_DECL, - NULL_TREE, + gg_create_assembler_name(psz), void_type_node); DECL_CONTEXT(*label_decl) = current_function->function_decl; TREE_USED(*label_decl) = 1; @@ -1858,6 +1941,7 @@ gg_create_goto_pair(tree *goto_expr, *goto_expr = build1(GOTO_EXPR, void_type_node, *label_decl); *label_expr = build1(LABEL_EXPR, void_type_node, *label_decl); *label_addr = gg_get_address_of(*label_decl); + free(psz); } void @@ -1866,15 +1950,18 @@ gg_create_goto_pair(tree *goto_expr, tree *label_expr) // We are going to create a pair of expressions for our // caller. They are a matched set of goto/label expressions, // to be included in a statement list + char *psz; + psz = xasprintf(LABEL_ROOT, label_identifier++); tree label_decl = build_decl( UNKNOWN_LOCATION, LABEL_DECL, - NULL_TREE, + gg_create_assembler_name(psz), void_type_node); DECL_CONTEXT(label_decl) = current_function->function_decl; TREE_USED(label_decl) = 1; *goto_expr = build1(GOTO_EXPR, void_type_node, label_decl); *label_expr = build1(LABEL_EXPR, void_type_node, label_decl); + free(psz); } void @@ -1883,15 +1970,25 @@ gg_create_goto_pair(tree *goto_expr, tree *label_expr, const char *name) // We are going to create a pair of named expressions for our // caller. They are a matched set of goto/label expressions, // to be included in a statement list + char *psz; + if(name && *name) + { + psz = xstrdup(name); + } + else + { + psz = xasprintf(LABEL_ROOT, label_identifier++); + } tree label_decl = build_decl( UNKNOWN_LOCATION, LABEL_DECL, - gg_create_assembler_name(name), + gg_create_assembler_name(psz), void_type_node); DECL_CONTEXT(label_decl) = current_function->function_decl; TREE_USED(label_decl) = 1; *goto_expr = build1(GOTO_EXPR, void_type_node, label_decl); *label_expr = build1(LABEL_EXPR, void_type_node, label_decl); + free(psz); } void @@ -2861,16 +2958,19 @@ gg_finalize_function() gg_trans_unit.function_stack.pop_back(); } +void scm_dump_generic_nodes(const char *filename, tree root); + void gg_leaving_the_source_code_file() { - for( std::vector::const_iterator it=finalized_function_decls.begin(); - it != finalized_function_decls.end(); - it++ ) + typedef std::vector::value_type func_type; + for( const func_type& func : finalized_function_decls ) { //This makes the function visible on the source code module level. - cgraph_node::finalize_function(*it, true); + cgraph_node::finalize_function(func, true); } + + dump_missing_labels(); } void @@ -3434,3 +3534,61 @@ gg_token_location() } return retval; } + +const char * +label_decl_text_from_expr(tree expr) + { + // This extracts the LABEL_DECL text from GOTO_EXPR and LABEL_EXPR + tree label_decl = NULL_TREE; + + if(expr == NULL_TREE) + { + return "missing"; + } + + switch(TREE_CODE (expr)) + { + case LABEL_DECL: + label_decl = expr; + break; + + case LABEL_EXPR: + label_decl = LABEL_EXPR_LABEL(expr); + break; + + case GOTO_EXPR: + { + tree dest = GOTO_DESTINATION(expr); + + if (dest != NULL_TREE && TREE_CODE (dest) == LABEL_DECL) + { + label_decl = dest; + } + else if (dest != NULL_TREE + && TREE_CODE(dest) == ADDR_EXPR + && TREE_OPERAND(dest, 0) != NULL_TREE + && TREE_CODE(TREE_OPERAND(dest, 0)) == LABEL_DECL) + { + label_decl = TREE_OPERAND(dest, 0); + } + break; + } + + default: + return "missing"; + } + + if( label_decl == NULL_TREE || TREE_CODE (label_decl) != LABEL_DECL ) + { + return "missing"; + } + + tree name = DECL_NAME (label_decl); + if( name == NULL_TREE || TREE_CODE (name) != IDENTIFIER_NODE ) + { + return "missing"; + } + + const char *text = IDENTIFIER_POINTER(name); + return text ? text : "missing"; + } diff --git a/gcc/cobol/gengen.h b/gcc/cobol/gengen.h index 336bf2ef1d9..4126321bb26 100644 --- a/gcc/cobol/gengen.h +++ b/gcc/cobol/gengen.h @@ -588,5 +588,7 @@ extern void gg_insert_into_assemblerf(const char *format, ...) ATTRIBUTE_PRINTF_ extern char *gg_show_type(tree type); extern void gg_leaving_the_source_code_file(); +extern tree gg_create_assembler_name(const char *cobol_name); +extern const char * label_decl_text_from_expr(tree expr); #endif diff --git a/gcc/cobol/genmath.cc b/gcc/cobol/genmath.cc index 7a39f87ab7a..3b1c3b74e0b 100644 --- a/gcc/cobol/genmath.cc +++ b/gcc/cobol/genmath.cc @@ -45,6 +45,13 @@ #include "../../libgcobol/charmaps.h" #include "show_parse.h" +// These are convenience values used by the ADD 1 TO routines. I am putting +// them here rather than cluttering up subroutine calls with them. +#define uchar_f_node build_int_cst_type(UCHAR, 0x0F) +#define uchar_ten_node build_int_cst_type(UCHAR, 10) +static tree tzero; // '0' in ascii or ebcdic +static tree tnine; + void set_up_on_exception_label(cbl_label_t *arithmetic_label) { @@ -391,7 +398,9 @@ largest_binary_term(size_t nA, cbl_refer_t *A) static bool fast_add( size_t nC, cbl_num_result_t *C, size_t nA, cbl_refer_t *A, - cbl_arith_format_t format ) + cbl_arith_format_t format, + const cbl_label_t *error, + const cbl_label_t *not_error) { /* ADD A TO D: nC==1, nA==1, D += A. ADD A B C TO D: nC==1, nA==3, D = (A + B + C) @@ -400,7 +409,9 @@ fast_add( size_t nC, cbl_num_result_t *C, ADD A B C TO D GIVING X Y nC==2, nA==3, format==giving_e */ bool retval = false; if( all_results_integer(nC, C) - && all_refers_integer(nA, A) ) + && all_refers_integer(nA, A) + && !error + && !not_error ) { Analyze(); // All targets are non-PICTURE binaries: @@ -409,9 +420,6 @@ fast_add( size_t nC, cbl_num_result_t *C, { tree dest_type = tree_type_from_size(C[0].refer.field->data.capacity(), 0); -// tree dest_type2 = TREE_TYPE(C[0].refer.field->data_decl_node); -// gcc_assert(dest_type2 == dest_type); - // All the numbers are integers without rdigits if( nC == 1 && nA == 1 @@ -580,7 +588,9 @@ static bool fast_subtract(size_t nC, cbl_num_result_t *C, size_t nA, cbl_refer_t *A, size_t nB, cbl_refer_t *B, - cbl_arith_format_t format) + cbl_arith_format_t format, + const cbl_label_t *error, + const cbl_label_t *not_error) { /* SUBTRACT A FROM D: nC==1, nA==1, nB==0: D -= A. SUBTRACT A B C FROM D: nC==1, nA==3, nB==0: D -= (A + B + C) @@ -590,7 +600,10 @@ fast_subtract(size_t nC, cbl_num_result_t *C, bool retval = false; if( all_refers_integer(nA, A) && all_refers_integer(nB, B) - && all_results_integer(nC, C) ) + && all_results_integer(nC, C) + && !error + && !not_error + ) { Analyze(); // All targets are non-PICTURE binaries: @@ -926,336 +939,1314 @@ fast_divide(size_t nC, cbl_num_result_t *C, return retval; } -void -parser_add( size_t nC, cbl_num_result_t *C, +static bool +add_floats( size_t nC, cbl_num_result_t *C, size_t nA, cbl_refer_t *A, cbl_arith_format_t format, cbl_label_t *error, cbl_label_t *not_error, - void *compute_error_p ) // Cast this to a tree / int * + tree compute_error ) { - Analyze(); - SHOW_PARSE - { - SHOW_PARSE_HEADER - fprintf(stderr, " A[" HOST_SIZE_T_PRINT_DEC "]:", (fmt_size_t)nA); - for(size_t i=0; i 0) - { - fprintf(stderr, ","); - } - fprintf(stderr, "%s", A[i].field->name); - } - - fprintf(stderr, "%s", format==giving_e? " GIVING" : ""); - - fprintf(stderr, " C[" HOST_SIZE_T_PRINT_DEC "]:", (fmt_size_t)nC); - for(size_t i=0; i 0) - { - fprintf(stderr, ","); - } - fprintf(stderr, "%s", C[i].refer.field->name); - } - - SHOW_PARSE_END - } - - TRACE1 - { - TRACE1_HEADER - TRACE1_END - } - bool handled = false; - if( !error && !not_error && fast_add(nC, C, - nA, A, - format) ) - { - handled = true; - } - else + bool computation_is_float = is_somebody_float(nA, A) + || is_somebody_float(nC, C); + // We now start deciding which arithmetic routine we are going to use: + if( computation_is_float ) { - tree compute_error = (tree)compute_error_p; - if( compute_error == NULL ) - { - gg_assign(var_decl_default_compute_error, integer_zero_node); - compute_error = gg_get_address_of(var_decl_default_compute_error); - } - - bool computation_is_float = is_somebody_float(nA, A) - || is_somebody_float(nC, C); - // We now start deciding which arithmetic routine we are going to use: - if( computation_is_float ) + switch( format ) { - switch( format ) + case no_giving_e: { - case no_giving_e: - { - // Float format 1 + // Float format 1 + + set_up_arithmetic_error_handler(error, + not_error); + // Do phase 1, which calculates the subtotal and puts it into a + // temporary location + arithmetic_operation( 0, NULL, + nA, A, + 0, NULL, + format, + error, + not_error, + compute_error, + "__gg__add_float_phase1"); - set_up_arithmetic_error_handler(error, - not_error); - // Do phase 1, which calculates the subtotal and puts it into a - // temporary location - arithmetic_operation( 0, NULL, - nA, A, + // Do phase 2, which accumulates the subtotal into each target location in turn + for(size_t i=0; iis_like_ebcdic() && delta >= 7 ) + { + /* EBCDIC leads to an odd situation. The range of digits in + EBCDIC is xF0 though 0xF9. That means that when DELTA is + >= 7 and the units digit is '9', the sum of 7 + 0xF9 is 0x100. + That's a carry condition, but we are working in UCHAR space, + so it looks to us like zero. And, so, we need some extra + logic so that we notice it that the zero is actually a + carry condition, and not something we are supposed to ignore. + + The largest possible value we might see is 9 + 0xF9, which is + 0x102, which to us looks like 0x02, so if the result is zero, + one, or two, we need to enter the carry condition. */ + IF( gg_indirect(pointer), ge_op, build_int_cst_type(UCHAR, 3) ) + { + // We are done with adding delta to C[0]. + gg_append_statement(break_goto); + } + ELSE + { + // Fall through to carry processing } + ENDIF } else { - switch( format ) - { - case no_giving_e: - { - // Fixed format 1 - - set_up_arithmetic_error_handler(error, - not_error); - // Do phase 1, which calculates the subtotal and puts it into a - // temporary location - arithmetic_operation( 0, NULL, - nA, A, - 0, NULL, - format, - error, - not_error, - compute_error, - "__gg__add_fixed_phase1"); - - // Do phase 2, which accumulates the subtotal into each target location in turn - for(size_t i=0; itype == FldLiteralN + && C[0].refer.field->type == FldNumericDisplay + && !(C[0].refer.field->attr & scaled_e) + && C[0].refer.field->codeset.stride() == 1) + { + // We are adding a FldLiteral to a FldNumericDisplay. + + // Get the integer value of the literal: + REAL_VALUE_TYPE val = TREE_REAL_CST(A[0].field->data.value_of()); + int delta = (int)real_to_integer (&val); + val = real_value_truncate (TYPE_MODE (float_type_node), val); + REAL_VALUE_TYPE rival; + real_from_integer (&rival, VOIDmode, delta, SIGNED); + + if( real_identical (&val, &rival) && delta == 0 ) + { + // val has no fractional part, which means delta is the exact integer + // part of val. + + // And delta is zero. This is a weird degenerate case. But adding zero + // to anything means we are already done. + handled = true; + return handled; + } + + int digits = C[0].refer.field->data.digits; + int rdigits = C[0].refer.field->data.rdigits; + + if( digits == rdigits ) + { + // This is another degenerate case. We are being asked to add an integer + // to a value whose PICTURE is something like V9999. This is beyond our + // capabilities. + if( !subtracting ) + { + ordinary_add_format_1(nC, C, + nA, A, + format, + error, + not_error, + compute_error ); + } + else + { + ordinary_subtract_format_1(nC, C, + nA, A, + format, + error, + not_error, + compute_error ); + } + + handled = true; + return handled; + } + + if( real_identical (&val, &rival) + && delta >= -9 + && delta <= 9 ) + { + delta = subtracting ? -delta : delta; + + // delta is a non-zero integer in the range of -9 to 9. + tree tdelta = build_int_cst_type(UCHAR, delta); + + charmap_t *charmap = + __gg__get_charmap(C[0].refer.field->codeset.encoding); + tzero = build_int_cst_type(UCHAR, + charmap->mapped_character(ascii_zero)); + tnine = build_int_cst_type(UCHAR, + charmap->mapped_character(ascii_nine)); + + // Build up an integer constant for conveniently handling the various + // PICTURE possibilities for a numeric display variable. + typedef enum + { UIT = 0, // unsignable, internal, trailing + UIL = 1, // unsignable, internal, leading (impossible) + UST = 2, // unsignable, separate, trailing (impossible) + USL = 3, // unsignable, separate, leading (impossible) + SIT = 4, // signable, internal, trailing + SIL = 5, // signable, internal, leading + SST = 6, // signable, separate, trailing + SSL = 7, // signable, separate, leading + } SIGN; + int the_attributes = ((C[0].refer.field->attr & signable_e) ? 4 : 0) + + ((C[0].refer.field->attr & separate_e) ? 2 : 0) + + ((C[0].refer.field->attr & leading_e ) ? 1 : 0) ; + SIGN signbits = static_cast(the_attributes); + + // We need a pointer to the units digit of the data. For a PIC 999v99 + // value of 123.45, we need a pointer to the '3': + int units_offset = (signbits == SSL ? 1 : 0) + + C[0].refer.field->data.digits + - C[0].refer.field->data.rdigits + - 1; + tree base; + // Now and forever, base points to the data area of C[0] + get_location(base, C[0].refer); + + tree units = gg_define_variable(UCHAR_P); + // Now and forever, units points to the units digit of C[0] + gg_assign(units, gg_add(base, build_int_cst_type(SIZE_T, units_offset))); + + // Now and forever, signloc points to the location of the byte containing + // the sign information: + int signloc_offset=0; + switch(signbits) + { + case UIT: + case UIL: + case UST: + case USL: + signloc_offset = 0; + break; + case SIT: + signloc_offset = digits-1; + break; + case SIL: + signloc_offset = 0; + break; + case SST: + signloc_offset = digits; + break; + case SSL: + signloc_offset = 0; + break; + } + tree counter = gg_define_int(digits - rdigits); + tree pointer = gg_define_variable(UCHAR_P); + gg_assign(pointer, units); + if( !(C[0].refer.field->attr & signable_e) ) + { + // The target is not signable + if( delta >= 1 ) + { + // Adding a positive number to an unsignable target. + add_case_1(pointer, + tdelta, + charmap, + delta, + counter); + handled = 1; + } + else + { + // Adding a negative number to an unsignable target. + + /* The edge case is when we are doing something like ADD 1 to 0.21, + where the computed value is -0.79, and ends up in the target as + 0.79. We don't try to do that, and instead pass off such + calculations to the ordinary arithmetic routine. */ + if( rdigits ) + { + // When there are rdigits, we might have to call ordinary_add + // First, we look at the rightmost units digit. + IF( gg_bitwise_and(gg_indirect(pointer), uchar_f_node), + ge_op, + tdelta ) + { + // There will be no carry from the lowest order digit, so it is + // safe to use add_case_2 + add_case_2(pointer, + tdelta, + counter, + digits - rdigits); + } + ELSE + { + // There will be a carry from the rightmost digit. We have to + // check the other digits. If any are non-zero, then it is safe + // to use add_case_2 + tree break_goto; + tree break_label; + gg_create_goto_pair(&break_goto, + &break_label); + WHILE( counter, gt_op, integer_one_node ) + { + gg_decrement(pointer); + IF( gg_indirect(pointer), ne_op, tzero ) + { + // One of the left digits is non-zero, which means it is safe + // to use add_case_2() + gg_assign(counter, build_int_cst_type(INT, digits-rdigits)); + gg_assign(pointer, units); + add_case_2(pointer, + tdelta, + counter, + digits - rdigits); + gg_append_statement(break_goto); + } + ELSE + { + gg_decrement(counter); + } + ENDIF + } + WEND + // If you get here, that means we are adding a negative value + // to something with rdigits and we have a carry from the + // rightmost place, and all of the other digits are zero. + if( !subtracting ) + { + ordinary_add_format_1(nC, C, + nA, A, + format, + error, + not_error, + compute_error ); + } + else + { + ordinary_subtract_format_1(nC, C, + nA, A, + format, + error, + not_error, + compute_error ); + } + gg_append_statement(break_label); + } + ENDIF + } + else + { + add_case_2(pointer, + tdelta, + counter, + digits - rdigits); + } + handled = true; + } + } + else if( signbits == SIT ) + { + // The target is signable, and it is of the type PIC S9999, which is + // the most common. + + tree signloc = gg_define_variable(UCHAR_P); + gg_assign(signloc, + gg_add(base, build_int_cst_type(SIZE_T, signloc_offset))); + if( delta >= 1 ) + { + tree break_goto; + tree break_label; + gg_create_goto_pair(&break_goto, + &break_label); + IF( gg_indirect(signloc), ge_op, tzero ) + { + IF( gg_indirect(signloc), le_op, tnine ) + { + // The signloc byte is between '0' and '9'. + + // We are adding a positive to a signable positive value + // This is the same as adding a positive value to an unsignable + // value: + add_case_1(pointer, + tdelta, + charmap, + delta, + counter); + gg_append_statement(break_goto); + } + ELSE + { + } + ENDIF + } + ELSE + { + } + ENDIF + /* We are adding a positive value to a negative value. */ + + IF( gg_bitwise_and(gg_indirect(pointer), uchar_f_node), + gt_op, + tdelta ) + { + // The rightmost digit is bigger than tdelta, so it's safe to use + // the fast routine, because the result will stay negative. + add_case_3(pointer, + tdelta, + counter); + gg_append_statement(break_goto); + } + ELSE + { + } + ENDIF + // Either the rightmost digit is zero, or there will be a carry. + // If any of the remaining digits is non-zero, then the result will + // stay negative. + + WHILE( counter, gt_op, integer_one_node ) + { + gg_decrement(pointer); + IF( gg_indirect(pointer), ne_op, tzero ) + { + // One of the remaining digits is non-zero, so we can still + // use the fast routine: + gg_assign(counter, build_int_cst_type(INT, digits-rdigits)); + gg_assign(pointer, units); + add_case_3(pointer, + tdelta, + counter); + gg_append_statement(break_goto); + } + ELSE + { + } + ENDIF + gg_decrement(counter); + } + WEND + // since we are doing something like ADD 1 to -00.21, we need to + // use ordinary arithmetic to cope with the switch to +00.79 + if( !subtracting ) + { + ordinary_add_format_1(nC, C, + nA, A, + format, + error, + not_error, + compute_error ); + } + else + { + ordinary_subtract_format_1(nC, C, + nA, A, + format, + error, + not_error, + compute_error ); + } + gg_append_statement(break_label); + } + else + { + // We are adding a negative value to a signable value. + + tree break_goto; + tree break_label; + gg_create_goto_pair(&break_goto, + &break_label); + + IF( gg_indirect(signloc), ge_op, tzero ) + { + IF( gg_indirect(signloc), le_op, tnine ) + { + // The signloc byte is between '0' and '9'. + // We are adding a negative value to a positive signable value. + + IF( gg_bitwise_and(gg_indirect(pointer), uchar_f_node), + gt_op, + gg_negate(tdelta) ) + { + // The units digit is non-zero, so we can use the same routine + // we use for unsignable positives: + add_case_2(pointer, + tdelta, + counter, + digits); + gg_append_statement(break_goto); + } + ELSE + { + } + ENDIF + + // The rightmost digit is zero. Check the remaining digits of the + // integer part: + WHILE( counter, gt_op, integer_one_node ) + { + gg_decrement(pointer); + IF( gg_indirect(pointer), ne_op, tzero ) + { + // One of the remaining digits is non-zero, so we can still + // use the fast routine: + gg_assign(counter, build_int_cst_type(INT, digits-rdigits)); + gg_assign(pointer, units); + add_case_2(pointer, + tdelta, + counter, + digits); + gg_append_statement(break_goto); + } + ELSE + { + } + ENDIF + gg_decrement(counter); + } + WEND + // Arriving here means the integer part of the positive signable + // is zero. + // We are dealing with something like 00.21 + if( !subtracting ) + { + ordinary_add_format_1(nC, C, + nA, A, + format, + error, + not_error, + compute_error ); + } + else + { + ordinary_subtract_format_1(nC, C, + nA, A, + format, + error, + not_error, + compute_error ); + } + gg_append_statement(break_goto); + } + ELSE + { + } + ENDIF + } + ELSE + { + } + ENDIF + + // We are adding a negative value to negative S9999 + + add_case_4(pointer, + tdelta, + counter); + + // Special case: When we do ADD -1 to -99.00, add_case_4 actually + // comes back with -00.00. So, we have to check the digits; when + // they are all zero, we make the value positive. + //if( rdigits ) + { + gg_assign(units, gg_add(units, build_int_cst_type(SIZE_T, rdigits))); + gg_assign(pointer, units); + IF( gg_bitwise_and(gg_indirect(pointer), uchar_f_node), + ne_op, + build_int_cst_type(UCHAR, 0) ) + { + gg_append_statement(break_goto); + } + ELSE + { + } + ENDIF + gg_assign(counter, build_int_cst_type(INT, digits)); + WHILE( counter, gt_op, integer_one_node ) + { + gg_decrement(pointer); + IF( gg_indirect(pointer), + ne_op, + tzero ) + { + gg_append_statement(break_goto); + } + ELSE + { + } + ENDIF + gg_decrement(counter); + } + WEND + // Getting here means that we are looking at -negative zero. Make + // it positive + gg_assign(gg_indirect(units), tzero); + } + gg_append_statement(break_label); + } + handled = true; + } + } + } + return handled; + } + +static bool +add_format_1( size_t nC, cbl_num_result_t *C, + size_t nA, cbl_refer_t *A, + cbl_arith_format_t format, + cbl_label_t *error, + cbl_label_t *not_error, + tree compute_error ) + { + bool handled = false; + if( format == no_giving_e ) + { + // Fixed format 1 + handled = add_litN_to_numdisp( nC, C, + nA, A, + format, + error, + not_error, + compute_error, + false); // false means adding + if( !handled ) + { + ordinary_add_format_1(nC, C, + nA, A, + format, + error, + not_error, + compute_error ); + handled = true; + } + } + + return handled; + } + +static bool +add_format_2( size_t nC, cbl_num_result_t *C, + size_t nA, cbl_refer_t *A, + cbl_arith_format_t format, + cbl_label_t *error, + cbl_label_t *not_error, + tree compute_error ) + { + bool handled = false; + if( format == giving_e ) + { + // Fixed format 2 + + set_up_arithmetic_error_handler(error, + not_error); + // Do phase 1, which calculates the subtotal and puts it into a + // temporary location + arithmetic_operation( 0, NULL, + nA, A, + 0, NULL, + format, + error, + not_error, + compute_error, + "__gg__add_fixed_phase1"); + + // Do phase 2, which puts the subtotal into each target location in turn + for(size_t i=0; i 0) + { + fprintf(stderr, ","); + } + fprintf(stderr, "%s", A[i].field->name); + } + + fprintf(stderr, "%s", format==giving_e? " GIVING" : ""); + + fprintf(stderr, " C[" HOST_SIZE_T_PRINT_DEC "]:", (fmt_size_t)nC); + for(size_t i=0; i 0) + { + fprintf(stderr, ","); + } + fprintf(stderr, "%s", C[i].refer.field->name); + } + + SHOW_PARSE_END + } + + TRACE1 + { + TRACE1_HEADER + TRACE1_END + } + + bool handled = fast_add(nC, C, nA, A, format, error, not_error) ; + + tree compute_error = (tree)compute_error_p; + + if( !handled ) + { + if( compute_error == NULL ) + { + gg_assign(var_decl_default_compute_error, integer_zero_node); + compute_error = gg_get_address_of(var_decl_default_compute_error); + } + + // See if somebody in the addition is a float: + handled = add_floats( nC, C, + nA, A, + format, + error, + not_error, + compute_error ); + } + + if( !handled ) + { + handled = add_format_1(nC, C, + nA, A, + format, + error, + not_error, + compute_error ); + } + + if( !handled ) + { + handled = add_format_2(nC, C, + nA, A, + format, + error, + not_error, + compute_error ); + } + + if( !handled ) + { + handled = add_format_3(nC, C, + nA, A, + format, + error, + not_error, + compute_error ); + } + + gcc_assert( handled ); + } + +void +parser_add( const cbl_refer_t& cref, + const cbl_refer_t& aref, + const cbl_refer_t& bref, + cbl_round_t rounded) + { + // This is the simple and innocent C = A + B + cbl_num_result_t C[1]; + C[0].rounded = rounded; + C[0].refer = cref; + + cbl_refer_t A[2]; + A[0] = aref; + A[1] = bref; + + parser_add( 1, C, + 2, A, + giving_e, + NULL, + NULL ); + } + +void +parser_multiply(size_t nC, cbl_num_result_t *C, + size_t nA, cbl_refer_t *A, + size_t nB, cbl_refer_t *B, + cbl_label_t *error, + cbl_label_t *not_error, + void *compute_error_p ) // This is a pointer to an int + { + Analyze(); + SHOW_PARSE + { + SHOW_PARSE_HEADER + SHOW_PARSE_END + } + + if( !error && !not_error && fast_multiply(nC, C, + nA, A, + nB, B) ) + { + + } + else + { + tree compute_error = (tree)compute_error_p; + + if( compute_error == NULL ) + { + gg_assign(var_decl_default_compute_error, integer_zero_node); + compute_error = gg_get_address_of(var_decl_default_compute_error); } if( nB == 0 ) @@ -1613,6 +2604,249 @@ parser_op( struct cbl_refer_t cref, } } +static bool +subtract_floats( size_t nC, cbl_num_result_t *C, + size_t nA, cbl_refer_t *A, + size_t nB, cbl_refer_t *B, + cbl_arith_format_t format, + cbl_label_t *error, + cbl_label_t *not_error, + tree compute_error ) + { + bool handled = false; + + bool computation_is_float = is_somebody_float(nA, A) + || is_somebody_float(nC, C); + + // We now start deciding which arithmetic routine we are going to use: + + if( computation_is_float ) + { + switch( format ) + { + case no_giving_e: + { + // Float format 1 + + set_up_arithmetic_error_handler(error, + not_error); + // Do phase 1, which calculates the subtotal and puts it into a + // temporary location + arithmetic_operation( 0, NULL, + nA, A, + 0, NULL, + format, + error, + not_error, + compute_error, + "__gg__add_float_phase1"); + + // Do phase 2, which subtracts the subtotal from each target in turn + for(size_t i=0; itype == FldIndex ) + { + // This field can't have a DEPENDING ON + return false; + } + // Check if there there is an occurs with a depending_on in the hierarchy bool proceed = false; const cbl_field_t *odo = symbol_find_odo(refer.field); diff --git a/gcc/cobol/lang-specs.h b/gcc/cobol/lang-specs.h index b84b6666e78..e82e6ca39fe 100644 --- a/gcc/cobol/lang-specs.h +++ b/gcc/cobol/lang-specs.h @@ -37,10 +37,12 @@ "%{D*} %{E} %{I*} %{M} %{fmax-errors*} %{fsyntax-only*} " "%{fcobol-exceptions*} " "%{copyext} " + "%{fdefaultbyte} " "%{fexec-charset*} " "%{fexec-national-charset*} " - "%{fstatic-call} %{fdefaultbyte} " "%{ffixed-form} %{ffree-form} %{indicator-column*} " + "%{fstatic-call} " + "%{ftrunc} " "%{preprocess} " "%{dialect} " "%{include} " diff --git a/gcc/cobol/lang.opt b/gcc/cobol/lang.opt index 58e1a7d3a5e..2fd4d3571b0 100644 --- a/gcc/cobol/lang.opt +++ b/gcc/cobol/lang.opt @@ -81,6 +81,10 @@ fexec-national-charset= Cobol Joined Var(cobol_national_charset) RejectNegative Set the default execution character set for NATIONAL data items. +ftrunc +Cobol Var(cobol_trunc_bin, 1) Init(1) +Truncate BINARY PIC 9(n) to n digits. + ;; warnings ; Par78CdfDefinedW diff --git a/gcc/cobol/lexio.cc b/gcc/cobol/lexio.cc index 8a914ae86a9..0fcf71f8e1a 100644 --- a/gcc/cobol/lexio.cc +++ b/gcc/cobol/lexio.cc @@ -1605,7 +1605,8 @@ int cdftext::open_input( const char filename[] ) { int fd = open(filename, O_RDONLY); if( fd == -1 ) { - dbgmsg( "could not open '%s': %s", filename, xstrerror(errno) ); + auto erc(errno); + dbgmsg( "could not open '%s': %s", filename, xstrerror(erc) ); } verbose_file_reader = NULL != getenv("GCOBOL_TEMPDIR"); diff --git a/gcc/cobol/parse.y b/gcc/cobol/parse.y index dc2ac9765cd..804bf28363f 100644 --- a/gcc/cobol/parse.y +++ b/gcc/cobol/parse.y @@ -58,6 +58,14 @@ struct label_pair_t { cbl_label_t *from, *to; }; + + struct linage_t { + cbl_refer_t *footing, *top, *bottom; + }; + struct linage_value_t { + int token; + cbl_refer_t *value; + }; class locale_tgt_t { char user_system_default; @@ -741,11 +749,12 @@ class locale_tgt_t { perform_inline perform_except %type eval_subject1 -%type vargs disp_vargs; +%type vargs disp_vargs %type level_name -%type fd_name picture_sym name66 paragraph_name +%type fd_name +%type picture_sym name66 paragraph_name %type literalism -%type bound advance_when org_clause1 read_next +%type bound advance_when org_clause1 read_next top_bot %type access_mode multiple lock_how lock_mode org_is %type select_clauses %type select_clause access_clause alt_key_clause @@ -754,6 +763,8 @@ class locale_tgt_t { record_delim_clause record_key_clause relative_key_clause reserve_clause sharing_clause +%type with_linage with_footings +%type with_footing %type filename read_body write_body delete_body %type