diff options
372 files changed, 10051 insertions, 13277 deletions
diff --git a/c++tools/ChangeLog b/c++tools/ChangeLog index ff35cac..d5a345b 100644 --- a/c++tools/ChangeLog +++ b/c++tools/ChangeLog @@ -1,3 +1,8 @@ +2025-06-02 Kito Cheng <kito.cheng@sifive.com> + + * configure.ac: Don't check `--enable-default-pie`. + * configure: Regen. + 2024-05-07 Rainer Orth <ro@CeBiTec.Uni-Bielefeld.DE> * configure.ac (ax_lib_socket_nsl.m4): Don't sinclude. diff --git a/gcc/ChangeLog b/gcc/ChangeLog index 25c6624..f70a66e 100644 --- a/gcc/ChangeLog +++ b/gcc/ChangeLog @@ -1,3 +1,203 @@ +2025-06-04 Kugan Vivekanandarajah <kvivekananda@nvidia.com> + + * auto-profile.cc (autofdo_source_profile::read): Dump message + while merging profile. + * pass_manager.h (get_pass_auto_profile): New. + +2025-06-04 Sandra Loosemore <sloosemore@baylibre.com> + + PR c++/120518 + * omp-general.cc (omp_device_num_check): Look inside a + CLEANUP_POINT_EXPR when trying to optimize special cases. + +2025-06-04 Thomas Schwinge <tschwinge@baylibre.com> + + * config/nvptx/mkoffload.cc (process): Use an 'auto_vec' for + 'file_idx'. + +2025-06-04 Andrew Pinski <quic_apinski@quicinc.com> + + PR tree-optimization/14295 + PR tree-optimization/108358 + PR tree-optimization/114169 + * tree-ssa-forwprop.cc (optimize_agr_copyprop): New function. + (pass_forwprop::execute): Call optimize_agr_copyprop for load/store statements. + +2025-06-04 Pengfei Li <Pengfei.Li2@arm.com> + + * match.pd: Add folding rule for vector average. + * tree-ssa-ccp.cc (get_default_value): Reject vector types. + (evaluate_stmt): Reject vector types. + * tree-ssanames.cc (get_nonzero_bits_1): Extend to handle + uniform vectors. + +2025-06-04 Xi Ruoyao <xry111@xry111.site> + + PR rtl-optimization/120050 + * ext-dce.cc (ext_dce_process_uses): Break early if a SUBREG in + rhs is promoted and the truncation from the inner mode to the + outer mode is not a noop when handling SETs. + +2025-06-04 Jakub Jelinek <jakub@redhat.com> + + * range-op-float.cc (range_operator::fold_range, + range_operator::op1_range, range_operator::op2_range, + range_operator::lhs_op1_relation, range_operator::lhs_op2_relation, + operator_equal::op1_range, foperator_unordered_gt::op1_range): Fix + up parameter indentation. + * range-op.cc (range_operator::fold_range, range_operator::op1_range, + range_operator::op1_op2_relation_effect, + range_operator::update_bitmask, plus_minus_ranges, + operator_bitwise_and::lhs_op1_relation): Likewise. + +2025-06-04 Jakub Jelinek <jakub@redhat.com> + + PR tree-optimization/120231 + * range-op-mixed.h (operator_cast::fold_range): Add overload + with 3 {,const} frange & operands. Change parameter names and + add final override keywords for float <-> integer cast overloads. + (operator_cast::op1_range): Likewise. + * range-op-float.cc (operator_cast::fold_range): New overload + with 3 {,const} frange & operands. + (operator_cast::op1_range): Likewise. + +2025-06-04 Dongyan Chen <chendongyan@isrc.iscas.ac.cn> + + * config/riscv/riscv-ext.def: Imply zicsr. + +2025-06-04 Dongyan Chen <chendongyan@isrc.iscas.ac.cn> + + * config/riscv/riscv-ext.def: New extension defs. + * config/riscv/riscv-ext.opt: Ditto. + * doc/riscv-ext.texi: Ditto. + +2025-06-04 Richard Sandiford <richard.sandiford@arm.com> + + PR rtl-optimization/120447 + * emit-rtl.cc (validate_subreg): Restrict ordered_p test + between osize and regsize to cases where the inner value + occupies multiple blocks. + +2025-06-04 Pan Li <pan2.li@intel.com> + + * config/riscv/riscv.cc (get_vector_binary_rtx_cost): Rename + the args to scalar2vr. + (riscv_rtx_costs): Leverage above func to avoid code dup. + +2025-06-04 H.J. Lu <hjl.tools@gmail.com> + + PR debug/120525 + * var-tracking.cc (prepare_call_arguments): Use MEM_EXPR only + if MEM_P is true. + +2025-06-04 Jiawei <jiawei@iscas.ac.cn> + + * config/riscv/riscv-ext.def: New extension defs. + * config/riscv/riscv-ext.opt: Ditto. + * doc/riscv-ext.texi: Ditto. + +2025-06-04 Hu, Lin1 <lin1.hu@intel.com> + + * config/i386/i386.md (define_peephole2): Define some new peephole2 for + APX NDD. + +2025-06-04 Hu, Lin1 <lin1.hu@intel.com> + + * config/i386/i386.md: Add 4 new peephole2 by swap the original + peephole2's operands' order to support new pattern. + +2025-06-04 H.J. Lu <hjl.tools@gmail.com> + + PR other/120494 + * calls.cc (expand_call): Always add REG_CALL_DECL note. + (emit_library_call_value_1): Likewise. + +2025-06-03 Richard Biener <rguenther@suse.de> + + * gimple-fold.cc (create_tmp_reg_or_ssa_name): Always + create a SSA name. + +2025-06-03 Pan Li <pan2.li@intel.com> + + * config/riscv/riscv-v.cc (expand_vx_binary_vec_vec_dup): Add new + case for DIV op. + * config/riscv/riscv.cc (get_vector_binary_rtx_cost): Add new func + to get the cost of vector binary. + (riscv_rtx_costs): Add div rtx match and leverage above wrap to + get cost. + * config/riscv/vector-iterators.md: Add new op div to no_shift_vx_op. + +2025-06-03 Richard Biener <rguenther@suse.de> + + PR tree-optimization/120517 + * tree-vect-data-refs.cc (vect_analyze_data_ref_accesses): + Fix math in dataref group split. + +2025-06-03 Paul-Antoine Arras <parras@baylibre.com> + + * config/riscv/riscv-vector-costs.cc (costs::adjust_stmt_cost): Replace + FR2VR with get_fr2vr_cost (). + * config/riscv/riscv.cc (riscv_register_move_cost): Likewise. + (riscv_builtin_vectorization_cost): Likewise. + +2025-06-03 Paul-Antoine Arras <parras@baylibre.com> + + PR target/119100 + * config/riscv/autovec-opt.md (*<optab>_vf_<mode>): Add new pattern to + combine vec_duplicate + vfm{add,sub}.vv into vfm{add,sub}.vf. + * config/riscv/riscv-opts.h (FPR2VR_COST_UNPROVIDED): Define. + * config/riscv/riscv-protos.h (get_fr2vr_cost): Declare function. + * config/riscv/riscv.cc (riscv_rtx_costs): Add cost model for MULT with + VEC_DUPLICATE. + (get_fr2vr_cost): New function. + * config/riscv/riscv.opt: Add new option --param=fpr2vr-cost. + +2025-06-03 Andrew Pinski <quic_apinski@quicinc.com> + + PR tree-optimization/120451 + * tree-switch-conversion.cc (switch_conversion::build_one_array): Mark + the newly created decl as mergable. + +2025-06-02 Alexandre Oliva <oliva@adacore.com> + + PR rtl-optimization/120424 + PR middle-end/118939 + * lra-spills.cc (spill_pseudos): Update insn regno info. + * lra-eliminations.cc (update_reg_eliminate): Recognize + disabling of active elimination regardless of + prev_can_eliminate. + +2025-06-02 Dongyan Chen <chendongyan@isrc.iscas.ac.cn> + + * config/riscv/riscv-ext.def: New extension defs. + * config/riscv/riscv-ext.opt: Ditto. + * doc/riscv-ext.texi: Ditto. + +2025-06-02 Stafford Horne <shorne@gmail.com> + + * config/or1k/predicates.md (call_insn_operand): Add condition + to not allow symbol_ref operands with TARGET_CMODEL_LARGE. + * config/or1k/or1k.opt: Document new -mcmodel=large + implications. + * doc/invoke.texi: Likewise. + +2025-06-02 Christophe Lyon <christophe.lyon@linaro.org> + + * doc/sourcebuild.texi (tls_link): Add documentation. + +2025-06-02 Kito Cheng <kito.cheng@sifive.com> + + * config/riscv/t-riscv: Adjust build rule for gen-riscv-ext-opt + and gen-riscv-ext-texi. + +2025-06-02 Kito Cheng <kito.cheng@sifive.com> + + * config/riscv/riscv-c.cc (riscv_cpu_cpp_builtins): Use + range-based-for-loop. + * config/riscv/riscv-subset.h (riscv_subset_list::iterator): + New. + (riscv_subset_list::const_iterator): New. + 2025-06-01 H.J. Lu <hjl.tools@gmail.com> PR other/120493 diff --git a/gcc/DATESTAMP b/gcc/DATESTAMP index 5646e6e..520e78d 100644 --- a/gcc/DATESTAMP +++ b/gcc/DATESTAMP @@ -1 +1 @@ -20250602 +20250605 diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl index cb41e68..a26a725 100644 --- a/gcc/ada/Makefile.rtl +++ b/gcc/ada/Makefile.rtl @@ -211,7 +211,6 @@ GNATRTL_NONTASKING_OBJS= \ a-nallfl$(objext) \ a-nalofl$(objext) \ a-nashfl$(objext) \ - a-nbnbig$(objext) \ a-nbnbin$(objext) \ a-nbnbre$(objext) \ a-ncelfu$(objext) \ @@ -745,8 +744,6 @@ GNATRTL_NONTASKING_OBJS= \ s-shasto$(objext) \ s-soflin$(objext) \ s-soliin$(objext) \ - s-spark$(objext) \ - s-spcuop$(objext) \ s-spsufi$(objext) \ s-stache$(objext) \ s-stalib$(objext) \ @@ -772,7 +769,6 @@ GNATRTL_NONTASKING_OBJS= \ s-vaenu8$(objext) \ s-vafi32$(objext) \ s-vafi64$(objext) \ - s-vaispe$(objext) \ s-valboo$(objext) \ s-valcha$(objext) \ s-valflt$(objext) \ @@ -782,7 +778,6 @@ GNATRTL_NONTASKING_OBJS= \ s-vallli$(objext) \ s-valllu$(objext) \ s-valrea$(objext) \ - s-valspe$(objext) \ s-valued$(objext) \ s-valuef$(objext) \ s-valuei$(objext) \ @@ -792,14 +787,9 @@ GNATRTL_NONTASKING_OBJS= \ s-valuns$(objext) \ s-valuti$(objext) \ s-valwch$(objext) \ - s-vauspe$(objext) \ s-veboop$(objext) \ s-vector$(objext) \ s-vercon$(objext) \ - s-vs_int$(objext) \ - s-vs_lli$(objext) \ - s-vs_llu$(objext) \ - s-vs_uns$(objext) \ s-wchcnv$(objext) \ s-wchcon$(objext) \ s-wchjis$(objext) \ @@ -1046,8 +1036,6 @@ GNATRTL_128BIT_OBJS = \ s-vafi128$(objext) \ s-valllli$(objext) \ s-vallllu$(objext) \ - s-vsllli$(objext) \ - s-vslllu$(objext) \ s-widllli$(objext) \ s-widlllu$(objext) diff --git a/gcc/ada/accessibility.adb b/gcc/ada/accessibility.adb index 8c85173..0b8d3f7 100644 --- a/gcc/ada/accessibility.adb +++ b/gcc/ada/accessibility.adb @@ -1642,6 +1642,13 @@ package body Accessibility is (No (Extra_Accessibility_Of_Result (Scope_Id)) and then Is_Formal_Of_Current_Function (Assoc_Expr) and then Is_Tagged_Type (Etype (Scope_Id))) + + -- Disable the check generation when we are only checking semantics + -- since required locals do not get generated (e.g. extra + -- accessibility of result), and constant folding can occur and + -- lead to spurious errors. + + and then not Check_Semantics_Only_Mode then -- Generate a dynamic check based on the extra accessibility of -- the result or the scope of the current function. @@ -1684,8 +1691,8 @@ package body Accessibility is and then Entity (Check_Cond) = Standard_True then Error_Msg_N - ("access discriminant in return object would be a dangling" - & " reference", Return_Stmt); + ("access discriminant in return object could be a dangling" + & " reference??", Return_Stmt); end if; end if; diff --git a/gcc/ada/atree.ads b/gcc/ada/atree.ads index dc5fe0d..c8cc2bc 100644 --- a/gcc/ada/atree.ads +++ b/gcc/ada/atree.ads @@ -299,20 +299,19 @@ package Atree is -- This function allocates a new node, and then initializes it by copying -- the contents of the source node into it. The contents of the source node -- is not affected. The target node is always marked as not being in a list - -- (even if the source is a list member), and not overloaded. The new node - -- will have an extension if the source has an extension. New_Copy (Empty) - -- returns Empty, and New_Copy (Error) returns Error. Note that, unlike - -- Copy_Separate_Tree, New_Copy does not recursively copy any descendants, - -- so in general parent pointers are not set correctly for the descendants - -- of the copied node. + -- (even if the source is a list member), and not overloaded. + -- New_Copy (Empty) returns Empty, and New_Copy (Error) returns Error. Note + -- that, unlike Copy_Separate_Tree, New_Copy does not recursively copy any + -- descendants, so in general parent pointers are not set correctly for the + -- descendants of the copied node. function Relocate_Node (Source : Node_Id) return Node_Id; -- Source is a non-entity node that is to be relocated. A new node is -- allocated, and the contents of Source are copied to this node, using -- New_Copy. The parent pointers of descendants of the node are then -- adjusted to point to the relocated copy. The original node is not - -- modified, but the parent pointers of its descendants are no longer - -- valid. The new copy is always marked as not overloaded. This routine is + -- modified, but the parent pointers of its children no longer point back + -- at it. The new copy is always marked as not overloaded. This routine is -- used in conjunction with the tree rewrite routines (see descriptions of -- Replace/Rewrite). -- diff --git a/gcc/ada/clean.adb b/gcc/ada/clean.adb index f28cf69..dcbeffe 100644 --- a/gcc/ada/clean.adb +++ b/gcc/ada/clean.adb @@ -319,7 +319,9 @@ package body Clean is Delete ("", Executable); end if; - Delete_Binder_Generated_Files (Get_Current_Dir, Source); + Delete_Binder_Generated_Files + (GNAT.Directory_Operations.Get_Current_Dir, + Source); end; end if; end loop; @@ -405,7 +407,8 @@ package body Clean is Source : File_Name_Type) is Source_Name : constant String := Get_Name_String (Source); - Current : constant String := Get_Current_Dir; + Current : constant String := + GNAT.Directory_Operations.Get_Current_Dir; Last : constant Positive := B_Start'Length + Source_Name'Length; File_Name : String (1 .. Last + 4); diff --git a/gcc/ada/contracts.adb b/gcc/ada/contracts.adb index 8b94a67..c0a57e6 100644 --- a/gcc/ada/contracts.adb +++ b/gcc/ada/contracts.adb @@ -4909,7 +4909,7 @@ package body Contracts is Install_Formals (Subp); Inside_Class_Condition_Preanalysis := True; - Preanalyze_Spec_Expression (Expr, Standard_Boolean); + Preanalyze_And_Resolve_Spec_Expression (Expr, Standard_Boolean); Inside_Class_Condition_Preanalysis := False; End_Scope; diff --git a/gcc/ada/diagnostics-json_utils.adb b/gcc/ada/diagnostics-json_utils.adb index 072cab4..8ce04c4 100644 --- a/gcc/ada/diagnostics-json_utils.adb +++ b/gcc/ada/diagnostics-json_utils.adb @@ -22,7 +22,11 @@ -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ + +with Namet; use Namet; +with Osint; with Output; use Output; +with System.OS_Lib; package body Diagnostics.JSON_Utils is @@ -64,6 +68,141 @@ package body Diagnostics.JSON_Utils is end if; end NL_And_Indent; + ----------------- + -- To_File_Uri -- + ----------------- + + function To_File_Uri (Path : String) return String is + + function Normalize_Uri (Path : String) return String; + -- Construct a normalized URI from the path name by replacing reserved + -- URI characters that can appear in paths with their escape character + -- combinations. + -- + -- According to the URI standard reserved charcthers within the paths + -- should be percent encoded: + -- + -- https://www.rfc-editor.org/info/rfc3986 + -- + -- Reserved charcters are defined as: + -- + -- reserved = gen-delims / sub-delims + -- gen-delims = ":" / "/" / "?" / "#" / "[" / "]" / "@" + -- sub-delims = "!" / "$" / "&" / "’" / "(" / ")" + -- / "*" / "+" / "," / ";" / "=" + + ------------------- + -- Normalize_Uri -- + ------------------- + + function Normalize_Uri (Path : String) return String is + Buf : Bounded_String; + begin + for C of Path loop + case C is + when '\' => + + -- Use forward slashes instead of backward slashes as + -- separators on Windows and on Linux simply encode the + -- symbol if part of a directory name. + + if Osint.On_Windows then + Append (Buf, '/'); + else + Append (Buf, "%5C"); + end if; + + when ' ' => + Append (Buf, "%20"); + + when '!' => + Append (Buf, "%21"); + + when '#' => + Append (Buf, "%23"); + + when '$' => + Append (Buf, "%24"); + + when '&' => + Append (Buf, "%26"); + + when ''' => + Append (Buf, "%27"); + + when '(' => + Append (Buf, "%28"); + + when ')' => + Append (Buf, "%29"); + + when '*' => + Append (Buf, "%2A"); + + when '+' => + Append (Buf, "%2A"); + + when ',' => + Append (Buf, "%2A"); + + when '/' => + -- Forward slash is a valid file separator on both Unix and + -- Windows based machines and should be treated as such + -- within a path. + Append (Buf, '/'); + + when ':' => + Append (Buf, "%3A"); + + when ';' => + Append (Buf, "%3B"); + + when '=' => + Append (Buf, "%3D"); + + when '?' => + Append (Buf, "%3F"); + + when '@' => + Append (Buf, "%40"); + + when '[' => + Append (Buf, "%5B"); + + when ']' => + Append (Buf, "%5D"); + + when others => + Append (Buf, C); + end case; + end loop; + + return To_String (Buf); + end Normalize_Uri; + + Norm_Uri : constant String := Normalize_Uri (Path); + + -- Start of processing for To_File_Uri + + begin + if System.OS_Lib.Is_Absolute_Path (Path) then + -- URI-s using the file scheme should start with the following + -- prefix: + -- + -- "file:///" + + if Osint.On_Windows then + return "file:///" & Norm_Uri; + else + -- Full paths on linux based systems already start with '/' + + return "file://" & Norm_Uri; + end if; + else + return Norm_Uri; + end if; + end To_File_Uri; + ----------------------------- -- Write_Boolean_Attribute -- ----------------------------- diff --git a/gcc/ada/diagnostics-json_utils.ads b/gcc/ada/diagnostics-json_utils.ads index 526e09e..75adc08 100644 --- a/gcc/ada/diagnostics-json_utils.ads +++ b/gcc/ada/diagnostics-json_utils.ads @@ -49,6 +49,11 @@ package Diagnostics.JSON_Utils is procedure NL_And_Indent; -- Print a new line + function To_File_Uri (Path : String) return String; + -- Converts an absolute Path into a file URI string by adding the file + -- schema prefix "file:///" and replacing all of the URI reserved + -- characters in the absolute path. + procedure Write_Boolean_Attribute (Name : String; Value : Boolean); -- Write a JSON attribute with a boolean value. -- diff --git a/gcc/ada/diagnostics-sarif_emitter.adb b/gcc/ada/diagnostics-sarif_emitter.adb index 31b3154..d7f9234 100644 --- a/gcc/ada/diagnostics-sarif_emitter.adb +++ b/gcc/ada/diagnostics-sarif_emitter.adb @@ -23,18 +23,56 @@ -- -- ------------------------------------------------------------------------------ -with Diagnostics.Utils; use Diagnostics.Utils; -with Diagnostics.JSON_Utils; use Diagnostics.JSON_Utils; -with Gnatvsn; use Gnatvsn; -with Output; use Output; -with Sinput; use Sinput; -with Lib; use Lib; -with Namet; use Namet; -with Osint; use Osint; -with Errout; use Errout; +with Errout; use Errout; +with Diagnostics.JSON_Utils; use Diagnostics.JSON_Utils; +with Diagnostics.Utils; use Diagnostics.Utils; +with Gnatvsn; use Gnatvsn; +with Lib; use Lib; +with Namet; use Namet; +with Osint; use Osint; +with Output; use Output; +with Sinput; use Sinput; +with System.OS_Lib; package body Diagnostics.SARIF_Emitter is + -- SARIF attribute names + + N_ARTIFACT_CHANGES : constant String := "artifactChanges"; + N_ARTIFACT_LOCATION : constant String := "artifactLocation"; + N_COMMAND_LINE : constant String := "commandLine"; + N_DELETED_REGION : constant String := "deletedRegion"; + N_DESCRIPTION : constant String := "description"; + N_DRIVER : constant String := "driver"; + N_END_COLUMN : constant String := "endColumn"; + N_END_LINE : constant String := "endLine"; + N_EXECUTION_SUCCESSFUL : constant String := "executionSuccessful"; + N_FIXES : constant String := "fixes"; + N_ID : constant String := "id"; + N_INSERTED_CONTENT : constant String := "insertedContent"; + N_INVOCATIONS : constant String := "invocations"; + N_LOCATIONS : constant String := "locations"; + N_LEVEL : constant String := "level"; + N_MESSAGE : constant String := "message"; + N_NAME : constant String := "name"; + N_ORIGINAL_URI_BASE_IDS : constant String := "originalUriBaseIds"; + N_PHYSICAL_LOCATION : constant String := "physicalLocation"; + N_REGION : constant String := "region"; + N_RELATED_LOCATIONS : constant String := "relatedLocations"; + N_REPLACEMENTS : constant String := "replacements"; + N_RESULTS : constant String := "results"; + N_RULES : constant String := "rules"; + N_RULE_ID : constant String := "ruleId"; + N_RUNS : constant String := "runs"; + N_SCHEMA : constant String := "$schema"; + N_START_COLUMN : constant String := "startColumn"; + N_START_LINE : constant String := "startLine"; + N_TEXT : constant String := "text"; + N_TOOL : constant String := "tool"; + N_URI : constant String := "uri"; + N_URI_BASE_ID : constant String := "uriBaseId"; + N_VERSION : constant String := "version"; + -- We are currently using SARIF 2.1.0 SARIF_Version : constant String := "2.1.0"; @@ -43,21 +81,28 @@ package body Diagnostics.SARIF_Emitter is "https://docs.oasis-open.org/sarif/sarif/v2.1.0/errata01/os/schemas/sarif-schema-2.1.0.json"; pragma Style_Checks ("M79"); + URI_Base_Id_Name : constant String := "PWD"; + -- We use the pwd as the originalUriBaseIds when providing absolute paths + -- in locations. + + Current_Dir : constant String := Get_Current_Dir; + -- Cached value of the current directory that is used in the URI_Base_Id + -- and it is also the path that all other Uri attributes will be created + -- relative to. + type Artifact_Change is record - File : String_Ptr; - -- Name of the file + File_Index : Source_File_Index; + -- Index for the source file Replacements : Edit_List; -- Regions of texts to be edited end record; - procedure Destroy (Elem : in out Artifact_Change); + procedure Destroy (Elem : in out Artifact_Change) is null; pragma Inline (Destroy); function Equals (L, R : Artifact_Change) return Boolean is - (L.File /= null - and then R.File /= null - and then L.File.all = R.File.all); + (L.File_Index = R.File_Index); package Artifact_Change_Lists is new Doubly_Linked_Lists (Element_Type => Artifact_Change, @@ -119,11 +164,12 @@ package body Diagnostics.SARIF_Emitter is -- replacements: [<Replacements>] -- } - procedure Print_Artifact_Location (File_Name : String); + procedure Print_Artifact_Location (Sfile : Source_File_Index); -- Print an artifactLocation node -- -- "artifactLocation": { - -- "URI": <File_Name> + -- "uri": <File_Name>, + -- "uriBaseId": "PWD" -- } procedure Print_Location (Loc : Labeled_Span_Type; @@ -140,7 +186,7 @@ package body Diagnostics.SARIF_Emitter is -- }, -- "physicalLocation": { -- "artifactLocation": { - -- "URI": <File_Name (Loc)> + -- "uri": <File_Name (Loc)> -- }, -- "region": { -- "startLine": <Line(Loc.Fst)>, @@ -159,13 +205,25 @@ package body Diagnostics.SARIF_Emitter is -- <Location (Primary_Span (Diag))> -- ], - procedure Print_Message (Text : String; Name : String := "message"); - -- Print a SARIF message node + procedure Print_Message (Text : String; Name : String := N_MESSAGE); + -- Print a SARIF message node. + -- + -- There are many message type nodes in the SARIF report however they can + -- have a different node <Name>. -- - -- "message": { + -- <Name>: { -- "text": <text> -- }, + procedure Print_Original_Uri_Base_Ids; + -- Print the originalUriBaseIds that holds the PWD value + -- + -- "originalUriBaseIds": { + -- "PWD": { + -- "uri": "<current_working_directory>" + -- } + -- }, + procedure Print_Related_Locations (Diag : Diagnostic_Type); -- Print a relatedLocations node that consists of multiple location nodes. -- Related locations are the non-primary spans of the diagnostic and the @@ -179,7 +237,7 @@ package body Diagnostics.SARIF_Emitter is Start_Col : Int; End_Line : Int; End_Col : Int; - Name : String := "region"); + Name : String := N_REGION); -- Print a region node. -- -- More specifically a text region node that specifies the textual @@ -271,17 +329,6 @@ package body Diagnostics.SARIF_Emitter is -- } -- } - ------------- - -- Destroy -- - ------------- - - procedure Destroy (Elem : in out Artifact_Change) - is - - begin - Free (Elem.File); - end Destroy; - -------------------------- -- Get_Artifact_Changes -- -------------------------- @@ -304,7 +351,7 @@ package body Diagnostics.SARIF_Emitter is while Artifact_Change_Lists.Has_Next (It) loop Artifact_Change_Lists.Next (It, A); - if A.File.all = To_File_Name (E.Span.Ptr) then + if A.File_Index = Get_Source_File_Index (E.Span.Ptr) then Edit_Lists.Append (A.Replacements, E); return; end if; @@ -316,7 +363,7 @@ package body Diagnostics.SARIF_Emitter is Edit_Lists.Append (Replacements, E); Artifact_Change_Lists.Append (Changes, - (File => new String'(To_File_Name (E.Span.Ptr)), + (File_Index => Get_Source_File_Index (E.Span.Ptr), Replacements => Replacements)); end; end Insert; @@ -402,12 +449,12 @@ package body Diagnostics.SARIF_Emitter is -- Print artifactLocation - Print_Artifact_Location (A.File.all); + Print_Artifact_Location (A.File_Index); Write_Char (','); NL_And_Indent; - Write_Str ("""" & "replacements" & """" & ": " & "["); + Write_Str ("""" & N_REPLACEMENTS & """" & ": " & "["); Begin_Block; NL_And_Indent; @@ -443,14 +490,53 @@ package body Diagnostics.SARIF_Emitter is -- Print_Artifact_Location -- ----------------------------- - procedure Print_Artifact_Location (File_Name : String) is - + procedure Print_Artifact_Location (Sfile : Source_File_Index) is + Full_Name : constant String := Get_Name_String (Full_Ref_Name (Sfile)); begin - Write_Str ("""" & "artifactLocation" & """" & ": " & "{"); + Write_Str ("""" & N_ARTIFACT_LOCATION & """" & ": " & "{"); Begin_Block; NL_And_Indent; - Write_String_Attribute ("uri", File_Name); + if System.OS_Lib.Is_Absolute_Path (Full_Name) then + declare + Abs_Name : constant String := + System.OS_Lib.Normalize_Pathname + (Name => Full_Name, Resolve_Links => False); + begin + -- We cannot create relative paths between different drives on + -- Windows. If the path is on a different drive than the PWD print + -- the absolute path in the URI and omit the baseUriId attribute. + + if Osint.On_Windows + and then Abs_Name (Abs_Name'First) = + Current_Dir (Current_Dir'First) + then + Write_String_Attribute + (N_URI, To_File_Uri (Abs_Name)); + else + Write_String_Attribute + (N_URI, + To_File_Uri + (Relative_Path (Abs_Name, Current_Dir))); + + Write_Char (','); + NL_And_Indent; + + Write_String_Attribute + (N_URI_BASE_ID, URI_Base_Id_Name); + end if; + end; + else + -- If the path was not absolute it was given relative to the + -- uriBaseId. + + Write_String_Attribute (N_URI, To_File_Uri (Full_Name)); + + Write_Char (','); + NL_And_Indent; + + Write_String_Attribute (N_URI_BASE_ID, URI_Base_Id_Name); + end if; End_Block; NL_And_Indent; @@ -482,13 +568,13 @@ package body Diagnostics.SARIF_Emitter is Start_Col => Col_Fst, End_Line => Line_Lst, End_Col => Col_Lst, - Name => "deletedRegion"); + Name => N_DELETED_REGION); if Replacement.Text /= null then Write_Char (','); NL_And_Indent; - Print_Message (Replacement.Text.all, "insertedContent"); + Print_Message (Replacement.Text.all, N_INSERTED_CONTENT); end if; -- End replacement @@ -512,7 +598,7 @@ package body Diagnostics.SARIF_Emitter is -- Print the message if the location has one if Fix.Description /= null then - Print_Message (Fix.Description.all, "description"); + Print_Message (Fix.Description.all, N_DESCRIPTION); Write_Char (','); NL_And_Indent; @@ -524,7 +610,7 @@ package body Diagnostics.SARIF_Emitter is A : Artifact_Change; A_It : Iterator := Iterate (Changes); begin - Write_Str ("""" & "artifactChanges" & """" & ": " & "["); + Write_Str ("""" & N_ARTIFACT_CHANGES & """" & ": " & "["); Begin_Block; while Has_Next (A_It) loop @@ -564,7 +650,7 @@ package body Diagnostics.SARIF_Emitter is First : Boolean := True; begin - Write_Str ("""" & "fixes" & """" & ": " & "["); + Write_Str ("""" & N_FIXES & """" & ": " & "["); Begin_Block; if Present (Diag.Fixes) then @@ -601,6 +687,9 @@ package body Diagnostics.SARIF_Emitter is function Compose_Command_Line return String is Buffer : Bounded_String; begin + Find_Program_Name; + Append (Buffer, Name_Buffer (1 .. Name_Len)); + Append (Buffer, ' '); Append (Buffer, Get_First_Main_File_Name); for I in 1 .. Compilation_Switches_Last loop declare @@ -616,7 +705,7 @@ package body Diagnostics.SARIF_Emitter is end Compose_Command_Line; begin - Write_Str ("""" & "invocations" & """" & ": " & "["); + Write_Str ("""" & N_INVOCATIONS & """" & ": " & "["); Begin_Block; NL_And_Indent; @@ -626,13 +715,13 @@ package body Diagnostics.SARIF_Emitter is -- Print commandLine - Write_String_Attribute ("commandLine", Compose_Command_Line); + Write_String_Attribute (N_COMMAND_LINE, Compose_Command_Line); Write_Char (','); NL_And_Indent; -- Print executionSuccessful - Write_Boolean_Attribute ("executionSuccessful", Compilation_Errors); + Write_Boolean_Attribute (N_EXECUTION_SUCCESSFUL, not Compilation_Errors); End_Block; NL_And_Indent; @@ -651,7 +740,7 @@ package body Diagnostics.SARIF_Emitter is Start_Col : Int; End_Line : Int; End_Col : Int; - Name : String := "region") + Name : String := N_REGION) is begin @@ -659,22 +748,22 @@ package body Diagnostics.SARIF_Emitter is Begin_Block; NL_And_Indent; - Write_Int_Attribute ("startLine", Start_Line); + Write_Int_Attribute (N_START_LINE, Start_Line); Write_Char (','); NL_And_Indent; - Write_Int_Attribute ("startColumn", Start_Col); + Write_Int_Attribute (N_START_COLUMN, Start_Col); Write_Char (','); NL_And_Indent; - Write_Int_Attribute ("endLine", End_Line); + Write_Int_Attribute (N_END_LINE, End_Line); Write_Char (','); NL_And_Indent; -- Convert the end of the span to the definition of the endColumn -- for a SARIF region. - Write_Int_Attribute ("endColumn", End_Col + 1); + Write_Int_Attribute (N_END_COLUMN, End_Col + 1); End_Block; NL_And_Indent; @@ -713,13 +802,13 @@ package body Diagnostics.SARIF_Emitter is NL_And_Indent; end if; - Write_Str ("""" & "physicalLocation" & """" & ": " & "{"); + Write_Str ("""" & N_PHYSICAL_LOCATION & """" & ": " & "{"); Begin_Block; NL_And_Indent; -- Print artifactLocation - Print_Artifact_Location (To_File_Name (Loc.Span.Ptr)); + Print_Artifact_Location (Get_Source_File_Index (Loc.Span.Ptr)); Write_Char (','); NL_And_Indent; @@ -751,7 +840,7 @@ package body Diagnostics.SARIF_Emitter is First : Boolean := True; begin - Write_Str ("""" & "locations" & """" & ": " & "["); + Write_Str ("""" & N_LOCATIONS & """" & ": " & "["); Begin_Block; while Has_Next (It) loop @@ -782,18 +871,43 @@ package body Diagnostics.SARIF_Emitter is -- Print_Message -- ------------------- - procedure Print_Message (Text : String; Name : String := "message") is + procedure Print_Message (Text : String; Name : String := N_MESSAGE) is begin Write_Str ("""" & Name & """" & ": " & "{"); Begin_Block; NL_And_Indent; - Write_String_Attribute ("text", Text); + Write_String_Attribute (N_TEXT, Text); End_Block; NL_And_Indent; Write_Char ('}'); end Print_Message; + --------------------------------- + -- Print_Original_Uri_Base_Ids -- + --------------------------------- + + procedure Print_Original_Uri_Base_Ids is + begin + Write_Str ("""" & N_ORIGINAL_URI_BASE_IDS & """" & ": " & "{"); + Begin_Block; + NL_And_Indent; + + Write_Str ("""" & URI_Base_Id_Name & """" & ": " & "{"); + Begin_Block; + NL_And_Indent; + + Write_String_Attribute (N_URI, To_File_Uri (Current_Dir)); + + End_Block; + NL_And_Indent; + Write_Char ('}'); + + End_Block; + NL_And_Indent; + Write_Char ('}'); + end Print_Original_Uri_Base_Ids; + ----------------------------- -- Print_Related_Locations -- ----------------------------- @@ -808,7 +922,7 @@ package body Diagnostics.SARIF_Emitter is First : Boolean := True; begin - Write_Str ("""" & "relatedLocations" & """" & ": " & "["); + Write_Str ("""" & N_RELATED_LOCATIONS & """" & ": " & "["); Begin_Block; -- Related locations are the non-primary spans of the diagnostic @@ -908,14 +1022,14 @@ package body Diagnostics.SARIF_Emitter is -- Print ruleId - Write_String_Attribute ("ruleId", "[" & To_String (Diag.Id) & "]"); + Write_String_Attribute (N_RULE_ID, "[" & To_String (Diag.Id) & "]"); Write_Char (','); NL_And_Indent; -- Print level - Write_String_Attribute ("level", Kind_To_String (Diag)); + Write_String_Attribute (N_LEVEL, Kind_To_String (Diag)); Write_Char (','); NL_And_Indent; @@ -964,7 +1078,7 @@ package body Diagnostics.SARIF_Emitter is First : Boolean := True; begin - Write_Str ("""" & "results" & """" & ": " & "["); + Write_Str ("""" & N_RESULTS & """" & ": " & "["); Begin_Block; if Present (Diags) then @@ -998,14 +1112,14 @@ package body Diagnostics.SARIF_Emitter is Begin_Block; NL_And_Indent; - Write_String_Attribute ("id", "[" & To_String (Diag.Id) & "]"); + Write_String_Attribute (N_ID, "[" & To_String (Diag.Id) & "]"); Write_Char (','); NL_And_Indent; if Human_Id = null then - Write_String_Attribute ("name", "Uncategorized_Diagnostic"); + Write_String_Attribute (N_NAME, "Uncategorized_Diagnostic"); else - Write_String_Attribute ("name", Human_Id.all); + Write_String_Attribute (N_NAME, Human_Id.all); end if; End_Block; @@ -1027,7 +1141,7 @@ package body Diagnostics.SARIF_Emitter is First : Boolean := True; begin - Write_Str ("""" & "rules" & """" & ": " & "["); + Write_Str ("""" & N_RULES & """" & ": " & "["); Begin_Block; while Has_Next (It) loop @@ -1056,23 +1170,23 @@ package body Diagnostics.SARIF_Emitter is procedure Print_Tool (Diags : Diagnostic_List) is begin - Write_Str ("""" & "tool" & """" & ": " & "{"); + Write_Str ("""" & N_TOOL & """" & ": " & "{"); Begin_Block; NL_And_Indent; -- -- Attributes of tool - Write_Str ("""" & "driver" & """" & ": " & "{"); + Write_Str ("""" & N_DRIVER & """" & ": " & "{"); Begin_Block; NL_And_Indent; -- Attributes of tool.driver - Write_String_Attribute ("name", "GNAT"); + Write_String_Attribute (N_NAME, "GNAT"); Write_Char (','); NL_And_Indent; - Write_String_Attribute ("version", Gnat_Version_String); + Write_String_Attribute (N_VERSION, Gnat_Version_String); Write_Char (','); NL_And_Indent; @@ -1100,7 +1214,7 @@ package body Diagnostics.SARIF_Emitter is procedure Print_Runs (Diags : Diagnostic_List) is begin - Write_Str ("""" & "runs" & """" & ": " & "["); + Write_Str ("""" & N_RUNS & """" & ": " & "["); Begin_Block; NL_And_Indent; @@ -1124,6 +1238,10 @@ package body Diagnostics.SARIF_Emitter is Write_Char (','); NL_And_Indent; + Print_Original_Uri_Base_Ids; + Write_Char (','); + NL_And_Indent; + -- A run consists of results Print_Results (Diags); @@ -1153,11 +1271,11 @@ package body Diagnostics.SARIF_Emitter is Begin_Block; NL_And_Indent; - Write_String_Attribute ("$schema", SARIF_Schema); + Write_String_Attribute (N_SCHEMA, SARIF_Schema); Write_Char (','); NL_And_Indent; - Write_String_Attribute ("version", SARIF_Version); + Write_String_Attribute (N_VERSION, SARIF_Version); Write_Char (','); NL_And_Indent; diff --git a/gcc/ada/doc/gnat_rm/implementation_defined_attributes.rst b/gcc/ada/doc/gnat_rm/implementation_defined_attributes.rst index f051810..86d2a81 100644 --- a/gcc/ada/doc/gnat_rm/implementation_defined_attributes.rst +++ b/gcc/ada/doc/gnat_rm/implementation_defined_attributes.rst @@ -1629,9 +1629,9 @@ Attribute Valid_Value .. index:: Valid_Value The ``'Valid_Value`` attribute is defined for enumeration types other than -those in package Standard. This attribute is a function that takes -a String, and returns Boolean. ``T'Valid_Value (S)`` returns True -if and only if ``T'Value (S)`` would not raise Constraint_Error. +those in package Standard or types derived from those types. This attribute is +a function that takes a String, and returns Boolean. ``T'Valid_Value (S)`` +returns True if and only if ``T'Value (S)`` would not raise Constraint_Error. Attribute Valid_Scalars ======================= diff --git a/gcc/ada/doc/gnat_ugn/platform_specific_information.rst b/gcc/ada/doc/gnat_ugn/platform_specific_information.rst index f2fc737..6493a06 100644 --- a/gcc/ada/doc/gnat_ugn/platform_specific_information.rst +++ b/gcc/ada/doc/gnat_ugn/platform_specific_information.rst @@ -2212,11 +2212,12 @@ Setting Stack Size from ``gnatlink`` You can specify the program stack size at link time. On most versions of Windows, starting with XP, this is mostly useful to set the size of the main stack (environment task). The other task stacks are set with -pragma Storage_Size or with the *gnatbind -d* command. +pragma Storage_Size or with the *gnatbind -d* command. The specified size will +become the reserved memory size of the underlying thread. Since very old versions of Windows (2000, NT4, etc.) don't allow setting the -reserve size of individual tasks, the link-time stack size applies to all -tasks, and pragma Storage_Size has no effect. +reserve size of individual tasks, for those versions the link-time stack size +applies to all tasks, and pragma Storage_Size has no effect. In particular, Stack Overflow checks are made against this link-time specified size. diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index 7cb26ce..f2e7ad7 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -4956,6 +4956,14 @@ package body Exp_Aggr is -- type using the computable sizes of the aggregate and its sub- -- aggregates. + function Build_Two_Pass_Aggr_Code + (Lhs : Node_Id; + Aggr_Typ : out Entity_Id) return List_Id; + -- The aggregate consists only of iterated associations and Lhs is an + -- expression containing the location of the anonymous object, which + -- may be built in place. Returns the dynamic subtype of the aggregate + -- in Aggr_Typ and the list of statements needed to build it. + procedure Check_Bounds (Aggr_Bounds_Node, Index_Bounds_Node : Node_Id); -- Checks that the bounds of Aggr_Bounds are within the bounds defined -- by Index_Bounds. For null array aggregate (Ada 2022) check that the @@ -4983,7 +4991,7 @@ package body Exp_Aggr is -- built directly into the target of an assignment, the target must -- be free of side effects. N is the target of the assignment. - procedure Two_Pass_Aggregate_Expansion (N : Node_Id); + procedure Two_Pass_Aggregate_Expansion; -- If the aggregate consists only of iterated associations then the -- aggregate is constructed in two steps: -- a) Build an expression to compute the number of elements @@ -5053,6 +5061,221 @@ package body Exp_Aggr is Freeze_Itype (Agg_Type, N); end Build_Constrained_Type; + ------------------------------ + -- Build_Two_Pass_Aggr_Code -- + ------------------------------ + + function Build_Two_Pass_Aggr_Code + (Lhs : Node_Id; + Aggr_Typ : out Entity_Id) return List_Id + is + Index_Id : constant Entity_Id := Make_Temporary (Loc, 'I', N); + Index_Type : constant Entity_Id := Etype (First_Index (Typ)); + Index_Base : constant Entity_Id := Base_Type (Index_Type); + Size_Id : constant Entity_Id := Make_Temporary (Loc, 'I', N); + Size_Type : constant Entity_Id := + Integer_Type_For + (Esize (Index_Base), Is_Unsigned_Type (Index_Base)); + + Assoc : Node_Id; + Incr : Node_Id; + Iter : Node_Id; + New_Comp : Node_Id; + One_Loop : Node_Id; + Iter_Id : Entity_Id; + + Aggr_Code : List_Id; + Size_Expr_Code : List_Id; + + begin + Size_Expr_Code := New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => Size_Id, + Object_Definition => New_Occurrence_Of (Size_Type, Loc), + Expression => Make_Integer_Literal (Loc, 0))); + + -- First pass: execute the iterators to count the number of elements + -- that will be generated. + + Assoc := First (Component_Associations (N)); + while Present (Assoc) loop + Iter := Iterator_Specification (Assoc); + Iter_Id := Defining_Identifier (Iter); + Incr := + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Size_Id, Loc), + Expression => + Make_Op_Add (Loc, + Left_Opnd => New_Occurrence_Of (Size_Id, Loc), + Right_Opnd => Make_Integer_Literal (Loc, 1))); + + -- Avoid using the same iterator definition in both loops by + -- creating a new iterator for each loop and mapping it over the + -- original iterator references. + + One_Loop := + Make_Implicit_Loop_Statement (N, + Iteration_Scheme => + Make_Iteration_Scheme (Loc, + Iterator_Specification => + New_Copy_Tree (Iter, + Map => New_Elmt_List (Iter_Id, New_Copy (Iter_Id)))), + Statements => New_List (Incr)); + + Append (One_Loop, Size_Expr_Code); + Next (Assoc); + end loop; + + Insert_Actions (N, Size_Expr_Code); + + -- Build a constrained subtype with the bounds deduced from + -- the size computed above and declare the aggregate object. + -- The index type is some discrete type, so the bounds of the + -- constrained subtype are computed as T'Val (integer bounds). + + declare + -- Pos_Lo := Index_Type'Pos (Index_Type'First) + + Pos_Lo : constant Node_Id := + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Index_Type, Loc), + Attribute_Name => Name_Pos, + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Index_Type, Loc), + Attribute_Name => Name_First))); + + -- Corresponding index value, i.e. Index_Type'First + + Aggr_Lo : constant Node_Id := + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Index_Type, Loc), + Attribute_Name => Name_First); + + -- Pos_Hi := Pos_Lo + Size - 1 + + Pos_Hi : constant Node_Id := + Make_Op_Add (Loc, + Left_Opnd => Pos_Lo, + Right_Opnd => + Make_Op_Subtract (Loc, + Left_Opnd => New_Occurrence_Of (Size_Id, Loc), + Right_Opnd => Make_Integer_Literal (Loc, 1))); + + -- Corresponding index value + + Aggr_Hi : constant Node_Id := + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Index_Type, Loc), + Attribute_Name => Name_Val, + Expressions => New_List (Pos_Hi)); + + begin + Aggr_Typ := Make_Temporary (Loc, 'T'); + + Insert_Action (N, + Make_Subtype_Declaration (Loc, + Defining_Identifier => Aggr_Typ, + Subtype_Indication => + Make_Subtype_Indication (Loc, + Subtype_Mark => + New_Occurrence_Of (Base_Type (Typ), Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint + (Loc, + Constraints => + New_List (Make_Range (Loc, Aggr_Lo, Aggr_Hi)))))); + end; + + -- Second pass: use the iterators to generate the elements of the + -- aggregate. We assume that the second evaluation of each iterator + -- generates the same number of elements as the first pass, and thus + -- consider that the execution is erroneous (even if the RM does not + -- state this explicitly) if the number of elements generated differs + -- between first and second pass. + + Assoc := First (Component_Associations (N)); + + -- Initialize insertion position to first array component + + Aggr_Code := New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => Index_Id, + Object_Definition => + New_Occurrence_Of (Index_Type, Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => New_Copy_Tree (Lhs), + Attribute_Name => Name_First))); + + while Present (Assoc) loop + Iter := Iterator_Specification (Assoc); + Iter_Id := Defining_Identifier (Iter); + New_Comp := + Make_OK_Assignment_Statement (Loc, + Name => + Make_Indexed_Component (Loc, + Prefix => New_Copy_Tree (Lhs), + Expressions => + New_List (New_Occurrence_Of (Index_Id, Loc))), + Expression => Copy_Separate_Tree (Expression (Assoc))); + + -- Arrange for the component to be adjusted if need be (the call + -- will be generated by Make_Tag_Ctrl_Assignment). + + if Needs_Finalization (Ctyp) + and then not Is_Inherently_Limited_Type (Ctyp) + then + Set_No_Finalize_Actions (New_Comp); + else + Set_No_Ctrl_Actions (New_Comp); + end if; + + -- Advance index position for insertion + + Incr := + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Index_Id, Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Index_Type, Loc), + Attribute_Name => Name_Succ, + Expressions => + New_List (New_Occurrence_Of (Index_Id, Loc)))); + + -- Add guard to skip last increment when upper bound is reached + + Incr := + Make_If_Statement (Loc, + Condition => + Make_Op_Ne (Loc, + Left_Opnd => New_Occurrence_Of (Index_Id, Loc), + Right_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Index_Type, Loc), + Attribute_Name => Name_Last)), + Then_Statements => New_List (Incr)); + + -- Avoid using the same iterator definition in both loops by + -- creating a new iterator for each loop and mapping it over + -- the original iterator references. + + One_Loop := + Make_Implicit_Loop_Statement (N, + Iteration_Scheme => + Make_Iteration_Scheme (Loc, + Iterator_Specification => + New_Copy_Tree (Iter, + Map => New_Elmt_List (Iter_Id, New_Copy (Iter_Id)))), + Statements => New_List (New_Comp, Incr)); + + Append (One_Loop, Aggr_Code); + Next (Assoc); + end loop; + + return Aggr_Code; + end Build_Two_Pass_Aggr_Code; + ------------------ -- Check_Bounds -- ------------------ @@ -5596,214 +5819,98 @@ package body Exp_Aggr is -- Two_Pass_Aggregate_Expansion -- ---------------------------------- - procedure Two_Pass_Aggregate_Expansion (N : Node_Id) is - Loc : constant Source_Ptr := Sloc (N); - Comp_Type : constant Entity_Id := Etype (N); - Index_Id : constant Entity_Id := Make_Temporary (Loc, 'I', N); - Index_Type : constant Entity_Id := Etype (First_Index (Etype (N))); - Index_Base : constant Entity_Id := Base_Type (Index_Type); - Size_Id : constant Entity_Id := Make_Temporary (Loc, 'I', N); - Size_Type : constant Entity_Id := - Integer_Type_For - (Esize (Index_Base), Is_Unsigned_Type (Index_Base)); - TmpE : constant Entity_Id := Make_Temporary (Loc, 'A', N); - - Assoc : Node_Id := First (Component_Associations (N)); - Incr : Node_Id; - Iter : Node_Id; - New_Comp : Node_Id; - One_Loop : Node_Id; - Iter_Id : Entity_Id; - - Size_Expr_Code : List_Id; - Insertion_Code : List_Id := New_List; + procedure Two_Pass_Aggregate_Expansion is + Aggr_Code : List_Id; + Aggr_Typ : Entity_Id; + Lhs : Node_Id; + Obj_Id : Entity_Id; + Par : Node_Id; begin - Size_Expr_Code := New_List ( - Make_Object_Declaration (Loc, - Defining_Identifier => Size_Id, - Object_Definition => New_Occurrence_Of (Size_Type, Loc), - Expression => Make_Integer_Literal (Loc, 0))); - - -- First pass: execute the iterators to count the number of elements - -- that will be generated. - - while Present (Assoc) loop - Iter := Iterator_Specification (Assoc); - Iter_Id := Defining_Identifier (Iter); - Incr := Make_Assignment_Statement (Loc, - Name => New_Occurrence_Of (Size_Id, Loc), - Expression => - Make_Op_Add (Loc, - Left_Opnd => New_Occurrence_Of (Size_Id, Loc), - Right_Opnd => Make_Integer_Literal (Loc, 1))); - - -- Avoid using the same iterator definition in both loops by - -- creating a new iterator for each loop and mapping it over the - -- original iterator references. - - One_Loop := Make_Implicit_Loop_Statement (N, - Iteration_Scheme => - Make_Iteration_Scheme (Loc, - Iterator_Specification => - New_Copy_Tree (Iter, - Map => New_Elmt_List (Iter_Id, New_Copy (Iter_Id)))), - Statements => New_List (Incr)); - - Append (One_Loop, Size_Expr_Code); - Next (Assoc); + Par := Parent (N); + while Nkind (Par) = N_Qualified_Expression loop + Par := Parent (Par); end loop; - Insert_Actions (N, Size_Expr_Code); - - -- Build a constrained subtype with the bounds deduced from - -- the size computed above and declare the aggregate object. - -- The index type is some discrete type, so the bounds of the - -- constrained subtype are computed as T'Val (integer bounds). - - declare - -- Pos_Lo := Index_Type'Pos (Index_Type'First) - - Pos_Lo : constant Node_Id := - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Index_Type, Loc), - Attribute_Name => Name_Pos, - Expressions => New_List ( - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Index_Type, Loc), - Attribute_Name => Name_First))); - - -- Corresponding index value, i.e. Index_Type'First + -- If the aggregate is the initialization expression of an object + -- declaration, we always build the aggregate in place, although + -- this is required only for immutably limited types and types + -- that need finalization, see RM 7.6(17.2/3-17.3/3). - Aggr_Lo : constant Node_Id := - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Index_Type, Loc), - Attribute_Name => Name_First); - - -- Pos_Hi := Pos_Lo + Size - 1 - - Pos_Hi : constant Node_Id := - Make_Op_Add (Loc, - Left_Opnd => Pos_Lo, - Right_Opnd => - Make_Op_Subtract (Loc, - Left_Opnd => New_Occurrence_Of (Size_Id, Loc), - Right_Opnd => Make_Integer_Literal (Loc, 1))); - - -- Corresponding index value - - Aggr_Hi : constant Node_Id := - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Index_Type, Loc), - Attribute_Name => Name_Val, - Expressions => New_List (Pos_Hi)); - - SubE : constant Entity_Id := Make_Temporary (Loc, 'T'); - SubD : constant Node_Id := - Make_Subtype_Declaration (Loc, - Defining_Identifier => SubE, - Subtype_Indication => - Make_Subtype_Indication (Loc, - Subtype_Mark => - New_Occurrence_Of (Etype (Comp_Type), Loc), - Constraint => - Make_Index_Or_Discriminant_Constraint - (Loc, - Constraints => - New_List (Make_Range (Loc, Aggr_Lo, Aggr_Hi))))); - - -- Create a temporary array of the above subtype which - -- will be used to capture the aggregate assignments. - - TmpD : constant Node_Id := - Make_Object_Declaration (Loc, - Defining_Identifier => TmpE, - Object_Definition => New_Occurrence_Of (SubE, Loc)); - - begin - Insert_Actions (N, New_List (SubD, TmpD)); - end; - - -- Second pass: use the iterators to generate the elements of the - -- aggregate. Insertion index starts at Index_Type'First. We - -- assume that the second evaluation of each iterator generates - -- the same number of elements as the first pass, and consider - -- that the execution is erroneous (even if the RM does not state - -- this explicitly) if the number of elements generated differs - -- between first and second pass. - - Assoc := First (Component_Associations (N)); + if Nkind (Par) = N_Object_Declaration then + Obj_Id := Defining_Identifier (Par); + Lhs := New_Occurrence_Of (Obj_Id, Loc); + Set_Assignment_OK (Lhs); + Aggr_Code := Build_Two_Pass_Aggr_Code (Lhs, Aggr_Typ); - -- Initialize insertion position to first array component. + -- Save the last assignment statement associated with the + -- aggregate when building a controlled object. This last + -- assignment is used by the finalization machinery when + -- marking an object as successfully initialized. - Insertion_Code := New_List ( - Make_Object_Declaration (Loc, - Defining_Identifier => Index_Id, - Object_Definition => - New_Occurrence_Of (Index_Type, Loc), - Expression => - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Index_Type, Loc), - Attribute_Name => Name_First))); + if Needs_Finalization (Typ) then + Mutate_Ekind (Obj_Id, E_Variable); + Set_Last_Aggregate_Assignment (Obj_Id, Last (Aggr_Code)); + end if; - while Present (Assoc) loop - Iter := Iterator_Specification (Assoc); - Iter_Id := Defining_Identifier (Iter); - New_Comp := Make_Assignment_Statement (Loc, - Name => - Make_Indexed_Component (Loc, - Prefix => New_Occurrence_Of (TmpE, Loc), - Expressions => - New_List (New_Occurrence_Of (Index_Id, Loc))), - Expression => Copy_Separate_Tree (Expression (Assoc))); + -- If a transient scope has been created around the declaration, + -- we need to attach the code to it so that finalization actions + -- of the declaration will be inserted after it; otherwise, we + -- directly insert it after the declaration. In both cases, the + -- code will be analyzed after the declaration is processed, i.e. + -- once the actual subtype of the object is established. - -- Advance index position for insertion. + if Scope_Is_Transient and then Par = Node_To_Be_Wrapped then + Store_After_Actions_In_Scope_Without_Analysis (Aggr_Code); + else + Insert_List_After (Par, Aggr_Code); + end if; - Incr := Make_Assignment_Statement (Loc, - Name => New_Occurrence_Of (Index_Id, Loc), - Expression => - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Index_Type, Loc), - Attribute_Name => Name_Succ, - Expressions => - New_List (New_Occurrence_Of (Index_Id, Loc)))); + Set_Etype (N, Aggr_Typ); + Set_No_Initialization (Par); - -- Add guard to skip last increment when upper bound is reached. + -- Likewise if it is the qualified expression of an allocator but, + -- in this case, we wait until after Expand_Allocator_Expression + -- rewrites the allocator as the initialization expression of an + -- object declaration, so that we have the left-hand side. - Incr := Make_If_Statement (Loc, - Condition => - Make_Op_Ne (Loc, - Left_Opnd => New_Occurrence_Of (Index_Id, Loc), - Right_Opnd => - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Index_Type, Loc), - Attribute_Name => Name_Last)), - Then_Statements => New_List (Incr)); + elsif Nkind (Par) = N_Allocator then + if Nkind (Parent (Par)) = N_Object_Declaration + and then + not Comes_From_Source (Defining_Identifier (Parent (Par))) + then + Obj_Id := Defining_Identifier (Parent (Par)); + Lhs := + Make_Explicit_Dereference (Loc, + Prefix => New_Occurrence_Of (Obj_Id, Loc)); + Set_Assignment_OK (Lhs); + Aggr_Code := Build_Two_Pass_Aggr_Code (Lhs, Aggr_Typ); - -- Avoid using the same iterator definition in both loops by - -- creating a new iterator for each loop and mapping it over the - -- original iterator references. + Insert_Actions_After (Parent (Par), Aggr_Code); - One_Loop := Make_Implicit_Loop_Statement (N, - Iteration_Scheme => - Make_Iteration_Scheme (Loc, - Iterator_Specification => - New_Copy_Tree (Iter, - Map => New_Elmt_List (Iter_Id, New_Copy (Iter_Id)))), - Statements => New_List (New_Comp, Incr)); + Set_Expression (Par, New_Occurrence_Of (Aggr_Typ, Loc)); + Set_No_Initialization (Par); + end if; - Append (One_Loop, Insertion_Code); - Next (Assoc); - end loop; + -- Otherwise we create a temporary for the anonymous object and + -- replace the aggregate with the temporary. - Insert_Actions (N, Insertion_Code); + else + Obj_Id := Make_Temporary (Loc, 'A', N); + Lhs := New_Occurrence_Of (Obj_Id, Loc); + Set_Assignment_OK (Lhs); - -- Depending on context this may not work for build-in-place - -- arrays ??? + Aggr_Code := Build_Two_Pass_Aggr_Code (Lhs, Aggr_Typ); + Prepend_To (Aggr_Code, + Make_Object_Declaration (Loc, + Defining_Identifier => Obj_Id, + Object_Definition => New_Occurrence_Of (Aggr_Typ, Loc))); - Rewrite (N, New_Occurrence_Of (TmpE, Loc)); + Insert_Actions (N, Aggr_Code); + Rewrite (N, Lhs); + Analyze_And_Resolve (N, Aggr_Typ); + end if; end Two_Pass_Aggregate_Expansion; -- Local variables @@ -5829,7 +5936,7 @@ package body Exp_Aggr is -- Aggregates that require a two-pass expansion are handled separately elsif Is_Two_Pass_Aggregate (N) then - Two_Pass_Aggregate_Expansion (N); + Two_Pass_Aggregate_Expansion; return; -- Do not attempt expansion if error already detected. We may reach this @@ -6002,12 +6109,11 @@ package body Exp_Aggr is -- static type imposed by the context. declare - Itype : constant Entity_Id := Etype (N); Index : Node_Id; Needs_Type : Boolean := False; begin - Index := First_Index (Itype); + Index := First_Index (Typ); while Present (Index) loop if not Is_OK_Static_Subtype (Etype (Index)) then Needs_Type := True; @@ -6019,7 +6125,7 @@ package body Exp_Aggr is if Needs_Type then Build_Constrained_Type (Positional => True); - Rewrite (N, Unchecked_Convert_To (Itype, N)); + Rewrite (N, Unchecked_Convert_To (Typ, N)); Analyze (N); end if; end; @@ -6147,7 +6253,7 @@ package body Exp_Aggr is then Tmp := Name (Parent_Node); - if Etype (Tmp) /= Etype (N) then + if Etype (Tmp) /= Typ then Apply_Length_Check (N, Etype (Tmp)); if Nkind (N) = N_Raise_Constraint_Error then @@ -7362,7 +7468,7 @@ package body Exp_Aggr is -- Likewise if the aggregate is the qualified expression of an allocator -- but, in this case, we wait until after Expand_Allocator_Expression -- rewrites the allocator as the initialization expression of an object - -- declaration to have the left hand side. + -- declaration, so that we have the left-hand side. elsif Nkind (Par) = N_Allocator then if Nkind (Parent (Par)) = N_Object_Declaration diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index b896228..4e0052e 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -88,8 +88,10 @@ package body Exp_Attr is function Attribute_Op_Hash (Id : Entity_Id) return Header_Num is (Header_Num (Id mod Map_Size)); - -- Cache used to avoid building duplicate subprograms for a single - -- type/streaming-attribute pair. + -- Caches used to avoid building duplicate subprograms for a single + -- type/attribute pair (where the attribute is either Put_Image or + -- one of the four streaming attributes). The type used as a key in + -- in accessing these maps should not be the entity of a subtype. package Read_Map is new GNAT.HTable.Simple_HTable (Header_Num => Header_Num, @@ -282,8 +284,8 @@ package body Exp_Attr is (In_Same_Extended_Unit (Subp_Unit, Attr_Ref_Unit) -- If subp declared in unit body, then we don't want to refer -- to it from within unit spec so return False in that case. - and then not (Body_Required (Attr_Ref_Unit) - and not Body_Required (Subp_Unit))); + and then not (not Is_Body (Unit (Attr_Ref_Unit)) + and Is_Body (Unit (Subp_Unit)))); -- Returns True if it is ok to refer to a cached subprogram declared in -- Subp_Unit from the point of an attribute reference occurring in -- Attr_Ref_Unit. Both arguments are usually N_Compilation_Nodes, @@ -4669,7 +4671,7 @@ package body Exp_Attr is end if; if not Is_Tagged_Type (P_Type) then - Cached_Attribute_Ops.Input_Map.Set (P_Type, Fname); + Cached_Attribute_Ops.Input_Map.Set (U_Type, Fname); end if; end Input; @@ -5750,7 +5752,7 @@ package body Exp_Attr is Rewrite_Attribute_Proc_Call (Pname); if not Is_Tagged_Type (P_Type) then - Cached_Attribute_Ops.Output_Map.Set (P_Type, Pname); + Cached_Attribute_Ops.Output_Map.Set (U_Type, Pname); end if; end Output; @@ -6669,7 +6671,7 @@ package body Exp_Attr is Rewrite_Attribute_Proc_Call (Pname); if not Is_Tagged_Type (P_Type) then - Cached_Attribute_Ops.Read_Map.Set (P_Type, Pname); + Cached_Attribute_Ops.Read_Map.Set (U_Type, Pname); end if; end Read; @@ -8349,7 +8351,7 @@ package body Exp_Attr is Rewrite_Attribute_Proc_Call (Pname); if not Is_Tagged_Type (P_Type) then - Cached_Attribute_Ops.Write_Map.Set (P_Type, Pname); + Cached_Attribute_Ops.Write_Map.Set (U_Type, Pname); end if; end Write; @@ -8951,15 +8953,22 @@ package body Exp_Attr is return Empty; end if; - if Nam = TSS_Stream_Read then - Ent := Cached_Attribute_Ops.Read_Map.Get (Typ); - elsif Nam = TSS_Stream_Write then - Ent := Cached_Attribute_Ops.Write_Map.Get (Typ); - elsif Nam = TSS_Stream_Input then - Ent := Cached_Attribute_Ops.Input_Map.Get (Typ); - elsif Nam = TSS_Stream_Output then - Ent := Cached_Attribute_Ops.Output_Map.Get (Typ); - end if; + declare + function U_Base return Entity_Id is + (Underlying_Type (Base_Type (Typ))); + -- Return the right type node for use in a C_A_O map lookup. + -- In particular, we do not want the entity for a subtype. + begin + if Nam = TSS_Stream_Read then + Ent := Cached_Attribute_Ops.Read_Map.Get (U_Base); + elsif Nam = TSS_Stream_Write then + Ent := Cached_Attribute_Ops.Write_Map.Get (U_Base); + elsif Nam = TSS_Stream_Input then + Ent := Cached_Attribute_Ops.Input_Map.Get (U_Base); + elsif Nam = TSS_Stream_Output then + Ent := Cached_Attribute_Ops.Output_Map.Get (U_Base); + end if; + end; Cached_Attribute_Ops.Validate_Cached_Candidate (Subp => Ent, Attr_Ref => Attr_Ref); diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index bc46fd3..fa87149 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -5423,18 +5423,12 @@ package body Exp_Ch3 is -- with an initial value, its Init_Proc will never be called. The -- initial value itself may have been expanded into assignments, -- in which case the declaration has the No_Initialization flag. - -- The exception is when the initial value is a 2-pass aggregate, - -- because the special expansion used for it creates a temporary - -- that needs a fully-fledged initialization. if Is_Itype (Base) and then Nkind (Associated_Node_For_Itype (Base)) = N_Object_Declaration and then - ((Present (Expression (Associated_Node_For_Itype (Base))) - and then not - Is_Two_Pass_Aggregate - (Expression (Associated_Node_For_Itype (Base)))) + (Present (Expression (Associated_Node_For_Itype (Base))) or else No_Initialization (Associated_Node_For_Itype (Base))) then null; @@ -8293,12 +8287,15 @@ package body Exp_Ch3 is -- where the object has been initialized by a call to a function -- returning on the primary stack (see Expand_Ctrl_Function_Call) -- since no copy occurred, given that the type is by-reference. + -- Likewise if it is initialized by a 2-pass aggregate, since the + -- actual initialization will only occur during the second pass. -- Similarly, no adjustment is needed if we are going to rewrite -- the object declaration into a renaming declaration. if Needs_Finalization (Typ) and then not Is_Inherently_Limited_Type (Typ) and then Nkind (Expr_Q) /= N_Function_Call + and then not Is_Two_Pass_Aggregate (Expr_Q) and then not Rewrite_As_Renaming then Adj_Call := diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 82978c7..eb9fb6b 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -769,7 +769,6 @@ package body Exp_Ch4 is -- Local variables Aggr_In_Place : Boolean; - Container_Aggr : Boolean; Delayed_Cond_Expr : Boolean; TagT : Entity_Id := Empty; @@ -865,13 +864,15 @@ package body Exp_Ch4 is Aggr_In_Place := Is_Delayed_Aggregate (Exp); Delayed_Cond_Expr := Is_Delayed_Conditional_Expression (Exp); - Container_Aggr := Nkind (Exp) = N_Aggregate - and then Has_Aspect (T, Aspect_Aggregate); - -- An allocator with a container aggregate as qualified expression must - -- be rewritten into the form expected by Expand_Container_Aggregate. + -- An allocator with a container aggregate, resp. a 2-pass aggregate, + -- as qualified expression must be rewritten into the form expected by + -- Expand_Container_Aggregate, resp. Two_Pass_Aggregate_Expansion. - if Container_Aggr then + if Nkind (Exp) = N_Aggregate + and then (Has_Aspect (T, Aspect_Aggregate) + or else Is_Two_Pass_Aggregate (Exp)) + then Temp := Make_Temporary (Loc, 'P', N); Set_Analyzed (Exp, False); Insert_Action (N, @@ -15035,10 +15036,11 @@ package body Exp_Ch4 is -- Handle entities from the limited view - Orig_Right_Type : constant Entity_Id := Available_View (Etype (Right)); + Orig_Right_Type : constant Entity_Id := + Base_Type (Available_View (Etype (Right))); Full_R_Typ : Entity_Id; - Left_Type : Entity_Id := Available_View (Etype (Left)); + Left_Type : Entity_Id := Base_Type (Available_View (Etype (Left))); Right_Type : Entity_Id := Orig_Right_Type; Obj_Tag : Node_Id; diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 7e46454..f85d977 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -2470,11 +2470,6 @@ package body Exp_Ch6 is -- (and ensure that we have an activation chain defined for tasks -- and a Master variable). - -- Currently we limit such functions to those with inherently - -- limited result subtypes, but eventually we plan to expand the - -- functions that are treated as build-in-place to include other - -- composite result types. - -- But do not do it here for intrinsic subprograms since this will -- be done properly after the subprogram is expanded. @@ -8562,12 +8557,10 @@ package body Exp_Ch6 is procedure Make_Build_In_Place_Call_In_Anonymous_Context (Function_Call : Node_Id) is - Loc : constant Source_Ptr := Sloc (Function_Call); - Func_Call : constant Node_Id := Unqual_Conv (Function_Call); - Function_Id : Entity_Id; - Result_Subt : Entity_Id; - Return_Obj_Id : Entity_Id; - Return_Obj_Decl : Entity_Id; + Loc : constant Source_Ptr := Sloc (Function_Call); + Func_Call : constant Node_Id := Unqual_Conv (Function_Call); + Function_Id : Entity_Id; + Result_Subt : Entity_Id; begin -- If the call has already been processed to add build-in-place actuals @@ -8580,10 +8573,6 @@ package body Exp_Ch6 is return; end if; - -- Mark the call as processed as a build-in-place call - - Set_Is_Expanded_Build_In_Place_Call (Func_Call); - if Is_Entity_Name (Name (Func_Call)) then Function_Id := Entity (Name (Func_Call)); @@ -8601,8 +8590,13 @@ package body Exp_Ch6 is -- If the build-in-place function returns a controlled object, then the -- object needs to be finalized immediately after the context. Since -- this case produces a transient scope, the servicing finalizer needs - -- to name the returned object. Create a temporary which is initialized - -- with the function call: + -- to name the returned object. + + -- If the build-in-place function returns a definite subtype, then an + -- object also needs to be created and an access value designating it + -- passed as an actual. + + -- Create a temporary which is initialized with the function call: -- -- Temp_Id : Func_Type := BIP_Func_Call; -- @@ -8610,75 +8604,25 @@ package body Exp_Ch6 is -- the expander using the appropriate mechanism in Make_Build_In_Place_ -- Call_In_Object_Declaration. - if Needs_Finalization (Result_Subt) then + if Needs_Finalization (Result_Subt) + or else Caller_Known_Size (Func_Call, Result_Subt) + then declare Temp_Id : constant Entity_Id := Make_Temporary (Loc, 'R'); - Temp_Decl : Node_Id; - - begin - -- Reset the guard on the function call since the following does - -- not perform actual call expansion. - - Set_Is_Expanded_Build_In_Place_Call (Func_Call, False); - - Temp_Decl := + Temp_Decl : constant Node_Id := Make_Object_Declaration (Loc, Defining_Identifier => Temp_Id, - Object_Definition => - New_Occurrence_Of (Result_Subt, Loc), - Expression => - New_Copy_Tree (Function_Call)); + Aliased_Present => True, + Object_Definition => New_Occurrence_Of (Result_Subt, Loc), + Expression => Relocate_Node (Function_Call)); + begin + Set_Assignment_OK (Temp_Decl); Insert_Action (Function_Call, Temp_Decl); - Rewrite (Function_Call, New_Occurrence_Of (Temp_Id, Loc)); Analyze (Function_Call); end; - -- When the result subtype is definite, an object of the subtype is - -- declared and an access value designating it is passed as an actual. - - elsif Caller_Known_Size (Func_Call, Result_Subt) then - - -- Create a temporary object to hold the function result - - Return_Obj_Id := Make_Temporary (Loc, 'R'); - Set_Etype (Return_Obj_Id, Result_Subt); - - Return_Obj_Decl := - Make_Object_Declaration (Loc, - Defining_Identifier => Return_Obj_Id, - Aliased_Present => True, - Object_Definition => New_Occurrence_Of (Result_Subt, Loc)); - - Set_No_Initialization (Return_Obj_Decl); - - Insert_Action (Func_Call, Return_Obj_Decl); - - -- When the function has a controlling result, an allocation-form - -- parameter must be passed indicating that the caller is allocating - -- the result object. This is needed because such a function can be - -- called as a dispatching operation and must be treated similarly - -- to functions with unconstrained result subtypes. - - Add_Unconstrained_Actuals_To_Build_In_Place_Call - (Func_Call, Function_Id, Alloc_Form => Caller_Allocation); - - Add_Collection_Actual_To_Build_In_Place_Call - (Func_Call, Function_Id); - - Add_Task_Actuals_To_Build_In_Place_Call - (Func_Call, Function_Id, Make_Identifier (Loc, Name_uMaster)); - - -- Add an implicit actual to the function call that provides access - -- to the caller's return object. - - Add_Access_Actual_To_Build_In_Place_Call - (Func_Call, Function_Id, New_Occurrence_Of (Return_Obj_Id, Loc)); - - pragma Assert (Check_Number_Of_Actuals (Func_Call, Function_Id)); - pragma Assert (Check_BIP_Actuals (Func_Call, Function_Id)); - -- When the result subtype is unconstrained, the function must allocate -- the return object in the secondary stack, so appropriate implicit -- parameters are added to the call to indicate that. A transient @@ -8703,6 +8647,10 @@ package body Exp_Ch6 is Add_Access_Actual_To_Build_In_Place_Call (Func_Call, Function_Id, Empty); + -- Mark the call as processed as a build-in-place call + + Set_Is_Expanded_Build_In_Place_Call (Func_Call); + pragma Assert (Check_Number_Of_Actuals (Func_Call, Function_Id)); pragma Assert (Check_BIP_Actuals (Func_Call, Function_Id)); end if; @@ -9909,6 +9857,13 @@ package body Exp_Ch6 is return Skip; end if; + -- Skip calls placed in unexpanded initialization expressions + + when N_Object_Declaration => + if No_Initialization (Nod) then + return Skip; + end if; + -- Skip calls placed in subprogram specifications since function -- calls initializing default parameter values will be processed -- when the call to the subprogram is found (if the default actual diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index 67af1d7..905094c 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -2783,16 +2783,31 @@ package body Exp_Ch7 is Master_Node_Id := Make_Defining_Identifier (Master_Node_Loc, Chars => New_External_Name (Chars (Obj_Id), Suffix => "MN")); + Master_Node_Decl := Make_Master_Node_Declaration (Master_Node_Loc, Master_Node_Id, Obj_Id); Push_Scope (Scope (Obj_Id)); + + -- Avoid generating duplicate names for master nodes + + if Ekind (Obj_Id) = E_Loop_Parameter + and then + Present (Current_Entity_In_Scope (Chars (Master_Node_Id))) + then + Set_Chars (Master_Node_Id, + New_External_Name (Chars (Obj_Id), + Suffix => "MN", + Suffix_Index => -1)); + end if; + if not Has_Strict_Ctrl_Objs or else Count = 1 then Prepend_To (Decls, Master_Node_Decl); else Insert_Before (Decl, Master_Node_Decl); end if; + Analyze (Master_Node_Decl); Pop_Scope; diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index d75fd3a..dd59af9 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -9877,7 +9877,7 @@ package body Exp_Ch9 is -- (T => To_Tag_Ptr (Obj'Address).all, -- Position => -- Ada.Tags.Get_Offset_Index - -- (Ada.Tags.Tag (Concval), + -- (Concval._Tag, -- <interface dispatch table position of Ename>)); -- Note that Obj'Address is recursively expanded into a call to @@ -9898,7 +9898,9 @@ package body Exp_Ch9 is Make_Function_Call (Loc, Name => New_Occurrence_Of (RTE (RE_Get_Offset_Index), Loc), Parameter_Associations => New_List ( - Unchecked_Convert_To (RTE (RE_Tag), Concval), + Make_Attribute_Reference (Loc, + Prefix => Concval, + Attribute_Name => Name_Tag), Make_Integer_Literal (Loc, DT_Position (Entity (Ename)))))))); diff --git a/gcc/ada/exp_pakd.adb b/gcc/ada/exp_pakd.adb index 4eb93c3..f04016f 100644 --- a/gcc/ada/exp_pakd.adb +++ b/gcc/ada/exp_pakd.adb @@ -904,7 +904,8 @@ package body Exp_Pakd is -- discriminants, so we treat it as a default/per-object expression. Set_Parent (Len_Expr, Typ); - Preanalyze_Spec_Expression (Len_Expr, Standard_Long_Long_Integer); + Preanalyze_And_Resolve_Spec_Expression + (Len_Expr, Standard_Long_Long_Integer); -- Use a modular type if possible. We can do this if we have -- static bounds, and the length is small enough, and the length @@ -1525,21 +1526,24 @@ package body Exp_Pakd is Get_Base_And_Bit_Offset (Prefix (N), Base, Offset); + Offset := Unchecked_Convert_To (RTE (RE_Storage_Offset), Offset); + Rewrite (N, - Unchecked_Convert_To (RTE (RE_Address), - Make_Op_Add (Loc, - Left_Opnd => - Unchecked_Convert_To (RTE (RE_Integer_Address), - Make_Attribute_Reference (Loc, - Prefix => Base, - Attribute_Name => Name_Address)), - - Right_Opnd => - Unchecked_Convert_To (RTE (RE_Integer_Address), - Make_Op_Divide (Loc, - Left_Opnd => Offset, - Right_Opnd => - Make_Integer_Literal (Loc, System_Storage_Unit)))))); + Make_Function_Call (Loc, + Name => + Make_Expanded_Name (Loc, + Chars => Name_Op_Add, + Prefix => + New_Occurrence_Of (RTU_Entity (System_Storage_Elements), Loc), + Selector_Name => Make_Identifier (Loc, Name_Op_Add)), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => Base, + Attribute_Name => Name_Address), + Make_Op_Divide (Loc, + Left_Opnd => Offset, + Right_Opnd => + Make_Integer_Literal (Loc, System_Storage_Unit))))); Analyze_And_Resolve (N, RTE (RE_Address)); end Expand_Packed_Address_Reference; diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index b8c6a9f..77d09d9 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -1956,7 +1956,7 @@ package body Exp_Util is -- time capture the visibility of the proper package part. Set_Parent (Expr, Typ_Decl); - Preanalyze_Assert_Expression (Expr, Any_Boolean); + Preanalyze_And_Resolve_Assert_Expression (Expr, Any_Boolean); -- Save a copy of the expression with all replacements and analysis -- already taken place in case a derived type inherits the pragma. @@ -1969,8 +1969,8 @@ package body Exp_Util is -- If the pragma comes from an aspect specification, replace the -- saved expression because all type references must be substituted - -- for the call to Preanalyze_Spec_Expression in Check_Aspect_At_xxx - -- routines. + -- for the call to Preanalyze_And_Resolve_Spec_Expression in + -- Check_Aspect_At_xxx routines. if Present (DIC_Asp) then Set_Expression_Copy (DIC_Asp, New_Copy_Tree (Expr)); @@ -3217,7 +3217,7 @@ package body Exp_Util is -- part. Set_Parent (Expr, Parent (Prag_Expr)); - Preanalyze_Assert_Expression (Expr, Any_Boolean); + Preanalyze_And_Resolve_Assert_Expression (Expr, Any_Boolean); -- Save a copy of the expression when T is tagged to detect -- errors and capture the visibility of the proper package part @@ -3229,8 +3229,8 @@ package body Exp_Util is -- If the pragma comes from an aspect specification, replace -- the saved expression because all type references must be - -- substituted for the call to Preanalyze_Spec_Expression in - -- Check_Aspect_At_xxx routines. + -- substituted for the call to Preanalyze_And_Resolve_Spec_ + -- Expression in Check_Aspect_At_xxx routines. if Present (Prag_Asp) then Set_Expression_Copy (Prag_Asp, New_Copy_Tree (Expr)); @@ -10871,11 +10871,10 @@ package body Exp_Util is -- operator on private type might not be visible and won't be -- resolved. - else pragma Assert (Is_RTE (Base_Type (Typ), RE_Big_Integer) - or else - Is_RTE (Base_Type (Typ), RO_GH_Big_Integer) - or else - Is_RTE (Base_Type (Typ), RO_SP_Big_Integer)); + else + pragma Assert + (Is_RTE (Base_Type (Typ), RE_Big_Integer) + or else Is_RTE (Base_Type (Typ), RO_SP_Big_Integer)); return Make_Function_Call (Loc, Name => diff --git a/gcc/ada/fname-uf.adb b/gcc/ada/fname-uf.adb index 39a09c4..ec22ad7 100644 --- a/gcc/ada/fname-uf.adb +++ b/gcc/ada/fname-uf.adb @@ -90,8 +90,9 @@ package body Fname.UF is Table_Initial => 10, Table_Increment => 100, Table_Name => "SFN_Patterns"); - -- Table recording calls to Set_File_Name_Pattern. Note that the first two - -- entries are set to represent the standard GNAT rules for file naming. + -- Table recording calls to Set_File_Name_Pattern. Note that the last two + -- entries are set to represent the standard GNAT rules for file naming; + -- that invariant is maintained by Set_File_Name_Pattern. procedure Instantiate_SFN_Pattern (Pattern : SFN_Pattern_Entry; @@ -178,6 +179,8 @@ package body Fname.UF is --------------------------- function Get_Default_File_Name (Uname : Unit_Name_Type) return String is + L : constant Int := SFN_Patterns.Last; + Buf : Bounded_String; Pattern : SFN_Pattern_Entry; @@ -185,10 +188,10 @@ package body Fname.UF is Get_Unit_Name_String (Buf, Uname, False); if Is_Spec_Name (Uname) then - Pattern := SFN_Patterns.Table (1); + Pattern := SFN_Patterns.Table (L - 1); else pragma Assert (Is_Body_Name (Uname)); - Pattern := SFN_Patterns.Table (2); + Pattern := SFN_Patterns.Table (L); end if; Instantiate_SFN_Pattern (Pattern, Buf); diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 54b6202..ec0fb16e 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -9389,16 +9389,17 @@ package body Freeze is -- pre/postconditions during expansion of the subprogram body, the -- subprogram is already installed. - -- Call Preanalyze_Spec_Expression instead of Preanalyze_And_Resolve - -- for the sake of consistency with Analyze_Expression_Function. + -- Call Preanalyze_And_Resolve_Spec_Expression instead of Preanalyze_ + -- And_Resolve for the sake of consistency with Analyze_Expression_ + -- Function. if Def_Id /= Current_Scope then Push_Scope (Def_Id); Install_Formals (Def_Id); - Preanalyze_Spec_Expression (Dup_Expr, Typ); + Preanalyze_And_Resolve_Spec_Expression (Dup_Expr, Typ); End_Scope; else - Preanalyze_Spec_Expression (Dup_Expr, Typ); + Preanalyze_And_Resolve_Spec_Expression (Dup_Expr, Typ); end if; -- Restore certain attributes of Def_Id since the preanalysis may diff --git a/gcc/ada/gcc-interface/Make-lang.in b/gcc/ada/gcc-interface/Make-lang.in index 2158bb6..98074b7 100644 --- a/gcc/ada/gcc-interface/Make-lang.in +++ b/gcc/ada/gcc-interface/Make-lang.in @@ -562,8 +562,6 @@ GNAT_ADA_OBJS+= \ ada/libgnat/s-secsta.o \ ada/libgnat/s-soflin.o \ ada/libgnat/s-soliin.o \ - ada/libgnat/s-spark.o \ - ada/libgnat/s-spcuop.o \ ada/libgnat/s-stache.o \ ada/libgnat/s-stalib.o \ ada/libgnat/s-stoele.o \ @@ -575,11 +573,8 @@ GNAT_ADA_OBJS+= \ ada/libgnat/s-trasym.o \ ada/libgnat/s-unstyp.o \ ada/libgnat/s-valint.o \ - ada/libgnat/s-valspe.o \ ada/libgnat/s-valuns.o \ ada/libgnat/s-valuti.o \ - ada/libgnat/s-vs_int.o \ - ada/libgnat/s-vs_uns.o \ ada/libgnat/s-wchcnv.o \ ada/libgnat/s-wchcon.o \ ada/libgnat/s-wchjis.o \ diff --git a/gcc/ada/generate_minimal_reproducer.adb b/gcc/ada/generate_minimal_reproducer.adb index 66d34fe..5a5ae16 100644 --- a/gcc/ada/generate_minimal_reproducer.adb +++ b/gcc/ada/generate_minimal_reproducer.adb @@ -23,16 +23,18 @@ -- -- ------------------------------------------------------------------------------ +with Atree; with Fmap; with Fname.UF; with Lib; -with Namet; use Namet; -with Osint; use Osint; -with Output; use Output; -with Sinfo.Nodes; +with Namet; use Namet; +with Osint; use Osint; +with Output; use Output; +with Sinfo.Nodes; use Sinfo.Nodes; with System.CRTL; with System.OS_Lib; use System.OS_Lib; -with Types; use Types; +with Types; use Types; +with Uname; procedure Generate_Minimal_Reproducer is Reproducer_Generation_Failed : exception; @@ -85,6 +87,26 @@ procedure Generate_Minimal_Reproducer is Oracle_Path : constant String := Dirname & Directory_Separator & Executable_Name ("oracle"); + Main_Library_Item : constant Node_Id := Unit (Lib.Cunit (Main_Unit)); + + -- There is a special case that we need to detect: when the main library + -- item is the instantiation of a generic that has a body, and the + -- instantiation of generic bodies has started. We start by binding whether + -- the main library item is an instantiation to the following constant. + Main_Is_Instantiation : constant Boolean := + Nkind (Atree.Original_Node (Main_Library_Item)) + in N_Generic_Instantiation; + + -- If the main library item is an instantiation and its unit name is a body + -- name, it means that Make_Instance_Unit has been called. We need to use + -- the corresponding spec name to reconstruct the on-disk form of the + -- semantic closure. + Main_Unit_Name : constant Unit_Name_Type := + (if Main_Is_Instantiation + and then Uname.Is_Body_Name (Lib.Unit_Name (Main_Unit)) + then Uname.Get_Spec_Name (Lib.Unit_Name (Main_Unit)) + else Lib.Unit_Name (Main_Unit)); + Result : Integer; begin Create_Semantic_Closure_Project : @@ -118,25 +140,30 @@ begin end if; for J in Main_Unit .. Lib.Last_Unit loop - declare - Path : File_Name_Type := - Fmap.Mapped_Path_Name (Lib.Unit_File_Name (J)); - - Default_File_Name : constant String := - Fname.UF.Get_Default_File_Name (Lib.Unit_Name (J)); - - File_Copy_Path : constant String := - Src_Dir_Path & Directory_Separator & Default_File_Name; - - -- We may have synthesized units for child subprograms without - -- spec files. We need to filter out those units because we would - -- create bogus spec files that break compilation if we didn't. - Is_Synthetic_Subprogram_Spec : constant Boolean := - not Sinfo.Nodes.Comes_From_Source (Lib.Cunit (J)); - begin - if not Lib.Is_Internal_Unit (J) - and then not Is_Synthetic_Subprogram_Spec - then + -- We skip library units that fall under one of the following cases: + -- - Internal library units. + -- - Units that were synthesized for child subprograms without spec + -- files. + -- - Dummy entries that Add_Preprocessing_Dependency puts in + -- Lib.Units. + -- Those cases correspond to the conjuncts in the condition below. + if not Lib.Is_Internal_Unit (J) + and then Comes_From_Source (Lib.Cunit (J)) + and then Lib.Unit_Name (J) /= No_Unit_Name + then + declare + Path : File_Name_Type := + Fmap.Mapped_Path_Name (Lib.Unit_File_Name (J)); + + Unit_Name : constant Unit_Name_Type := + (if J = Main_Unit then Main_Unit_Name else Lib.Unit_Name (J)); + + Default_File_Name : constant String := + Fname.UF.Get_Default_File_Name (Unit_Name); + + File_Copy_Path : constant String := + Src_Dir_Path & Directory_Separator & Default_File_Name; + begin -- Mapped_Path_Name might have returned No_File. This has been -- observed for files with a Source_File_Name pragma. if Path = No_File then @@ -153,8 +180,8 @@ begin pragma Assert (Success); end; - end if; - end; + end; + end if; end loop; end Create_Semantic_Closure_Project; @@ -197,7 +224,7 @@ begin (Fmap.Mapped_Path_Name (Lib.Unit_File_Name (Main_Unit))); Default_Main_Name : constant String := - Fname.UF.Get_Default_File_Name (Lib.Unit_Name (Main_Unit)); + Fname.UF.Get_Default_File_Name (Main_Unit_Name); New_Main_Path : constant String := Src_Dir_Path & Directory_Separator & Default_Main_Name; @@ -228,7 +255,8 @@ begin Write_Eol; Write_Line (" Args : constant GNAT.OS_Lib.Argument_List :="); - Write_Str (" (new String'(""-gnatd_M"")"); + Write_Str + (" (new String'(""-quiet""), new String'(""-gnatd_M"")"); -- The following way of iterating through the command line arguments -- was copied from Set_Targ. TODO factorize??? diff --git a/gcc/ada/gnat-style.texi b/gcc/ada/gnat-style.texi index dde6ec4..0880400 100644 --- a/gcc/ada/gnat-style.texi +++ b/gcc/ada/gnat-style.texi @@ -3,7 +3,7 @@ @setfilename gnat-style.info @documentencoding UTF-8 @ifinfo -@*Generated by Sphinx 8.0.2.@* +@*Generated by Sphinx 8.2.3.@* @end ifinfo @settitle GNAT Coding Style A Guide for GNAT Developers @defindex ge @@ -19,7 +19,7 @@ @copying @quotation -GNAT Coding Style: A Guide for GNAT Developers , Jan 03, 2025 +GNAT Coding Style: A Guide for GNAT Developers , Jun 02, 2025 AdaCore diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index 97469d7..5719d0d 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -3,7 +3,7 @@ @setfilename gnat_rm.info @documentencoding UTF-8 @ifinfo -@*Generated by Sphinx 8.0.2.@* +@*Generated by Sphinx 8.2.3.@* @end ifinfo @settitle GNAT Reference Manual @defindex ge @@ -19,7 +19,7 @@ @copying @quotation -GNAT Reference Manual , Jan 03, 2025 +GNAT Reference Manual , Jun 02, 2025 AdaCore @@ -4682,8 +4682,8 @@ pragma Interrupt_State Normally certain interrupts are reserved to the implementation. Any attempt to attach an interrupt causes Program_Error to be raised, as described in RM C.3.2(22). A typical example is the @code{SIGINT} interrupt used in -many systems for an @code{Ctrl-C} interrupt. Normally this interrupt is -reserved to the implementation, so that @code{Ctrl-C} can be used to +many systems for an @code{Ctrl}-@code{C} interrupt. Normally this interrupt is +reserved to the implementation, so that @code{Ctrl}-@code{C} can be used to interrupt execution. Additionally, signals such as @code{SIGSEGV}, @code{SIGABRT}, @code{SIGFPE} and @code{SIGILL} are often mapped to specific Ada exceptions, or used to implement run-time functions such as the @@ -8837,15 +8837,15 @@ pragma Unreserve_All_Interrupts; Normally certain interrupts are reserved to the implementation. Any attempt to attach an interrupt causes Program_Error to be raised, as described in RM C.3.2(22). A typical example is the @code{SIGINT} interrupt used in -many systems for a @code{Ctrl-C} interrupt. Normally this interrupt is -reserved to the implementation, so that @code{Ctrl-C} can be used to +many systems for a @code{Ctrl}-@code{C} interrupt. Normally this interrupt is +reserved to the implementation, so that @code{Ctrl}-@code{C} can be used to interrupt execution. If the pragma @code{Unreserve_All_Interrupts} appears anywhere in any unit in a program, then all such interrupts are unreserved. This allows the program to handle these interrupts, but disables their standard functions. For example, if this pragma is used, then pressing -@code{Ctrl-C} will not automatically interrupt execution. However, +@code{Ctrl}-@code{C} will not automatically interrupt execution. However, a program can then handle the @code{SIGINT} interrupt as it chooses. For a full list of the interrupts handled in a specific implementation, @@ -12360,9 +12360,9 @@ which changes element (1,2) to 20 and (3,4) to 30. @geindex Valid_Value The @code{'Valid_Value} attribute is defined for enumeration types other than -those in package Standard. This attribute is a function that takes -a String, and returns Boolean. @code{T'Valid_Value (S)} returns True -if and only if @code{T'Value (S)} would not raise Constraint_Error. +those in package Standard or types derived from those types. This attribute is +a function that takes a String, and returns Boolean. @code{T'Valid_Value (S)} +returns True if and only if @code{T'Value (S)} would not raise Constraint_Error. @node Attribute Valid_Scalars,Attribute VADS_Size,Attribute Valid_Value,Implementation Defined Attributes @anchor{gnat_rm/implementation_defined_attributes attribute-valid-scalars}@anchor{1c5} diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index 2579b31..5331a31 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -3,7 +3,7 @@ @setfilename gnat_ugn.info @documentencoding UTF-8 @ifinfo -@*Generated by Sphinx 8.0.2.@* +@*Generated by Sphinx 8.2.3.@* @end ifinfo @settitle GNAT User's Guide for Native Platforms @defindex ge @@ -19,7 +19,7 @@ @copying @quotation -GNAT User's Guide for Native Platforms , Jan 13, 2025 +GNAT User's Guide for Native Platforms , Jun 02, 2025 AdaCore @@ -25582,11 +25582,12 @@ the breakpoint we have set. From there you can use standard You can specify the program stack size at link time. On most versions of Windows, starting with XP, this is mostly useful to set the size of the main stack (environment task). The other task stacks are set with -pragma Storage_Size or with the `gnatbind -d' command. +pragma Storage_Size or with the `gnatbind -d' command. The specified size will +become the reserved memory size of the underlying thread. Since very old versions of Windows (2000, NT4, etc.) don’t allow setting the -reserve size of individual tasks, the link-time stack size applies to all -tasks, and pragma Storage_Size has no effect. +reserve size of individual tasks, for those versions the link-time stack size +applies to all tasks, and pragma Storage_Size has no effect. In particular, Stack Overflow checks are made against this link-time specified size. diff --git a/gcc/ada/gnatls.adb b/gcc/ada/gnatls.adb index 4e549a9..6fa2327 100644 --- a/gcc/ada/gnatls.adb +++ b/gcc/ada/gnatls.adb @@ -1605,7 +1605,9 @@ procedure Gnatls is Name_Len := 0; if not Is_Absolute_Path (Self (First .. Last)) then - Add_Str_To_Name_Buffer (Get_Current_Dir); -- ??? System call + Add_Str_To_Name_Buffer + (GNAT.Directory_Operations.Get_Current_Dir); + Add_Char_To_Name_Buffer (Directory_Separator); end if; diff --git a/gcc/ada/libgnat/a-nbnbig.adb b/gcc/ada/libgnat/a-nbnbig.adb deleted file mode 100644 index e487a05..0000000 --- a/gcc/ada/libgnat/a-nbnbig.adb +++ /dev/null @@ -1,81 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- ADA.NUMERICS.BIG_NUMBERS.BIG_INTEGERS_GHOST -- --- -- --- B o d y -- --- -- --- Copyright (C) 2021-2025, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This body is provided as a work-around for a GNAT compiler bug, as GNAT --- currently does not compile instantiations of the spec with imported ghost --- generics for packages Signed_Conversions and Unsigned_Conversions. - --- Ghost code in this unit is meant for analysis only, not for run-time --- checking. This is enforced by setting the assertion policy to Ignore. - -pragma Assertion_Policy (Ghost => Ignore); - -package body Ada.Numerics.Big_Numbers.Big_Integers_Ghost with - SPARK_Mode => Off -is - - package body Signed_Conversions with - SPARK_Mode => Off - is - - function To_Big_Integer (Arg : Int) return Valid_Big_Integer is - begin - raise Program_Error; - return (null record); - end To_Big_Integer; - - function From_Big_Integer (Arg : Valid_Big_Integer) return Int is - begin - raise Program_Error; - return 0; - end From_Big_Integer; - - end Signed_Conversions; - - package body Unsigned_Conversions with - SPARK_Mode => Off - is - - function To_Big_Integer (Arg : Int) return Valid_Big_Integer is - begin - raise Program_Error; - return (null record); - end To_Big_Integer; - - function From_Big_Integer (Arg : Valid_Big_Integer) return Int is - begin - raise Program_Error; - return 0; - end From_Big_Integer; - - end Unsigned_Conversions; - -end Ada.Numerics.Big_Numbers.Big_Integers_Ghost; diff --git a/gcc/ada/libgnat/a-nbnbig.ads b/gcc/ada/libgnat/a-nbnbig.ads deleted file mode 100644 index 04aa62a..0000000 --- a/gcc/ada/libgnat/a-nbnbig.ads +++ /dev/null @@ -1,241 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- ADA.NUMERICS.BIG_NUMBERS.BIG_INTEGERS_GHOST -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - --- This package provides a reduced and non-executable implementation of the --- ARM A.5.6 defined ``Ada.Numerics.Big_Numbers.Big_Integers`` for use in --- SPARK proofs in the runtime. As it is only intended for SPARK proofs, this --- package is marked as a Ghost package and consequently does not have a --- runtime footprint. - --- Contrary to Ada.Numerics.Big_Numbers.Big_Integers, this unit does not --- depend on System or Ada.Finalization, which makes it more convenient for --- use in run-time units. Note, since it is a ghost unit, all subprograms are --- marked as imported. - --- Ghost code in this unit is meant for analysis only, not for run-time --- checking. This is enforced by setting the assertion policy to Ignore. - -pragma Assertion_Policy (Ghost => Ignore); - -package Ada.Numerics.Big_Numbers.Big_Integers_Ghost with - SPARK_Mode, - Ghost, - Pure, - Always_Terminates -is - - type Big_Integer is private - with Integer_Literal => From_Universal_Image; - -- Private type that holds the integer value - - function Is_Valid (Arg : Big_Integer) return Boolean - with - Import, - Global => null; - -- Return whether a passed big integer is valid - - subtype Valid_Big_Integer is Big_Integer - with Dynamic_Predicate => Is_Valid (Valid_Big_Integer), - Predicate_Failure => raise Program_Error; - -- Holds a valid Big_Integer - - -- Comparison operators defined for valid Big_Integer values - function "=" (L, R : Valid_Big_Integer) return Boolean with - Import, - Global => null; - - function "<" (L, R : Valid_Big_Integer) return Boolean with - Import, - Global => null; - - function "<=" (L, R : Valid_Big_Integer) return Boolean with - Import, - Global => null; - - function ">" (L, R : Valid_Big_Integer) return Boolean with - Import, - Global => null; - - function ">=" (L, R : Valid_Big_Integer) return Boolean with - Import, - Global => null; - - function To_Big_Integer (Arg : Integer) return Valid_Big_Integer - with - Import, - Global => null; - -- Create a Big_Integer from an Integer value - - subtype Big_Positive is Big_Integer - with Dynamic_Predicate => - (if Is_Valid (Big_Positive) - then Big_Positive > To_Big_Integer (0)), - Predicate_Failure => raise Constraint_Error; - -- Positive subtype of Big_Integers, analogous to Positive and Integer - - subtype Big_Natural is Big_Integer - with Dynamic_Predicate => - (if Is_Valid (Big_Natural) - then Big_Natural >= To_Big_Integer (0)), - Predicate_Failure => raise Constraint_Error; - -- Natural subtype of Big_Integers, analogous to Natural and Integer - - function In_Range - (Arg : Valid_Big_Integer; Low, High : Big_Integer) return Boolean - is (Low <= Arg and Arg <= High) - with - Import, - Global => null; - -- Check whether Arg is in the range Low .. High - - function To_Integer (Arg : Valid_Big_Integer) return Integer - with - Import, - Pre => In_Range (Arg, - Low => To_Big_Integer (Integer'First), - High => To_Big_Integer (Integer'Last)) - or else raise Constraint_Error, - Global => null; - -- Convert a valid Big_Integer into an Integer - - generic - type Int is range <>; - package Signed_Conversions is - -- Generic package to implement conversion functions for - -- arbitrary ranged types. - - function To_Big_Integer (Arg : Int) return Valid_Big_Integer - with - Global => null; - -- Convert a ranged type into a valid Big_Integer - - function From_Big_Integer (Arg : Valid_Big_Integer) return Int - with - Pre => In_Range (Arg, - Low => To_Big_Integer (Int'First), - High => To_Big_Integer (Int'Last)) - or else raise Constraint_Error, - Global => null; - -- Convert a valid Big_Integer into a ranged type - end Signed_Conversions; - - generic - type Int is mod <>; - package Unsigned_Conversions is - -- Generic package to implement conversion functions for - -- arbitrary modular types. - - function To_Big_Integer (Arg : Int) return Valid_Big_Integer - with - Global => null; - -- Convert a modular type into a valid Big_Integer - - function From_Big_Integer (Arg : Valid_Big_Integer) return Int - with - Pre => In_Range (Arg, - Low => To_Big_Integer (Int'First), - High => To_Big_Integer (Int'Last)) - or else raise Constraint_Error, - Global => null; - -- Convert a valid Big_Integer into a modular type - - end Unsigned_Conversions; - - function From_String (Arg : String) return Valid_Big_Integer - with - Import, - Global => null; - -- Create a valid Big_Integer from a String - - function From_Universal_Image (Arg : String) return Valid_Big_Integer - renames From_String; - - -- Mathematical operators defined for valid Big_Integer values - function "+" (L : Valid_Big_Integer) return Valid_Big_Integer - with - Import, - Global => null; - - function "-" (L : Valid_Big_Integer) return Valid_Big_Integer - with - Import, - Global => null; - - function "abs" (L : Valid_Big_Integer) return Valid_Big_Integer - with - Import, - Global => null; - - function "+" (L, R : Valid_Big_Integer) return Valid_Big_Integer - with - Import, - Global => null; - - function "-" (L, R : Valid_Big_Integer) return Valid_Big_Integer - with - Import, - Global => null; - - function "*" (L, R : Valid_Big_Integer) return Valid_Big_Integer - with - Import, - Global => null; - - function "/" (L, R : Valid_Big_Integer) return Valid_Big_Integer - with - Import, - Global => null; - - function "mod" (L, R : Valid_Big_Integer) return Valid_Big_Integer - with - Import, - Global => null; - - function "rem" (L, R : Valid_Big_Integer) return Valid_Big_Integer - with - Import, - Global => null; - - function "**" (L : Valid_Big_Integer; R : Natural) return Valid_Big_Integer - with - Import, - Global => null; - - function Min (L, R : Valid_Big_Integer) return Valid_Big_Integer - with - Import, - Global => null; - - function Max (L, R : Valid_Big_Integer) return Valid_Big_Integer - with - Import, - Global => null; - - function Greatest_Common_Divisor - (L, R : Valid_Big_Integer) return Big_Positive - with - Import, - Pre => (L /= To_Big_Integer (0) and R /= To_Big_Integer (0)) - or else raise Constraint_Error, - Global => null; - -- Calculate the greatest common divisor for two Big_Integer values - -private - pragma SPARK_Mode (Off); - - type Big_Integer is null record; - -- Solely consists of Ghost code - -end Ada.Numerics.Big_Numbers.Big_Integers_Ghost; diff --git a/gcc/ada/libgnat/a-nudira.ads b/gcc/ada/libgnat/a-nudira.ads index 647470b..3b2ca18 100644 --- a/gcc/ada/libgnat/a-nudira.ads +++ b/gcc/ada/libgnat/a-nudira.ads @@ -44,38 +44,60 @@ generic type Result_Subtype is (<>); package Ada.Numerics.Discrete_Random with - SPARK_Mode => Off + SPARK_Mode => On, + Always_Terminates is -- Basic facilities - type Generator is limited private; + type Generator is limited private with Default_Initial_Condition; - function Random (Gen : Generator) return Result_Subtype; + function Random (Gen : Generator) return Result_Subtype with + Global => null, + Side_Effects; + pragma Annotate (GNATprove, Mutable_In_Parameters, Generator); function Random (Gen : Generator; First : Result_Subtype; Last : Result_Subtype) return Result_Subtype - with Post => Random'Result in First .. Last; + with + Post => Random'Result in First .. Last, + Global => null, + Side_Effects; + pragma Annotate (GNATprove, Mutable_In_Parameters, Generator); - procedure Reset (Gen : Generator; Initiator : Integer); - procedure Reset (Gen : Generator); + procedure Reset (Gen : Generator; Initiator : Integer) with + Global => null; + pragma Annotate (GNATprove, Mutable_In_Parameters, Generator); + + procedure Reset (Gen : Generator) with + Global => null; + pragma Annotate (GNATprove, Mutable_In_Parameters, Generator); -- Advanced facilities type State is private; - procedure Save (Gen : Generator; To_State : out State); - procedure Reset (Gen : Generator; From_State : State); + procedure Save (Gen : Generator; To_State : out State) with + Global => null; + pragma Annotate (GNATprove, Mutable_In_Parameters, Generator); + + procedure Reset (Gen : Generator; From_State : State) with + Global => null; + pragma Annotate (GNATprove, Mutable_In_Parameters, Generator); Max_Image_Width : constant := System.Random_Numbers.Max_Image_Width; - function Image (Of_State : State) return String; - function Value (Coded_State : String) return State; + function Image (Of_State : State) return String with + Global => null; + function Value (Coded_State : String) return State with + Global => null; private + pragma SPARK_Mode (Off); + type Generator is new System.Random_Numbers.Generator; type State is new System.Random_Numbers.State; diff --git a/gcc/ada/libgnat/a-nuflra.ads b/gcc/ada/libgnat/a-nuflra.ads index 7eb0494..9ea73d4 100644 --- a/gcc/ada/libgnat/a-nuflra.ads +++ b/gcc/ada/libgnat/a-nuflra.ads @@ -39,34 +39,50 @@ with System.Random_Numbers; package Ada.Numerics.Float_Random with - SPARK_Mode => Off + SPARK_Mode => On, + Always_Terminates is -- Basic facilities - type Generator is limited private; + type Generator is limited private with Default_Initial_Condition; subtype Uniformly_Distributed is Float range 0.0 .. 1.0; - function Random (Gen : Generator) return Uniformly_Distributed; + function Random (Gen : Generator) return Uniformly_Distributed with + Global => null, + Side_Effects; + pragma Annotate (GNATprove, Mutable_In_Parameters, Generator); + procedure Reset (Gen : Generator) with + Global => null; + pragma Annotate (GNATprove, Mutable_In_Parameters, Generator); - procedure Reset (Gen : Generator); - procedure Reset (Gen : Generator; Initiator : Integer); + procedure Reset (Gen : Generator; Initiator : Integer) with + Global => null; + pragma Annotate (GNATprove, Mutable_In_Parameters, Generator); -- Advanced facilities type State is private; - procedure Save (Gen : Generator; To_State : out State); - procedure Reset (Gen : Generator; From_State : State); + procedure Save (Gen : Generator; To_State : out State) with + Global => null; + pragma Annotate (GNATprove, Mutable_In_Parameters, Generator); + procedure Reset (Gen : Generator; From_State : State) with + Global => null; + pragma Annotate (GNATprove, Mutable_In_Parameters, Generator); Max_Image_Width : constant := System.Random_Numbers.Max_Image_Width; - function Image (Of_State : State) return String; - function Value (Coded_State : String) return State; + function Image (Of_State : State) return String with + Global => null; + function Value (Coded_State : String) return State with + Global => null; private + pragma SPARK_Mode (Off); + type Generator is new System.Random_Numbers.Generator; type State is new System.Random_Numbers.State; diff --git a/gcc/ada/libgnat/a-strfix.adb b/gcc/ada/libgnat/a-strfix.adb index 5acfef4..50bb214 100644 --- a/gcc/ada/libgnat/a-strfix.adb +++ b/gcc/ada/libgnat/a-strfix.adb @@ -38,14 +38,6 @@ -- bounds of function return results were also fixed, and use of & removed for -- efficiency reasons. --- Ghost code, loop invariants and assertions in this unit are meant for --- analysis only, not for run-time checking, as it would be too costly --- otherwise. This is enforced by setting the assertion policy to Ignore. - -pragma Assertion_Policy (Ghost => Ignore, - Loop_Invariant => Ignore, - Assert => Ignore); - with Ada.Strings.Maps; use Ada.Strings.Maps; package body Ada.Strings.Fixed with SPARK_Mode is @@ -153,12 +145,9 @@ package body Ada.Strings.Fixed with SPARK_Mode is Right : Character) return String is begin - return Result : String (1 .. Left) with Relaxed_Initialization do + return Result : String (1 .. Left) do for J in Result'Range loop Result (J) := Right; - pragma Loop_Invariant - (for all K in 1 .. J => - Result (K)'Initialized and then Result (K) = Right); end loop; end return; end "*"; @@ -168,82 +157,15 @@ package body Ada.Strings.Fixed with SPARK_Mode is Right : String) return String is Ptr : Integer := 0; - - -- Parts of the proof involving manipulations with the modulo operator - -- are complicated for the prover and can't be done automatically in - -- the global subprogram. That's why we isolate them in these two ghost - -- lemmas. - - procedure Lemma_Mod (K : Integer) with - Ghost, - Pre => - Right'Length /= 0 - and then Ptr mod Right'Length = 0 - and then Ptr in 0 .. Natural'Last - Right'Length - and then K in Ptr .. Ptr + Right'Length - 1, - Post => K mod Right'Length = K - Ptr; - -- Lemma_Mod is applied to an index considered in Lemma_Split to prove - -- that it has the right value modulo Right'Length. - - procedure Lemma_Split (Result : String) with - Ghost, - Relaxed_Initialization => Result, - Pre => - Right'Length /= 0 - and then Result'First = 1 - and then Result'Last >= 0 - and then Ptr mod Right'Length = 0 - and then Ptr in 0 .. Result'Last - Right'Length - and then Result (Result'First .. Ptr + Right'Length)'Initialized - and then Result (Ptr + 1 .. Ptr + Right'Length) = Right, - Post => - (for all K in Ptr + 1 .. Ptr + Right'Length => - Result (K) = Right (Right'First + (K - 1) mod Right'Length)); - -- Lemma_Split is used after Result (Ptr + 1 .. Ptr + Right'Length) is - -- updated to Right and concludes that the characters match for each - -- index when taken modulo Right'Length, as the considered slice starts - -- at index 1 modulo Right'Length. - - --------------- - -- Lemma_Mod -- - --------------- - - procedure Lemma_Mod (K : Integer) is null; - - ----------------- - -- Lemma_Split -- - ----------------- - - procedure Lemma_Split (Result : String) - is - begin - for K in Ptr + 1 .. Ptr + Right'Length loop - Lemma_Mod (K - 1); - pragma Loop_Invariant - (for all J in Ptr + 1 .. K => - Result (J) = Right (Right'First + (J - 1) mod Right'Length)); - end loop; - end Lemma_Split; - - -- Start of processing for "*" - begin if Right'Length = 0 then return ""; end if; - return Result : String (1 .. Left * Right'Length) - with Relaxed_Initialization - do + return Result : String (1 .. Left * Right'Length) do for J in 1 .. Left loop Result (Ptr + 1 .. Ptr + Right'Length) := Right; - Lemma_Split (Result); Ptr := Ptr + Right'Length; - pragma Loop_Invariant (Ptr = J * Right'Length); - pragma Loop_Invariant (Result (1 .. Ptr)'Initialized); - pragma Loop_Invariant - (for all K in 1 .. Ptr => - Result (K) = Right (Right'First + (K - 1) mod Right'Length)); end loop; end return; end "*"; @@ -255,8 +177,7 @@ package body Ada.Strings.Fixed with SPARK_Mode is function Delete (Source : String; From : Positive; - Through : Natural) return String - is + Through : Natural) return String is begin if From > Through then declare @@ -279,9 +200,7 @@ package body Ada.Strings.Fixed with SPARK_Mode is Result_Length : constant Integer := Front_Len + Back_Len; -- Length of result begin - return Result : String (1 .. Result_Length) - with Relaxed_Initialization - do + return Result : String (1 .. Result_Length) do Result (1 .. Front_Len) := Source (Source'First .. From - 1); @@ -325,14 +244,11 @@ package body Ada.Strings.Fixed with SPARK_Mode is Result_Type (Source (Source'First .. Source'First + (Count - 1))); else - return Result : Result_Type with Relaxed_Initialization do + return Result : Result_Type do Result (1 .. Source'Length) := Source; for J in Source'Length + 1 .. Count loop Result (J) := Pad; - pragma Loop_Invariant - (for all K in Source'Length + 1 .. J => - Result (K)'Initialized and then Result (K) = Pad); end loop; end return; end if; @@ -342,8 +258,7 @@ package body Ada.Strings.Fixed with SPARK_Mode is (Source : in out String; Count : Natural; Justify : Alignment := Left; - Pad : Character := Space) - is + Pad : Character := Space) is begin Move (Source => Head (Source, Count, Pad), Target => Source, @@ -362,37 +277,21 @@ package body Ada.Strings.Fixed with SPARK_Mode is New_Item : String) return String is Front : constant Integer := Before - Source'First; - begin if Before - 1 not in Source'First - 1 .. Source'Last then raise Index_Error; end if; - return Result : String (1 .. Source'Length + New_Item'Length) - with Relaxed_Initialization - do + return Result : String (1 .. Source'Length + New_Item'Length) do Result (1 .. Front) := Source (Source'First .. Before - 1); Result (Front + 1 .. Front + New_Item'Length) := New_Item; - pragma Assert - (Result (1 .. Before - Source'First) - = Source (Source'First .. Before - 1)); - pragma Assert - (Result - (Before - Source'First + 1 - .. Before - Source'First + New_Item'Length) - = New_Item); - if Before <= Source'Last then Result (Front + New_Item'Length + 1 .. Result'Last) := Source (Before .. Source'Last); end if; - - pragma Assert - (Result (1 .. Before - Source'First) - = Source (Source'First .. Before - 1)); end return; end Insert; @@ -400,8 +299,7 @@ package body Ada.Strings.Fixed with SPARK_Mode is (Source : in out String; Before : Positive; New_Item : String; - Drop : Truncation := Error) - is + Drop : Truncation := Error) is begin Move (Source => Insert (Source, Before, New_Item), Target => Source, @@ -536,38 +434,14 @@ package body Ada.Strings.Fixed with SPARK_Mode is Front : constant Integer := Position - Source'First; begin - return Result : String (1 .. Result_Length) - with Relaxed_Initialization - do + return Result : String (1 .. Result_Length) do Result (1 .. Front) := Source (Source'First .. Position - 1); - pragma Assert - (Result (1 .. Position - Source'First) - = Source (Source'First .. Position - 1)); Result (Front + 1 .. Front + New_Item'Length) := New_Item; - pragma Assert - (Result - (Position - Source'First + 1 - .. Position - Source'First + New_Item'Length) - = New_Item); if Position <= Source'Last - New_Item'Length then Result (Front + New_Item'Length + 1 .. Result'Last) := Source (Position + New_Item'Length .. Source'Last); - - pragma Assert - (Result - (Position - Source'First + New_Item'Length + 1 - .. Result'Last) - = Source (Position + New_Item'Length .. Source'Last)); end if; - - pragma Assert - (if Position <= Source'Last - New_Item'Length - then - Result - (Position - Source'First + New_Item'Length + 1 - .. Result'Last) - = Source (Position + New_Item'Length .. Source'Last)); end return; end; end Overwrite; @@ -576,8 +450,7 @@ package body Ada.Strings.Fixed with SPARK_Mode is (Source : in out String; Position : Positive; New_Item : String; - Drop : Truncation := Right) - is + Drop : Truncation := Right) is begin Move (Source => Overwrite (Source, Position, New_Item), Target => Source, @@ -612,39 +485,14 @@ package body Ada.Strings.Fixed with SPARK_Mode is -- Length of result begin - return Result : String (1 .. Result_Length) - with Relaxed_Initialization do + return Result : String (1 .. Result_Length) do Result (1 .. Front_Len) := Source (Source'First .. Low - 1); - pragma Assert - (Result (1 .. Integer'Max (0, Low - Source'First)) - = Source (Source'First .. Low - 1)); Result (Front_Len + 1 .. Front_Len + By'Length) := By; - pragma Assert - (Result - (Integer'Max (0, Low - Source'First) + 1 - .. Integer'Max (0, Low - Source'First) + By'Length) - = By); if High < Source'Last then Result (Front_Len + By'Length + 1 .. Result'Last) := Source (High + 1 .. Source'Last); end if; - - pragma Assert - (Result (1 .. Integer'Max (0, Low - Source'First)) - = Source (Source'First .. Low - 1)); - pragma Assert - (Result - (Integer'Max (0, Low - Source'First) + 1 - .. Integer'Max (0, Low - Source'First) + By'Length) - = By); - pragma Assert - (if High < Source'Last - then - Result - (Integer'Max (0, Low - Source'First) + By'Length + 1 - .. Result'Last) - = Source (High + 1 .. Source'Last)); end return; end; else @@ -659,8 +507,7 @@ package body Ada.Strings.Fixed with SPARK_Mode is By : String; Drop : Truncation := Error; Justify : Alignment := Left; - Pad : Character := Space) - is + Pad : Character := Space) is begin Move (Replace_Slice (Source, Low, High, By), Source, Drop, Justify, Pad); end Replace_Slice; @@ -675,7 +522,6 @@ package body Ada.Strings.Fixed with SPARK_Mode is Pad : Character := Space) return String is subtype Result_Type is String (1 .. Count); - begin if Count = 0 then return ""; @@ -686,12 +532,9 @@ package body Ada.Strings.Fixed with SPARK_Mode is -- Pad on left else - return Result : Result_Type with Relaxed_Initialization do + return Result : Result_Type do for J in 1 .. Count - Source'Length loop Result (J) := Pad; - pragma Loop_Invariant - (for all K in 1 .. J => - Result (K)'Initialized and then Result (K) = Pad); end loop; if Source'Length /= 0 then @@ -705,8 +548,7 @@ package body Ada.Strings.Fixed with SPARK_Mode is (Source : in out String; Count : Natural; Justify : Alignment := Left; - Pad : Character := Space) - is + Pad : Character := Space) is begin Move (Source => Tail (Source, Count, Pad), Target => Source, @@ -721,35 +563,21 @@ package body Ada.Strings.Fixed with SPARK_Mode is function Translate (Source : String; - Mapping : Maps.Character_Mapping) return String - is + Mapping : Maps.Character_Mapping) return String is begin - return Result : String (1 .. Source'Length) - with Relaxed_Initialization - do + return Result : String (1 .. Source'Length) do for J in Source'Range loop Result (J - (Source'First - 1)) := Value (Mapping, Source (J)); - pragma Loop_Invariant - (for all K in Source'First .. J => - Result (K - (Source'First - 1))'Initialized); - pragma Loop_Invariant - (for all K in Source'First .. J => - Result (K - (Source'First - 1)) = - Value (Mapping, Source (K))); end loop; end return; end Translate; procedure Translate (Source : in out String; - Mapping : Maps.Character_Mapping) - is + Mapping : Maps.Character_Mapping) is begin for J in Source'Range loop Source (J) := Value (Mapping, Source (J)); - pragma Loop_Invariant - (for all K in Source'First .. J => - Source (K) = Value (Mapping, Source'Loop_Entry (K))); end loop; end Translate; @@ -759,23 +587,9 @@ package body Ada.Strings.Fixed with SPARK_Mode is is pragma Unsuppress (Access_Check); begin - return Result : String (1 .. Source'Length) - with Relaxed_Initialization - do + return Result : String (1 .. Source'Length) do for J in Source'Range loop Result (J - (Source'First - 1)) := Mapping.all (Source (J)); - pragma Annotate (GNATprove, False_Positive, - "call via access-to-subprogram", - "function Mapping must always terminate"); - pragma Loop_Invariant - (for all K in Source'First .. J => - Result (K - (Source'First - 1))'Initialized); - pragma Loop_Invariant - (for all K in Source'First .. J => - Result (K - (Source'First - 1)) = Mapping (Source (K))); - pragma Annotate (GNATprove, False_Positive, - "call via access-to-subprogram", - "function Mapping must always terminate"); end loop; end return; end Translate; @@ -788,15 +602,6 @@ package body Ada.Strings.Fixed with SPARK_Mode is begin for J in Source'Range loop Source (J) := Mapping.all (Source (J)); - pragma Annotate (GNATprove, False_Positive, - "call via access-to-subprogram", - "function Mapping must always terminate"); - pragma Loop_Invariant - (for all K in Source'First .. J => - Source (K) = Mapping (Source'Loop_Entry (K))); - pragma Annotate (GNATprove, False_Positive, - "call via access-to-subprogram", - "function Mapping must always terminate"); end loop; end Translate; @@ -872,8 +677,7 @@ package body Ada.Strings.Fixed with SPARK_Mode is (Source : in out String; Side : Trim_End; Justify : Alignment := Left; - Pad : Character := Space) - is + Pad : Character := Space) is begin Move (Trim (Source, Side), Source, @@ -887,7 +691,6 @@ package body Ada.Strings.Fixed with SPARK_Mode is Right : Maps.Character_Set) return String is High, Low : Integer; - begin Low := Index (Source, Set => Left, Test => Outside, Going => Forward); @@ -908,7 +711,6 @@ package body Ada.Strings.Fixed with SPARK_Mode is declare Result_Length : constant Integer := High - Low + 1; subtype Result_Type is String (1 .. Result_Length); - begin return Result_Type (Source (Low .. High)); end; @@ -919,8 +721,7 @@ package body Ada.Strings.Fixed with SPARK_Mode is Left : Maps.Character_Set; Right : Maps.Character_Set; Justify : Alignment := Strings.Left; - Pad : Character := Space) - is + Pad : Character := Space) is begin Move (Source => Trim (Source, Left, Right), Target => Source, diff --git a/gcc/ada/libgnat/a-strmap.adb b/gcc/ada/libgnat/a-strmap.adb index 7490780..2f4cceb 100644 --- a/gcc/ada/libgnat/a-strmap.adb +++ b/gcc/ada/libgnat/a-strmap.adb @@ -35,14 +35,6 @@ -- is bit-by-bit or character-by-character and therefore rather slow. -- Generally for character sets we favor the full 32-byte representation. --- Assertions, ghost code and loop invariants in this unit are meant for --- analysis only, not for run-time checking, as it would be too costly --- otherwise. This is enforced by setting the assertion policy to Ignore. - -pragma Assertion_Policy (Assert => Ignore, - Ghost => Ignore, - Loop_Invariant => Ignore); - package body Ada.Strings.Maps with SPARK_Mode is @@ -131,36 +123,15 @@ is --------------- function To_Domain (Map : Character_Mapping) return Character_Sequence is - Result : String (1 .. Map'Length) with Relaxed_Initialization; + Result : String (1 .. Map'Length); J : Natural; - - type Character_Index is array (Character) of Natural with Ghost; - Indexes : Character_Index := [others => 0] with Ghost; - begin J := 0; for C in Map'Range loop if Map (C) /= C then J := J + 1; Result (J) := C; - Indexes (C) := J; end if; - - pragma Loop_Invariant (if Map = Identity then J = 0); - pragma Loop_Invariant (J <= Character'Pos (C) + 1); - pragma Loop_Invariant (for all K in 1 .. J => Result (K)'Initialized); - pragma Loop_Invariant (for all K in 1 .. J => Result (K) <= C); - pragma Loop_Invariant - (SPARK_Proof_Sorted_Character_Sequence (Result (1 .. J))); - pragma Loop_Invariant - (for all D in Map'First .. C => - (if Map (D) = D then - Indexes (D) = 0 - else - Indexes (D) in 1 .. J - and then Result (Indexes (D)) = D)); - pragma Loop_Invariant - (for all Char of Result (1 .. J) => Map (Char) /= Char); end loop; return Result (1 .. J); @@ -173,7 +144,7 @@ is function To_Mapping (From, To : Character_Sequence) return Character_Mapping is - Result : Character_Mapping with Relaxed_Initialization; + Result : Character_Mapping; Inserted : Character_Set := Null_Set; From_Len : constant Natural := From'Length; To_Len : constant Natural := To'Length; @@ -185,9 +156,6 @@ is for Char in Character loop Result (Char) := Char; - pragma Loop_Invariant (Result (Result'First .. Char)'Initialized); - pragma Loop_Invariant - (for all C in Result'First .. Char => Result (C) = C); end loop; for J in From'Range loop @@ -197,23 +165,6 @@ is Result (From (J)) := To (J - From'First + To'First); Inserted (From (J)) := True; - - pragma Loop_Invariant (Result'Initialized); - pragma Loop_Invariant - (for all K in From'First .. J => - Result (From (K)) = To (K - From'First + To'First) - and then Inserted (From (K))); - pragma Loop_Invariant - (for all Char in Character => - (Inserted (Char) = - (for some K in From'First .. J => Char = From (K)))); - pragma Loop_Invariant - (for all Char in Character => - (if not Inserted (Char) then Result (Char) = Char)); - pragma Loop_Invariant - (if (for all K in From'First .. J => - From (K) = To (J - From'First + To'First)) - then Result = Identity); end loop; return Result; @@ -224,195 +175,16 @@ is -------------- function To_Range (Map : Character_Mapping) return Character_Sequence is - - -- Extract from the postcondition of To_Domain the essential properties - -- that define Seq as the domain of Map. - function Is_Domain - (Map : Character_Mapping; - Seq : Character_Sequence) - return Boolean - is - (Seq'First = 1 - and then - SPARK_Proof_Sorted_Character_Sequence (Seq) - and then - (for all Char in Character => - (if (for all X of Seq => X /= Char) - then Map (Char) = Char)) - and then - (for all Char of Seq => Map (Char) /= Char)) - with - Ghost; - - -- Given Map, there is a unique sequence Seq for which - -- Is_Domain(Map,Seq) holds. - procedure Lemma_Domain_Unicity - (Map : Character_Mapping; - Seq1, Seq2 : Character_Sequence) - with - Ghost, - Pre => Is_Domain (Map, Seq1) - and then Is_Domain (Map, Seq2), - Post => Seq1 = Seq2; - - -- Isolate the proof that To_Domain(Map) returns a sequence for which - -- Is_Domain holds. - procedure Lemma_Is_Domain (Map : Character_Mapping) - with - Ghost, - Post => Is_Domain (Map, To_Domain (Map)); - - -- Deduce the alternative expression of sortedness from the one in - -- SPARK_Proof_Sorted_Character_Sequence which compares consecutive - -- elements. - procedure Lemma_Is_Sorted (Seq : Character_Sequence) - with - Ghost, - Pre => SPARK_Proof_Sorted_Character_Sequence (Seq), - Post => (for all J in Seq'Range => - (for all K in Seq'Range => - (if J < K then Seq (J) < Seq (K)))); - - -------------------------- - -- Lemma_Domain_Unicity -- - -------------------------- - - procedure Lemma_Domain_Unicity - (Map : Character_Mapping; - Seq1, Seq2 : Character_Sequence) - is - J : Positive := 1; - - begin - while J <= Seq1'Last - and then J <= Seq2'Last - and then Seq1 (J) = Seq2 (J) - loop - pragma Loop_Invariant - (Seq1 (Seq1'First .. J) = Seq2 (Seq2'First .. J)); - pragma Loop_Variant (Increases => J); - - if J = Positive'Last then - return; - end if; - - J := J + 1; - end loop; - - Lemma_Is_Sorted (Seq1); - Lemma_Is_Sorted (Seq2); - - if J <= Seq1'Last - and then J <= Seq2'Last - then - if Seq1 (J) < Seq2 (J) then - pragma Assert (for all X of Seq2 => X /= Seq1 (J)); - pragma Assert (Map (Seq1 (J)) = Seq1 (J)); - pragma Assert (False); - else - pragma Assert (for all X of Seq1 => X /= Seq2 (J)); - pragma Assert (Map (Seq2 (J)) = Seq2 (J)); - pragma Assert (False); - end if; - - elsif J <= Seq1'Last then - pragma Assert (for all X of Seq2 => X /= Seq1 (J)); - pragma Assert (Map (Seq1 (J)) = Seq1 (J)); - pragma Assert (False); - - elsif J <= Seq2'Last then - pragma Assert (for all X of Seq1 => X /= Seq2 (J)); - pragma Assert (Map (Seq2 (J)) = Seq2 (J)); - pragma Assert (False); - end if; - end Lemma_Domain_Unicity; - - --------------------- - -- Lemma_Is_Domain -- - --------------------- - - procedure Lemma_Is_Domain (Map : Character_Mapping) is - Ignore : constant Character_Sequence := To_Domain (Map); - begin - null; - end Lemma_Is_Domain; - - --------------------- - -- Lemma_Is_Sorted -- - --------------------- - - procedure Lemma_Is_Sorted (Seq : Character_Sequence) is - begin - for A in Seq'Range loop - exit when A = Positive'Last; - - for B in A + 1 .. Seq'Last loop - pragma Loop_Invariant - (for all K in A + 1 .. B => Seq (A) < Seq (K)); - end loop; - - pragma Loop_Invariant - (for all J in Seq'First .. A => - (for all K in Seq'Range => - (if J < K then Seq (J) < Seq (K)))); - end loop; - end Lemma_Is_Sorted; - - -- Local variables - - Result : String (1 .. Map'Length) with Relaxed_Initialization; + Result : String (1 .. Map'Length); J : Natural; - - -- Repeat the computation from To_Domain in ghost code, in order to - -- prove the relationship between Result and To_Domain(Map). - - Domain : String (1 .. Map'Length) with Ghost, Relaxed_Initialization; - type Character_Index is array (Character) of Natural with Ghost; - Indexes : Character_Index := [others => 0] with Ghost; - - -- Start of processing for To_Range - begin J := 0; for C in Map'Range loop if Map (C) /= C then J := J + 1; Result (J) := Map (C); - Domain (J) := C; - Indexes (C) := J; end if; - - -- Repeat the loop invariants from To_Domain regarding Domain and - -- Indexes. Add similar loop invariants for Result and Indexes. - - pragma Loop_Invariant (J <= Character'Pos (C) + 1); - pragma Loop_Invariant (Result (1 .. J)'Initialized); - pragma Loop_Invariant (Domain (1 .. J)'Initialized); - pragma Loop_Invariant (for all K in 1 .. J => Domain (K) <= C); - pragma Loop_Invariant - (SPARK_Proof_Sorted_Character_Sequence (Domain (1 .. J))); - pragma Loop_Invariant - (for all D in Map'First .. C => - (if Map (D) = D then - Indexes (D) = 0 - else - Indexes (D) in 1 .. J - and then Domain (Indexes (D)) = D - and then Result (Indexes (D)) = Map (D))); - pragma Loop_Invariant - (for all Char of Domain (1 .. J) => Map (Char) /= Char); - pragma Loop_Invariant - (for all K in 1 .. J => Result (K) = Map (Domain (K))); end loop; - pragma Assert (Is_Domain (Map, Domain (1 .. J))); - - -- Show the equality of Domain and To_Domain(Map) - - Lemma_Is_Domain (Map); - Lemma_Domain_Unicity (Map, Domain (1 .. J), To_Domain (Map)); - pragma Assert - (for all K in 1 .. J => Domain (K) = To_Domain (Map) (K)); - pragma Assert (To_Domain (Map)'Length = J); return Result (1 .. J); end To_Range; @@ -422,27 +194,18 @@ is --------------- function To_Ranges (Set : Character_Set) return Character_Ranges is - Max_Ranges : Character_Ranges (1 .. Set'Length / 2 + 1) - with Relaxed_Initialization; + Max_Ranges : Character_Ranges (1 .. Set'Length / 2 + 1); Range_Num : Natural; C : Character; - C_Iter : Character with Ghost; begin C := Character'First; Range_Num := 0; loop - C_Iter := C; - -- Skip gap between subsets while not Set (C) loop - pragma Loop_Invariant - (Character'Pos (C) >= Character'Pos (C'Loop_Entry)); - pragma Loop_Invariant - (for all Char in C'Loop_Entry .. C => not Set (Char)); - pragma Loop_Variant (Increases => C); exit when C = Character'Last; C := Character'Succ (C); end loop; @@ -455,12 +218,6 @@ is -- Span a subset loop - pragma Loop_Invariant - (Character'Pos (C) >= Character'Pos (C'Loop_Entry)); - pragma Loop_Invariant - (for all Char in C'Loop_Entry .. C => - (if Char /= C then Set (Char))); - pragma Loop_Variant (Increases => C); exit when not Set (C) or else C = Character'Last; C := Character'Succ (C); end loop; @@ -471,31 +228,6 @@ is else Max_Ranges (Range_Num).High := Character'Pred (C); end if; - - pragma Assert - (for all Char in C_Iter .. C => - (Set (Char) = - (Char in Max_Ranges (Range_Num).Low .. - Max_Ranges (Range_Num).High))); - pragma Assert - (for all Char in Character'First .. C_Iter => - (if Char /= C_Iter then - (Set (Char) = - (for some Span of Max_Ranges (1 .. Range_Num - 1) => - Char in Span.Low .. Span.High)))); - - pragma Loop_Invariant (2 * Range_Num <= Character'Pos (C) + 1); - pragma Loop_Invariant (Max_Ranges (1 .. Range_Num)'Initialized); - pragma Loop_Invariant (not Set (C)); - pragma Loop_Invariant - (for all Char in Character'First .. C => - (Set (Char) = - (for some Span of Max_Ranges (1 .. Range_Num) => - Char in Span.Low .. Span.High))); - pragma Loop_Invariant - (for all Span of Max_Ranges (1 .. Range_Num) => - (for all Char in Span.Low .. Span.High => Set (Char))); - pragma Loop_Variant (Increases => Range_Num); end loop; return Max_Ranges (1 .. Range_Num); @@ -506,8 +238,7 @@ is ----------------- function To_Sequence (Set : Character_Set) return Character_Sequence is - Result : String (1 .. Character'Pos (Character'Last) + 1) - with Relaxed_Initialization; + Result : String (1 .. Character'Pos (Character'Last) + 1); Count : Natural := 0; begin for Char in Set'Range loop @@ -515,17 +246,6 @@ is Count := Count + 1; Result (Count) := Char; end if; - - pragma Loop_Invariant (Count <= Character'Pos (Char) + 1); - pragma Loop_Invariant (Result (1 .. Count)'Initialized); - pragma Loop_Invariant (for all K in 1 .. Count => Result (K) <= Char); - pragma Loop_Invariant - (SPARK_Proof_Sorted_Character_Sequence (Result (1 .. Count))); - pragma Loop_Invariant - (for all C in Set'First .. Char => - (Set (C) = (for some X of Result (1 .. Count) => C = X))); - pragma Loop_Invariant - (for all Char of Result (1 .. Count) => Is_In (Char, Set)); end loop; return Result (1 .. Count); @@ -541,19 +261,7 @@ is for R in Ranges'Range loop for C in Ranges (R).Low .. Ranges (R).High loop Result (C) := True; - pragma Loop_Invariant - (for all Char in Character => - Result (Char) = - ((for some Prev in Ranges'First .. R - 1 => - Char in Ranges (Prev).Low .. Ranges (Prev).High) - or else Char in Ranges (R).Low .. C)); end loop; - - pragma Loop_Invariant - (for all Char in Character => - Result (Char) = - (for some Prev in Ranges'First .. R => - Char in Ranges (Prev).Low .. Ranges (Prev).High)); end loop; return Result; @@ -564,9 +272,6 @@ is begin for C in Span.Low .. Span.High loop Result (C) := True; - pragma Loop_Invariant - (for all Char in Character => - Result (Char) = (Char in Span.Low .. C)); end loop; return Result; @@ -577,10 +282,6 @@ is begin for J in Sequence'Range loop Result (Sequence (J)) := True; - pragma Loop_Invariant - (for all Char in Character => - Result (Char) = - (for some K in Sequence'First .. J => Char = Sequence (K))); end loop; return Result; @@ -599,8 +300,6 @@ is function Value (Map : Character_Mapping; - Element : Character) return Character - is - (Map (Element)); + Element : Character) return Character is (Map (Element)); end Ada.Strings.Maps; diff --git a/gcc/ada/libgnat/a-strsea.adb b/gcc/ada/libgnat/a-strsea.adb index 45fb682..55bf767 100644 --- a/gcc/ada/libgnat/a-strsea.adb +++ b/gcc/ada/libgnat/a-strsea.adb @@ -35,14 +35,6 @@ -- case of identity mappings for Count and Index, and also Index_Non_Blank -- is specialized (rather than using the general Index routine). --- Ghost code, loop invariants and assertions in this unit are meant for --- analysis only, not for run-time checking, as it would be too costly --- otherwise. This is enforced by setting the assertion policy to Ignore. - -pragma Assertion_Policy (Ghost => Ignore, - Loop_Invariant => Ignore, - Assert => Ignore); - with Ada.Strings.Maps; use Ada.Strings.Maps; with System; use System; @@ -110,10 +102,6 @@ package body Ada.Strings.Search with SPARK_Mode is Num := Num + 1; Ind := Ind + PL1; end if; - - pragma Loop_Invariant (Num <= Ind - (Source'First - 1)); - pragma Loop_Invariant (Ind >= Source'First); - pragma Loop_Variant (Increases => Ind); end loop; -- Mapped case @@ -125,25 +113,15 @@ package body Ada.Strings.Search with SPARK_Mode is if Pattern (K) /= Value (Mapping, Source (Ind + (K - Pattern'First))) then - pragma Assert (not Match (Source, Pattern, Mapping, Ind)); goto Cont; end if; - - pragma Loop_Invariant - (for all J in Pattern'First .. K => - Pattern (J) = Value (Mapping, - Source (Ind + (J - Pattern'First)))); end loop; - pragma Assert (Match (Source, Pattern, Mapping, Ind)); Num := Num + 1; Ind := Ind + PL1; <<Cont>> null; - pragma Loop_Invariant (Num <= Ind - (Source'First - 1)); - pragma Loop_Invariant (Ind >= Source'First); - pragma Loop_Variant (Increases => Ind); end loop; end if; @@ -185,30 +163,15 @@ package body Ada.Strings.Search with SPARK_Mode is Ind := Ind + 1; for K in Pattern'Range loop if Pattern (K) /= Mapping (Source (Ind + (K - Pattern'First))) then - pragma Annotate (GNATprove, False_Positive, - "call via access-to-subprogram", - "function Mapping must always terminate"); - pragma Assert (not Match (Source, Pattern, Mapping, Ind)); goto Cont; end if; - - pragma Loop_Invariant - (for all J in Pattern'First .. K => - Pattern (J) = Mapping (Source (Ind + (J - Pattern'First)))); - pragma Annotate (GNATprove, False_Positive, - "call via access-to-subprogram", - "function Mapping must always terminate"); end loop; - pragma Assert (Match (Source, Pattern, Mapping, Ind)); Num := Num + 1; Ind := Ind + PL1; <<Cont>> null; - pragma Loop_Invariant (Num <= Ind - (Source'First - 1)); - pragma Loop_Invariant (Ind >= Source'First); - pragma Loop_Variant (Increases => Ind); end loop; return Num; @@ -219,10 +182,8 @@ package body Ada.Strings.Search with SPARK_Mode is Set : Maps.Character_Set) return Natural is N : Natural := 0; - begin for J in Source'Range loop - pragma Loop_Invariant (N <= J - Source'First); if Is_In (Source (J), Set) then N := N + 1; end if; @@ -241,8 +202,7 @@ package body Ada.Strings.Search with SPARK_Mode is From : Positive; Test : Membership; First : out Positive; - Last : out Natural) - is + Last : out Natural) is begin -- AI05-031: Raise Index error if Source non-empty and From not in range @@ -264,10 +224,6 @@ package body Ada.Strings.Search with SPARK_Mode is Last := K - 1; return; end if; - - pragma Loop_Invariant - (for all L in J .. K => - Belongs (Source (L), Set, Test)); end loop; end if; @@ -277,10 +233,6 @@ package body Ada.Strings.Search with SPARK_Mode is Last := Source'Last; return; end if; - - pragma Loop_Invariant - (for all K in Integer'Max (From, Source'First) .. J => - not Belongs (Source (K), Set, Test)); end loop; -- Here if no token found @@ -294,8 +246,7 @@ package body Ada.Strings.Search with SPARK_Mode is Set : Maps.Character_Set; Test : Membership; First : out Positive; - Last : out Natural) - is + Last : out Natural) is begin for J in Source'Range loop if Belongs (Source (J), Set, Test) then @@ -307,10 +258,6 @@ package body Ada.Strings.Search with SPARK_Mode is Last := K - 1; return; end if; - - pragma Loop_Invariant - (for all L in J .. K => - Belongs (Source (L), Set, Test)); end loop; end if; @@ -320,10 +267,6 @@ package body Ada.Strings.Search with SPARK_Mode is Last := Source'Last; return; end if; - - pragma Loop_Invariant - (for all K in Source'First .. J => - not Belongs (Source (K), Set, Test)); end loop; -- Here if no token found @@ -335,7 +278,6 @@ package body Ada.Strings.Search with SPARK_Mode is if Source'First not in Positive then raise Constraint_Error; - else First := Source'First; Last := 0; @@ -353,7 +295,6 @@ package body Ada.Strings.Search with SPARK_Mode is Mapping : Maps.Character_Mapping := Maps.Identity) return Natural is PL1 : constant Integer := Pattern'Length - 1; - begin if Pattern = "" then raise Pattern_Error; @@ -374,13 +315,8 @@ package body Ada.Strings.Search with SPARK_Mode is if Is_Identity (Mapping) then for Ind in Source'First .. Source'Last - PL1 loop if Pattern = Source (Ind .. Ind + PL1) then - pragma Assert (Match (Source, Pattern, Mapping, Ind)); return Ind; end if; - - pragma Loop_Invariant - (for all J in Source'First .. Ind => - not Match (Source, Pattern, Mapping, J)); end loop; -- Mapped forward case @@ -393,20 +329,11 @@ package body Ada.Strings.Search with SPARK_Mode is then goto Cont1; end if; - - pragma Loop_Invariant - (for all J in Pattern'First .. K => - Pattern (J) = Value (Mapping, - Source (Ind + (J - Pattern'First)))); end loop; - pragma Assert (Match (Source, Pattern, Mapping, Ind)); return Ind; <<Cont1>> - pragma Loop_Invariant - (for all J in Source'First .. Ind => - not Match (Source, Pattern, Mapping, J)); null; end loop; end if; @@ -419,13 +346,8 @@ package body Ada.Strings.Search with SPARK_Mode is if Is_Identity (Mapping) then for Ind in reverse Source'First .. Source'Last - PL1 loop if Pattern = Source (Ind .. Ind + PL1) then - pragma Assert (Match (Source, Pattern, Mapping, Ind)); return Ind; end if; - - pragma Loop_Invariant - (for all J in Ind .. Source'Last - PL1 => - not Match (Source, Pattern, Mapping, J)); end loop; -- Mapped backward case @@ -438,20 +360,11 @@ package body Ada.Strings.Search with SPARK_Mode is then goto Cont2; end if; - - pragma Loop_Invariant - (for all J in Pattern'First .. K => - Pattern (J) = Value (Mapping, - Source (Ind + (J - Pattern'First)))); end loop; - pragma Assert (Match (Source, Pattern, Mapping, Ind)); return Ind; <<Cont2>> - pragma Loop_Invariant - (for all J in Ind .. Source'Last - PL1 => - not Match (Source, Pattern, Mapping, J)); null; end loop; end if; @@ -495,27 +408,17 @@ package body Ada.Strings.Search with SPARK_Mode is if Pattern (K) /= Mapping.all (Source (Ind + (K - Pattern'First))) then - pragma Annotate (GNATprove, False_Positive, - "call via access-to-subprogram", - "function Mapping must always terminate"); goto Cont1; end if; pragma Loop_Invariant (for all J in Pattern'First .. K => Pattern (J) = Mapping (Source (Ind + (J - Pattern'First)))); - pragma Annotate (GNATprove, False_Positive, - "call via access-to-subprogram", - "function Mapping must always terminate"); end loop; - pragma Assert (Match (Source, Pattern, Mapping, Ind)); return Ind; <<Cont1>> - pragma Loop_Invariant - (for all J in Source'First .. Ind => - not Match (Source, Pattern, Mapping, J)); null; end loop; @@ -527,26 +430,13 @@ package body Ada.Strings.Search with SPARK_Mode is if Pattern (K) /= Mapping.all (Source (Ind + (K - Pattern'First))) then - pragma Annotate (GNATprove, False_Positive, - "call via access-to-subprogram", - "function Mapping must always terminate"); goto Cont2; end if; - - pragma Loop_Invariant - (for all J in Pattern'First .. K => - Pattern (J) = Mapping (Source (Ind + (J - Pattern'First)))); - pragma Annotate (GNATprove, False_Positive, - "call via access-to-subprogram", - "function Mapping must always terminate"); end loop; return Ind; <<Cont2>> - pragma Loop_Invariant - (for all J in Ind .. Source'Last - PL1 => - not Match (Source, Pattern, Mapping, J)); null; end loop; end if; @@ -561,8 +451,7 @@ package body Ada.Strings.Search with SPARK_Mode is (Source : String; Set : Maps.Character_Set; Test : Membership := Inside; - Going : Direction := Forward) return Natural - is + Going : Direction := Forward) return Natural is begin -- Forwards case @@ -571,10 +460,6 @@ package body Ada.Strings.Search with SPARK_Mode is if Belongs (Source (J), Set, Test) then return J; end if; - - pragma Loop_Invariant - (for all C of Source (Source'First .. J) => - not Belongs (C, Set, Test)); end loop; -- Backwards case @@ -584,10 +469,6 @@ package body Ada.Strings.Search with SPARK_Mode is if Belongs (Source (J), Set, Test) then return J; end if; - - pragma Loop_Invariant - (for all C of Source (J .. Source'Last) => - not Belongs (C, Set, Test)); end loop; end if; @@ -604,7 +485,6 @@ package body Ada.Strings.Search with SPARK_Mode is Mapping : Maps.Character_Mapping := Maps.Identity) return Natural is Result : Natural; - PL1 : constant Integer := Pattern'Length - 1; begin -- AI05-056: If source is empty result is always zero @@ -619,12 +499,6 @@ package body Ada.Strings.Search with SPARK_Mode is Result := Index (Source (From .. Source'Last), Pattern, Forward, Mapping); - pragma Assert - (if (for some J in From .. Source'Last - PL1 => - Match (Source, Pattern, Mapping, J)) - then Result in From .. Source'Last - PL1 - and then Match (Source, Pattern, Mapping, Result) - else Result = 0); else if From > Source'Last then @@ -633,12 +507,6 @@ package body Ada.Strings.Search with SPARK_Mode is Result := Index (Source (Source'First .. From), Pattern, Backward, Mapping); - pragma Assert - (if (for some J in Source'First .. From - PL1 => - Match (Source, Pattern, Mapping, J)) - then Result in Source'First .. From - PL1 - and then Match (Source, Pattern, Mapping, Result) - else Result = 0); end if; return Result; @@ -722,9 +590,6 @@ package body Ada.Strings.Search with SPARK_Mode is if Source (J) /= ' ' then return J; end if; - - pragma Loop_Invariant - (for all C of Source (Source'First .. J) => C = ' '); end loop; else -- Going = Backward @@ -732,9 +597,6 @@ package body Ada.Strings.Search with SPARK_Mode is if Source (J) /= ' ' then return J; end if; - - pragma Loop_Invariant - (for all C of Source (J .. Source'Last) => C = ' '); end loop; end if; diff --git a/gcc/ada/libgnat/a-strsup.adb b/gcc/ada/libgnat/a-strsup.adb index 6540924..8afde71 100644 --- a/gcc/ada/libgnat/a-strsup.adb +++ b/gcc/ada/libgnat/a-strsup.adb @@ -29,15 +29,6 @@ -- -- ------------------------------------------------------------------------------ --- Ghost code, loop (in)variants and assertions in this unit are meant for --- analysis only, not for run-time checking, as it would be too costly --- otherwise. This is enforced by setting the assertion policy to Ignore. - -pragma Assertion_Policy (Ghost => Ignore, - Loop_Invariant => Ignore, - Loop_Variant => Ignore, - Assert => Ignore); - with Ada.Strings.Maps; use Ada.Strings.Maps; package body Ada.Strings.Superbounded with SPARK_Mode is @@ -1438,91 +1429,6 @@ package body Ada.Strings.Superbounded with SPARK_Mode is Indx : Natural; Ilen : constant Natural := Item'Length; - -- Parts of the proof involving manipulations with the modulo operator - -- are complicated for the prover and can't be done automatically in - -- the global subprogram. That's why we isolate them in these two ghost - -- lemmas. - - procedure Lemma_Mod (K : Natural; Q : Natural) with - Ghost, - Pre => Ilen /= 0 - and then Q mod Ilen = 0 - and then K - Q in 0 .. Ilen - 1, - Post => K mod Ilen = K - Q; - -- Lemma_Mod is applied to an index considered in Lemma_Split to prove - -- that it has the right value modulo Item'Length. - - procedure Lemma_Mod_Zero (X : Natural) with - Ghost, - Pre => Ilen /= 0 - and then X mod Ilen = 0 - and then X <= Natural'Last - Ilen, - Post => (X + Ilen) mod Ilen = 0; - -- Lemma_Mod_Zero is applied to prove that the length of the range - -- of indexes considered in the loop, when dropping on the Left, is - -- a multiple of Item'Length. - - procedure Lemma_Split (Going : Direction) with - Ghost, - Pre => - Ilen /= 0 - and then Indx in 0 .. Max_Length - Ilen - and then - (if Going = Forward - then Indx mod Ilen = 0 - else (Max_Length - Indx - Ilen) mod Ilen = 0) - and then Result.Data (Indx + 1 .. Indx + Ilen)'Initialized - and then String (Result.Data (Indx + 1 .. Indx + Ilen)) = Item, - Post => - (if Going = Forward then - (for all J in Indx + 1 .. Indx + Ilen => - Result.Data (J) = Item (Item'First + (J - 1) mod Ilen)) - else - (for all J in Indx + 1 .. Indx + Ilen => - Result.Data (J) = - Item (Item'Last - (Max_Length - J) mod Ilen))); - -- Lemma_Split is used after Result.Data (Indx + 1 .. Indx + Ilen) is - -- updated to Item and concludes that the characters match for each - -- index when taken modulo Item'Length, as the considered slice starts - -- at index 1 (or ends at index Max_Length, if Going = Backward) modulo - -- Item'Length. - - --------------- - -- Lemma_Mod -- - --------------- - - procedure Lemma_Mod (K : Natural; Q : Natural) is null; - - -------------------- - -- Lemma_Mod_Zero -- - -------------------- - - procedure Lemma_Mod_Zero (X : Natural) is null; - - ----------------- - -- Lemma_Split -- - ----------------- - - procedure Lemma_Split (Going : Direction) is - begin - if Going = Forward then - for K in Indx + 1 .. Indx + Ilen loop - Lemma_Mod (K - 1, Indx); - pragma Loop_Invariant - (for all J in Indx + 1 .. K => - Result.Data (J) = Item (Item'First + (J - 1) mod Ilen)); - end loop; - else - for K in Indx + 1 .. Indx + Ilen loop - Lemma_Mod (Max_Length - K, Max_Length - Indx - Ilen); - pragma Loop_Invariant - (for all J in Indx + 1 .. K => - Result.Data (J) = - Item (Item'Last - (Max_Length - J) mod Ilen)); - end loop; - end if; - end Lemma_Split; - begin if Count = 0 or else Ilen <= Max_Length / Count then if Count * Ilen > 0 then @@ -1531,19 +1437,7 @@ package body Ada.Strings.Superbounded with SPARK_Mode is for J in 1 .. Count loop Result.Data (Indx + 1 .. Indx + Ilen) := Super_String_Data (Item); - pragma Assert - (for all K in 1 .. Ilen => - Result.Data (Indx + K) = Item (Item'First - 1 + K)); - pragma Assert - (String (Result.Data (Indx + 1 .. Indx + Ilen)) = Item); - Lemma_Split (Forward); Indx := Indx + Ilen; - pragma Loop_Invariant (Indx = J * Ilen); - pragma Loop_Invariant (Result.Data (1 .. Indx)'Initialized); - pragma Loop_Invariant - (for all K in 1 .. Indx => - Result.Data (K) = - Item (Item'First + (K - 1) mod Ilen)); end loop; end if; @@ -1557,36 +1451,11 @@ package body Ada.Strings.Superbounded with SPARK_Mode is while Indx < Max_Length - Ilen loop Result.Data (Indx + 1 .. Indx + Ilen) := Super_String_Data (Item); - pragma Assert - (for all K in 1 .. Ilen => - Result.Data (Indx + K) = Item (Item'First - 1 + K)); - pragma Assert - (String (Result.Data (Indx + 1 .. Indx + Ilen)) = Item); - Lemma_Split (Forward); Indx := Indx + Ilen; - pragma Loop_Invariant (Indx mod Ilen = 0); - pragma Loop_Invariant (Indx in 0 .. Max_Length - 1); - pragma Loop_Invariant (Result.Data (1 .. Indx)'Initialized); - pragma Loop_Invariant - (for all K in 1 .. Indx => - Result.Data (K) = - Item (Item'First + (K - 1) mod Ilen)); - pragma Loop_Variant (Increases => Indx); end loop; Result.Data (Indx + 1 .. Max_Length) := Super_String_Data (Item (Item'First .. Item'First + (Max_Length - Indx - 1))); - pragma Assert - (for all J in Indx + 1 .. Max_Length => - Result.Data (J) = Item (Item'First - 1 - Indx + J)); - - for J in Indx + 1 .. Max_Length loop - Lemma_Mod (J - 1, Indx); - pragma Loop_Invariant - (for all K in 1 .. J => - Result.Data (K) = - Item (Item'First + (K - 1) mod Ilen)); - end loop; when Strings.Left => Indx := Max_Length; @@ -1595,40 +1464,10 @@ package body Ada.Strings.Superbounded with SPARK_Mode is Indx := Indx - Ilen; Result.Data (Indx + 1 .. Indx + Ilen) := Super_String_Data (Item); - pragma Assert - (for all K in 1 .. Ilen => - Result.Data (Indx + K) = Item (Item'First - 1 + K)); - pragma Assert - (String (Result.Data (Indx + 1 .. Indx + Ilen)) = Item); - Lemma_Split (Backward); - Lemma_Mod_Zero (Max_Length - Indx - Ilen); - pragma Loop_Invariant - ((Max_Length - Indx) mod Ilen = 0); - pragma Loop_Invariant (Indx in 1 .. Max_Length); - pragma Loop_Invariant - (Result.Data (Indx + 1 .. Max_Length)'Initialized); - pragma Loop_Invariant - (for all K in Indx + 1 .. Max_Length => - Result.Data (K) = - Item (Item'Last - (Max_Length - K) mod Ilen)); - pragma Loop_Variant (Decreases => Indx); end loop; Result.Data (1 .. Indx) := Super_String_Data (Item (Item'Last - Indx + 1 .. Item'Last)); - pragma Assert - (for all J in 1 .. Indx => - Result.Data (J) = Item (Item'Last - Indx + J)); - - for J in reverse 1 .. Indx loop - Lemma_Mod (Max_Length - J, Max_Length - Indx); - pragma Loop_Invariant - (for all K in J .. Max_Length => - Result.Data (K) = - Item (Item'Last - (Max_Length - K) mod Ilen)); - end loop; - pragma Assert - (Result.Data (1 .. Max_Length)'Initialized); when Strings.Error => raise Ada.Strings.Length_Error; @@ -1643,8 +1482,7 @@ package body Ada.Strings.Superbounded with SPARK_Mode is function Super_Replicate (Count : Natural; Item : Super_String; - Drop : Strings.Truncation := Strings.Error) return Super_String - is + Drop : Strings.Truncation := Strings.Error) return Super_String is begin return Super_Replicate (Count, Super_To_String (Item), Drop, Item.Max_Length); @@ -1820,14 +1658,9 @@ package body Ada.Strings.Superbounded with SPARK_Mode is Mapping : Maps.Character_Mapping) return Super_String is Result : Super_String (Source.Max_Length); - begin for J in 1 .. Source.Current_Length loop Result.Data (J) := Value (Mapping, Source.Data (J)); - pragma Loop_Invariant (Result.Data (1 .. J)'Initialized); - pragma Loop_Invariant - (for all K in 1 .. J => - Result.Data (K) = Value (Mapping, Source.Data (K))); end loop; Result.Current_Length := Source.Current_Length; @@ -1836,14 +1669,10 @@ package body Ada.Strings.Superbounded with SPARK_Mode is procedure Super_Translate (Source : in out Super_String; - Mapping : Maps.Character_Mapping) - is + Mapping : Maps.Character_Mapping) is begin for J in 1 .. Source.Current_Length loop Source.Data (J) := Value (Mapping, Source.Data (J)); - pragma Loop_Invariant - (for all K in 1 .. J => - Source.Data (K) = Value (Mapping, Source'Loop_Entry.Data (K))); end loop; end Super_Translate; @@ -1852,20 +1681,9 @@ package body Ada.Strings.Superbounded with SPARK_Mode is Mapping : Maps.Character_Mapping_Function) return Super_String is Result : Super_String (Source.Max_Length); - begin for J in 1 .. Source.Current_Length loop Result.Data (J) := Mapping.all (Source.Data (J)); - pragma Annotate (GNATprove, False_Positive, - "call via access-to-subprogram", - "function Mapping must always terminate"); - pragma Loop_Invariant (Result.Data (1 .. J)'Initialized); - pragma Loop_Invariant - (for all K in 1 .. J => - Result.Data (K) = Mapping (Source.Data (K))); - pragma Annotate (GNATprove, False_Positive, - "call via access-to-subprogram", - "function Mapping must always terminate"); end loop; Result.Current_Length := Source.Current_Length; @@ -1874,20 +1692,10 @@ package body Ada.Strings.Superbounded with SPARK_Mode is procedure Super_Translate (Source : in out Super_String; - Mapping : Maps.Character_Mapping_Function) - is + Mapping : Maps.Character_Mapping_Function) is begin for J in 1 .. Source.Current_Length loop Source.Data (J) := Mapping.all (Source.Data (J)); - pragma Annotate (GNATprove, False_Positive, - "call via access-to-subprogram", - "function Mapping must always terminate"); - pragma Loop_Invariant - (for all K in 1 .. J => - Source.Data (K) = Mapping (Source'Loop_Entry.Data (K))); - pragma Annotate (GNATprove, False_Positive, - "call via access-to-subprogram", - "function Mapping must always terminate"); end loop; end Super_Translate; @@ -1901,7 +1709,6 @@ package body Ada.Strings.Superbounded with SPARK_Mode is is Result : Super_String (Source.Max_Length); Last : constant Natural := Source.Current_Length; - begin case Side is when Strings.Left => @@ -2101,13 +1908,9 @@ package body Ada.Strings.Superbounded with SPARK_Mode is begin if Left > Max_Length then raise Ada.Strings.Length_Error; - else for J in 1 .. Left loop Result.Data (J) := Right; - pragma Loop_Invariant (Result.Data (1 .. J)'Initialized); - pragma Loop_Invariant - (for all K in 1 .. J => Result.Data (K) = Right); end loop; Result.Current_Length := Left; @@ -2126,80 +1929,15 @@ package body Ada.Strings.Superbounded with SPARK_Mode is Rlen : constant Natural := Right'Length; Nlen : constant Natural := Left * Rlen; - -- Parts of the proof involving manipulations with the modulo operator - -- are complicated for the prover and can't be done automatically in - -- the global subprogram. That's why we isolate them in these two ghost - -- lemmas. - - procedure Lemma_Mod (K : Integer) with - Ghost, - Pre => - Rlen /= 0 - and then Pos mod Rlen = 0 - and then Pos in 0 .. Max_Length - Rlen - and then K in Pos .. Pos + Rlen - 1, - Post => K mod Rlen = K - Pos; - -- Lemma_Mod is applied to an index considered in Lemma_Split to prove - -- that it has the right value modulo Right'Length. - - procedure Lemma_Split with - Ghost, - Pre => - Rlen /= 0 - and then Pos mod Rlen = 0 - and then Pos in 0 .. Max_Length - Rlen - and then Result.Data (1 .. Pos + Rlen)'Initialized - and then String (Result.Data (Pos + 1 .. Pos + Rlen)) = Right, - Post => - (for all K in Pos + 1 .. Pos + Rlen => - Result.Data (K) = Right (Right'First + (K - 1) mod Rlen)); - -- Lemma_Split is used after Result.Data (Pos + 1 .. Pos + Rlen) is - -- updated to Right and concludes that the characters match for each - -- index when taken modulo Right'Length, as the considered slice starts - -- at index 1 modulo Right'Length. - - --------------- - -- Lemma_Mod -- - --------------- - - procedure Lemma_Mod (K : Integer) is null; - - ----------------- - -- Lemma_Split -- - ----------------- - - procedure Lemma_Split is - begin - for K in Pos + 1 .. Pos + Rlen loop - Lemma_Mod (K - 1); - pragma Loop_Invariant - (for all J in Pos + 1 .. K => - Result.Data (J) = Right (Right'First + (J - 1) mod Rlen)); - end loop; - end Lemma_Split; - begin if Nlen > Max_Length then raise Ada.Strings.Length_Error; - else if Nlen > 0 then for J in 1 .. Left loop Result.Data (Pos + 1 .. Pos + Rlen) := Super_String_Data (Right); - pragma Assert - (for all K in 1 .. Rlen => Result.Data (Pos + K) = - Right (Right'First - 1 + K)); - pragma Assert - (String (Result.Data (Pos + 1 .. Pos + Rlen)) = Right); - Lemma_Split; Pos := Pos + Rlen; - pragma Loop_Invariant (Pos = J * Rlen); - pragma Loop_Invariant (Result.Data (1 .. Pos)'Initialized); - pragma Loop_Invariant - (for all K in 1 .. Pos => - Result.Data (K) = - Right (Right'First + (K - 1) mod Rlen)); end loop; end if; @@ -2221,19 +1959,12 @@ package body Ada.Strings.Superbounded with SPARK_Mode is begin if Nlen > Right.Max_Length then raise Ada.Strings.Length_Error; - else if Nlen > 0 then for J in 1 .. Left loop Result.Data (Pos + 1 .. Pos + Rlen) := Right.Data (1 .. Rlen); Pos := Pos + Rlen; - pragma Loop_Invariant (Pos = J * Rlen); - pragma Loop_Invariant (Result.Data (1 .. Pos)'Initialized); - pragma Loop_Invariant - (for all K in 1 .. Pos => - Result.Data (K) = - Right.Data (1 + (K - 1) mod Rlen)); end loop; end if; @@ -2259,7 +1990,6 @@ package body Ada.Strings.Superbounded with SPARK_Mode is if Slen <= Max_Length then Result.Data (1 .. Slen) := Super_String_Data (Source); Result.Current_Length := Slen; - else case Drop is when Strings.Right => diff --git a/gcc/ada/libgnat/i-c.adb b/gcc/ada/libgnat/i-c.adb index d248ceb..e63c014 100644 --- a/gcc/ada/libgnat/i-c.adb +++ b/gcc/ada/libgnat/i-c.adb @@ -29,78 +29,10 @@ -- -- ------------------------------------------------------------------------------ --- Ghost code, loop invariants and assertions in this unit are meant for --- analysis only, not for run-time checking, as it would be too costly --- otherwise. This is enforced by setting the assertion policy to Ignore. - -pragma Assertion_Policy (Ghost => Ignore, - Loop_Invariant => Ignore, - Assert => Ignore); - package body Interfaces.C with SPARK_Mode is - -------------------- - -- C_Length_Ghost -- - -------------------- - - function C_Length_Ghost (Item : char_array) return size_t is - begin - for J in Item'Range loop - if Item (J) = nul then - return J - Item'First; - end if; - - pragma Loop_Invariant - (for all K in Item'First .. J => Item (K) /= nul); - end loop; - - raise Program_Error; - end C_Length_Ghost; - - function C_Length_Ghost (Item : wchar_array) return size_t is - begin - for J in Item'Range loop - if Item (J) = wide_nul then - return J - Item'First; - end if; - - pragma Loop_Invariant - (for all K in Item'First .. J => Item (K) /= wide_nul); - end loop; - - raise Program_Error; - end C_Length_Ghost; - - function C_Length_Ghost (Item : char16_array) return size_t is - begin - for J in Item'Range loop - if Item (J) = char16_nul then - return J - Item'First; - end if; - - pragma Loop_Invariant - (for all K in Item'First .. J => Item (K) /= char16_nul); - end loop; - - raise Program_Error; - end C_Length_Ghost; - - function C_Length_Ghost (Item : char32_array) return size_t is - begin - for J in Item'Range loop - if Item (J) = char32_nul then - return J - Item'First; - end if; - - pragma Loop_Invariant - (for all K in Item'First .. J => Item (K) /= char32_nul); - end loop; - - raise Program_Error; - end C_Length_Ghost; - ----------------------- -- Is_Nul_Terminated -- ----------------------- @@ -113,9 +45,6 @@ is if Item (J) = nul then return True; end if; - - pragma Loop_Invariant - (for all K in Item'First .. J => Item (K) /= nul); end loop; return False; @@ -129,9 +58,6 @@ is if Item (J) = wide_nul then return True; end if; - - pragma Loop_Invariant - (for all K in Item'First .. J => Item (K) /= wide_nul); end loop; return False; @@ -145,9 +71,6 @@ is if Item (J) = char16_nul then return True; end if; - - pragma Loop_Invariant - (for all K in Item'First .. J => Item (K) /= char16_nul); end loop; return False; @@ -161,9 +84,6 @@ is if Item (J) = char32_nul then return True; end if; - - pragma Loop_Invariant - (for all K in Item'First .. J => Item (K) /= char32_nul); end loop; return False; @@ -194,14 +114,6 @@ is From := Item'First; loop - pragma Loop_Invariant (From in Item'Range); - pragma Loop_Invariant - (for some J in From .. Item'Last => Item (J) = nul); - pragma Loop_Invariant - (for all J in Item'First .. From when J /= From => - Item (J) /= nul); - pragma Loop_Variant (Increases => From); - if From > Item'Last then raise Terminator_Error; elsif Item (From) = nul then @@ -211,8 +123,6 @@ is end if; end loop; - pragma Assert (From = Item'First + C_Length_Ghost (Item)); - Count := Natural (From - Item'First); else @@ -220,17 +130,10 @@ is end if; declare - Count_Cst : constant Natural := Count; - R : String (1 .. Count_Cst) with Relaxed_Initialization; - + R : String (1 .. Count); begin for J in R'Range loop R (J) := To_Ada (Item (size_t (J) - 1 + Item'First)); - - pragma Loop_Invariant (for all K in 1 .. J => R (K)'Initialized); - pragma Loop_Invariant - (for all K in 1 .. J => - R (K) = To_Ada (Item (size_t (K) - 1 + Item'First))); end loop; return R; @@ -252,14 +155,6 @@ is if Trim_Nul then From := Item'First; loop - pragma Loop_Invariant (From in Item'Range); - pragma Loop_Invariant - (for some J in From .. Item'Last => Item (J) = nul); - pragma Loop_Invariant - (for all J in Item'First .. From when J /= From => - Item (J) /= nul); - pragma Loop_Variant (Increases => From); - if From > Item'Last then raise Terminator_Error; elsif Item (From) = nul then @@ -285,19 +180,6 @@ is for J in 1 .. Count loop Target (To) := Character (Item (From)); - pragma Loop_Invariant (From in Item'Range); - pragma Loop_Invariant (To in Target'Range); - pragma Loop_Invariant (To = Target'First + (J - 1)); - pragma Loop_Invariant (From = Item'First + size_t (J - 1)); - pragma Loop_Invariant - (for all J in Target'First .. To => Target (J)'Initialized); - pragma Loop_Invariant - (Target (Target'First .. To)'Initialized); - pragma Loop_Invariant - (for all K in Target'First .. To => - Target (K) = - To_Ada (Item (size_t (K - Target'First) + Item'First))); - -- Avoid possible overflow when incrementing To in the last -- iteration of the loop. exit when J = Count; @@ -329,14 +211,6 @@ is From := Item'First; loop - pragma Loop_Invariant (From in Item'Range); - pragma Loop_Invariant - (for some J in From .. Item'Last => Item (J) = wide_nul); - pragma Loop_Invariant - (for all J in Item'First .. From when J /= From => - Item (J) /= wide_nul); - pragma Loop_Variant (Increases => From); - if From > Item'Last then raise Terminator_Error; elsif Item (From) = wide_nul then @@ -346,8 +220,6 @@ is end if; end loop; - pragma Assert (From = Item'First + C_Length_Ghost (Item)); - Count := Natural (From - Item'First); else @@ -355,17 +227,10 @@ is end if; declare - Count_Cst : constant Natural := Count; - R : Wide_String (1 .. Count_Cst) with Relaxed_Initialization; - + R : Wide_String (1 .. Count); begin for J in R'Range loop R (J) := To_Ada (Item (size_t (J) - 1 + Item'First)); - - pragma Loop_Invariant (for all K in 1 .. J => R (K)'Initialized); - pragma Loop_Invariant - (for all K in 1 .. J => - R (K) = To_Ada (Item (size_t (K) - 1 + Item'First))); end loop; return R; @@ -387,14 +252,6 @@ is if Trim_Nul then From := Item'First; loop - pragma Loop_Invariant (From in Item'Range); - pragma Loop_Invariant - (for some J in From .. Item'Last => Item (J) = wide_nul); - pragma Loop_Invariant - (for all J in Item'First .. From when J /= From => - Item (J) /= wide_nul); - pragma Loop_Variant (Increases => From); - if From > Item'Last then raise Terminator_Error; elsif Item (From) = wide_nul then @@ -420,19 +277,6 @@ is for J in 1 .. Count loop Target (To) := To_Ada (Item (From)); - pragma Loop_Invariant (From in Item'Range); - pragma Loop_Invariant (To in Target'Range); - pragma Loop_Invariant (To = Target'First + (J - 1)); - pragma Loop_Invariant (From = Item'First + size_t (J - 1)); - pragma Loop_Invariant - (for all J in Target'First .. To => Target (J)'Initialized); - pragma Loop_Invariant - (Target (Target'First .. To)'Initialized); - pragma Loop_Invariant - (for all K in Target'First .. To => - Target (K) = - To_Ada (Item (size_t (K - Target'First) + Item'First))); - -- Avoid possible overflow when incrementing To in the last -- iteration of the loop. exit when J = Count; @@ -464,14 +308,6 @@ is From := Item'First; loop - pragma Loop_Invariant (From in Item'Range); - pragma Loop_Invariant - (for some J in From .. Item'Last => Item (J) = char16_nul); - pragma Loop_Invariant - (for all J in Item'First .. From when J /= From => - Item (J) /= char16_nul); - pragma Loop_Variant (Increases => From); - if From > Item'Last then raise Terminator_Error; elsif Item (From) = char16_nul then @@ -481,8 +317,6 @@ is end if; end loop; - pragma Assert (From = Item'First + C_Length_Ghost (Item)); - Count := Natural (From - Item'First); else @@ -490,17 +324,10 @@ is end if; declare - Count_Cst : constant Natural := Count; - R : Wide_String (1 .. Count_Cst) with Relaxed_Initialization; - + R : Wide_String (1 .. Count); begin for J in R'Range loop R (J) := To_Ada (Item (size_t (J) - 1 + Item'First)); - - pragma Loop_Invariant (for all K in 1 .. J => R (K)'Initialized); - pragma Loop_Invariant - (for all K in 1 .. J => - R (K) = To_Ada (Item (size_t (K) - 1 + Item'First))); end loop; return R; @@ -522,14 +349,6 @@ is if Trim_Nul then From := Item'First; loop - pragma Loop_Invariant (From in Item'Range); - pragma Loop_Invariant - (for some J in From .. Item'Last => Item (J) = char16_nul); - pragma Loop_Invariant - (for all J in Item'First .. From when J /= From => - Item (J) /= char16_nul); - pragma Loop_Variant (Increases => From); - if From > Item'Last then raise Terminator_Error; elsif Item (From) = char16_nul then @@ -555,19 +374,6 @@ is for J in 1 .. Count loop Target (To) := To_Ada (Item (From)); - pragma Loop_Invariant (From in Item'Range); - pragma Loop_Invariant (To in Target'Range); - pragma Loop_Invariant (To = Target'First + (J - 1)); - pragma Loop_Invariant (From = Item'First + size_t (J - 1)); - pragma Loop_Invariant - (for all J in Target'First .. To => Target (J)'Initialized); - pragma Loop_Invariant - (Target (Target'First .. To)'Initialized); - pragma Loop_Invariant - (for all K in Target'First .. To => - Target (K) = - To_Ada (Item (size_t (K - Target'First) + Item'First))); - -- Avoid possible overflow when incrementing To in the last -- iteration of the loop. exit when J = Count; @@ -599,15 +405,6 @@ is From := Item'First; loop - pragma Loop_Invariant (From in Item'Range); - pragma Loop_Invariant - (for some J in From .. Item'Last => Item (J) = char32_nul); - pragma Loop_Invariant - (for all J in Item'First .. From when J /= From => - Item (J) /= char32_nul); - pragma Loop_Invariant (From <= Item'First + C_Length_Ghost (Item)); - pragma Loop_Variant (Increases => From); - if From > Item'Last then raise Terminator_Error; elsif Item (From) = char32_nul then @@ -617,8 +414,6 @@ is end if; end loop; - pragma Assert (From = Item'First + C_Length_Ghost (Item)); - Count := Natural (From - Item'First); else @@ -626,17 +421,11 @@ is end if; declare - Count_Cst : constant Natural := Count; - R : Wide_Wide_String (1 .. Count_Cst) with Relaxed_Initialization; + R : Wide_Wide_String (1 .. Count); begin for J in R'Range loop R (J) := To_Ada (Item (size_t (J) - 1 + Item'First)); - - pragma Loop_Invariant (for all K in 1 .. J => R (K)'Initialized); - pragma Loop_Invariant - (for all K in 1 .. J => - R (K) = To_Ada (Item (size_t (K) - 1 + Item'First))); end loop; return R; @@ -658,14 +447,6 @@ is if Trim_Nul then From := Item'First; loop - pragma Loop_Invariant (From in Item'Range); - pragma Loop_Invariant - (for some J in From .. Item'Last => Item (J) = char32_nul); - pragma Loop_Invariant - (for all J in Item'First .. From when J /= From => - Item (J) /= char32_nul); - pragma Loop_Variant (Increases => From); - if From > Item'Last then raise Terminator_Error; elsif Item (From) = char32_nul then @@ -691,19 +472,6 @@ is for J in 1 .. Count loop Target (To) := To_Ada (Item (From)); - pragma Loop_Invariant (From in Item'Range); - pragma Loop_Invariant (To in Target'Range); - pragma Loop_Invariant (To = Target'First + (J - 1)); - pragma Loop_Invariant (From = Item'First + size_t (J - 1)); - pragma Loop_Invariant - (for all J in Target'First .. To => Target (J)'Initialized); - pragma Loop_Invariant - (Target (Target'First .. To)'Initialized); - pragma Loop_Invariant - (for all K in Target'First .. To => - Target (K) = - To_Ada (Item (size_t (K - Target'First) + Item'First))); - -- Avoid possible overflow when incrementing To in the last -- iteration of the loop. exit when J = Count; @@ -734,26 +502,14 @@ is begin if Append_Nul then declare - R : char_array (0 .. Item'Length) with Relaxed_Initialization; - + R : char_array (0 .. Item'Length); begin for J in Item'Range loop R (size_t (J - Item'First)) := To_C (Item (J)); - - pragma Loop_Invariant - (for all K in 0 .. size_t (J - Item'First) => - R (K)'Initialized); - pragma Loop_Invariant - (for all K in Item'First .. J => - R (size_t (K - Item'First)) = To_C (Item (K))); end loop; R (R'Last) := nul; - pragma Assert - (for all J in Item'Range => - R (size_t (J - Item'First)) = To_C (Item (J))); - return R; end; @@ -774,19 +530,10 @@ is else declare - R : char_array (0 .. Item'Length - 1) - with Relaxed_Initialization; - + R : char_array (0 .. Item'Length - 1); begin for J in Item'Range loop R (size_t (J - Item'First)) := To_C (Item (J)); - - pragma Loop_Invariant - (for all K in 0 .. size_t (J - Item'First) => - R (K)'Initialized); - pragma Loop_Invariant - (for all K in Item'First .. J => - R (size_t (K - Item'First)) = To_C (Item (K))); end loop; return R; @@ -814,18 +561,6 @@ is for From in Item'Range loop Target (To) := char (Item (From)); - pragma Loop_Invariant (To in Target'Range); - pragma Loop_Invariant - (To - Target'First = size_t (From - Item'First)); - pragma Loop_Invariant - (for all J in Target'First .. To => Target (J)'Initialized); - pragma Loop_Invariant - (Target (Target'First .. To)'Initialized); - pragma Loop_Invariant - (for all J in Item'First .. From => - Target (Target'First + size_t (J - Item'First)) = - To_C (Item (J))); - To := To + 1; end loop; @@ -836,7 +571,6 @@ is Target (To) := nul; Count := Item'Length + 1; end if; - else Count := Item'Length; end if; @@ -859,26 +593,14 @@ is begin if Append_Nul then declare - R : wchar_array (0 .. Item'Length) with Relaxed_Initialization; - + R : wchar_array (0 .. Item'Length); begin for J in Item'Range loop R (size_t (J - Item'First)) := To_C (Item (J)); - - pragma Loop_Invariant - (for all K in 0 .. size_t (J - Item'First) => - R (K)'Initialized); - pragma Loop_Invariant - (for all K in Item'First .. J => - R (size_t (K - Item'First)) = To_C (Item (K))); end loop; R (R'Last) := wide_nul; - pragma Assert - (for all J in Item'Range => - R (size_t (J - Item'First)) = To_C (Item (J))); - return R; end; @@ -895,19 +617,10 @@ is else declare - R : wchar_array (0 .. Item'Length - 1) - with Relaxed_Initialization; - + R : wchar_array (0 .. Item'Length - 1); begin for J in Item'Range loop R (size_t (J - Item'First)) := To_C (Item (J)); - - pragma Loop_Invariant - (for all K in 0 .. size_t (J - Item'First) => - R (K)'Initialized); - pragma Loop_Invariant - (for all K in Item'First .. J => - R (size_t (K - Item'First)) = To_C (Item (K))); end loop; return R; @@ -925,40 +638,17 @@ is Append_Nul : Boolean := True) is To : size_t; - begin if Target'Length < Item'Length then raise Constraint_Error; - else To := Target'First; for From in Item'Range loop Target (To) := To_C (Item (From)); - pragma Loop_Invariant (To in Target'Range); - pragma Loop_Invariant - (To - Target'First = size_t (From - Item'First)); - pragma Loop_Invariant - (for all J in Target'First .. To => Target (J)'Initialized); - pragma Loop_Invariant - (Target (Target'First .. To)'Initialized); - pragma Loop_Invariant - (for all J in Item'First .. From => - Target (Target'First + size_t (J - Item'First)) = - To_C (Item (J))); - To := To + 1; end loop; - pragma Assert - (for all J in Item'Range => - Target (Target'First + size_t (J - Item'First)) = - To_C (Item (J))); - pragma Assert - (if Item'Length /= 0 then - Target (Target'First .. - Target'First + (Item'Length - 1))'Initialized); - if Append_Nul then if To > Target'Last then raise Constraint_Error; @@ -966,7 +656,6 @@ is Target (To) := wide_nul; Count := Item'Length + 1; end if; - else Count := Item'Length; end if; @@ -989,26 +678,14 @@ is begin if Append_Nul then declare - R : char16_array (0 .. Item'Length) with Relaxed_Initialization; - + R : char16_array (0 .. Item'Length); begin for J in Item'Range loop R (size_t (J - Item'First)) := To_C (Item (J)); - - pragma Loop_Invariant - (for all K in 0 .. size_t (J - Item'First) => - R (K)'Initialized); - pragma Loop_Invariant - (for all K in Item'First .. J => - R (size_t (K - Item'First)) = To_C (Item (K))); end loop; R (R'Last) := char16_nul; - pragma Assert - (for all J in Item'Range => - R (size_t (J - Item'First)) = To_C (Item (J))); - return R; end; @@ -1022,22 +699,12 @@ is if Item'Length = 0 then raise Constraint_Error; - else declare - R : char16_array (0 .. Item'Length - 1) - with Relaxed_Initialization; - + R : char16_array (0 .. Item'Length - 1); begin for J in Item'Range loop R (size_t (J - Item'First)) := To_C (Item (J)); - - pragma Loop_Invariant - (for all K in 0 .. size_t (J - Item'First) => - R (K)'Initialized); - pragma Loop_Invariant - (for all K in Item'First .. J => - R (size_t (K - Item'First)) = To_C (Item (K))); end loop; return R; @@ -1055,7 +722,6 @@ is Append_Nul : Boolean := True) is To : size_t; - begin if Target'Length < Item'Length then raise Constraint_Error; @@ -1065,30 +731,9 @@ is for From in Item'Range loop Target (To) := To_C (Item (From)); - pragma Loop_Invariant (To in Target'Range); - pragma Loop_Invariant - (To - Target'First = size_t (From - Item'First)); - pragma Loop_Invariant - (for all J in Target'First .. To => Target (J)'Initialized); - pragma Loop_Invariant - (Target (Target'First .. To)'Initialized); - pragma Loop_Invariant - (for all J in Item'First .. From => - Target (Target'First + size_t (J - Item'First)) = - To_C (Item (J))); - To := To + 1; end loop; - pragma Assert - (for all J in Item'Range => - Target (Target'First + size_t (J - Item'First)) = - To_C (Item (J))); - pragma Assert - (if Item'Length /= 0 then - Target (Target'First .. - Target'First + (Item'Length - 1))'Initialized); - if Append_Nul then if To > Target'Last then raise Constraint_Error; @@ -1096,7 +741,6 @@ is Target (To) := char16_nul; Count := Item'Length + 1; end if; - else Count := Item'Length; end if; @@ -1119,26 +763,14 @@ is begin if Append_Nul then declare - R : char32_array (0 .. Item'Length) with Relaxed_Initialization; - + R : char32_array (0 .. Item'Length); begin for J in Item'Range loop R (size_t (J - Item'First)) := To_C (Item (J)); - - pragma Loop_Invariant - (for all K in 0 .. size_t (J - Item'First) => - R (K)'Initialized); - pragma Loop_Invariant - (for all K in Item'First .. J => - R (size_t (K - Item'First)) = To_C (Item (K))); end loop; R (R'Last) := char32_nul; - pragma Assert - (for all J in Item'Range => - R (size_t (J - Item'First)) = To_C (Item (J))); - return R; end; @@ -1154,19 +786,10 @@ is else declare - R : char32_array (0 .. Item'Length - 1) - with Relaxed_Initialization; - + R : char32_array (0 .. Item'Length - 1); begin for J in Item'Range loop R (size_t (J - Item'First)) := To_C (Item (J)); - - pragma Loop_Invariant - (for all K in 0 .. size_t (J - Item'First) => - R (K)'Initialized); - pragma Loop_Invariant - (for all K in Item'First .. J => - R (size_t (K - Item'First)) = To_C (Item (K))); end loop; return R; @@ -1188,36 +811,15 @@ is begin if Target'Length < Item'Length + (if Append_Nul then 1 else 0) then raise Constraint_Error; - else To := Target'First; + for From in Item'Range loop Target (To) := To_C (Item (From)); - pragma Loop_Invariant (To in Target'Range); - pragma Loop_Invariant - (To - Target'First = size_t (From - Item'First)); - pragma Loop_Invariant - (for all J in Target'First .. To => Target (J)'Initialized); - pragma Loop_Invariant - (Target (Target'First .. To)'Initialized); - pragma Loop_Invariant - (for all J in Item'First .. From => - Target (Target'First + size_t (J - Item'First)) = - To_C (Item (J))); - To := To + 1; end loop; - pragma Assert - (for all J in Item'Range => - Target (Target'First + size_t (J - Item'First)) = - To_C (Item (J))); - pragma Assert - (if Item'Length /= 0 then - Target (Target'First .. - Target'First + (Item'Length - 1))'Initialized); - if Append_Nul then Target (To) := char32_nul; Count := Item'Length + 1; @@ -1226,7 +828,5 @@ is end if; end if; end To_C; - pragma Annotate (CodePeer, False_Positive, "validity check", - "Count is only uninitialized on abnormal return."); end Interfaces.C; diff --git a/gcc/ada/libgnat/i-c.ads b/gcc/ada/libgnat/i-c.ads index f9f9f75..fc77caf 100644 --- a/gcc/ada/libgnat/i-c.ads +++ b/gcc/ada/libgnat/i-c.ads @@ -133,6 +133,7 @@ is function C_Length_Ghost (Item : char_array) return size_t with Ghost, + Import, Pre => Is_Nul_Terminated (Item), Post => C_Length_Ghost'Result <= Item'Last - Item'First and then Item (Item'First + C_Length_Ghost'Result) = nul @@ -274,6 +275,7 @@ is function C_Length_Ghost (Item : wchar_array) return size_t with Ghost, + Import, Pre => Is_Nul_Terminated (Item), Post => C_Length_Ghost'Result <= Item'Last - Item'First and then Item (Item'First + C_Length_Ghost'Result) = wide_nul @@ -395,6 +397,7 @@ is function C_Length_Ghost (Item : char16_array) return size_t with Ghost, + Import, Pre => Is_Nul_Terminated (Item), Post => C_Length_Ghost'Result <= Item'Last - Item'First and then Item (Item'First + C_Length_Ghost'Result) = char16_nul @@ -510,6 +513,7 @@ is function C_Length_Ghost (Item : char32_array) return size_t with Ghost, + Import, Pre => Is_Nul_Terminated (Item), Post => C_Length_Ghost'Result <= Item'Last - Item'First and then Item (Item'First + C_Length_Ghost'Result) = char32_nul diff --git a/gcc/ada/libgnat/i-cstrin.adb b/gcc/ada/libgnat/i-cstrin.adb index 7bf881f..8279562 100644 --- a/gcc/ada/libgnat/i-cstrin.adb +++ b/gcc/ada/libgnat/i-cstrin.adb @@ -66,8 +66,11 @@ is pragma Inline ("+"); -- Address arithmetic on chars_ptr value - function Position_Of_Nul (Into : char_array) return size_t; - -- Returns position of the first Nul in Into or Into'Last + 1 if none + procedure Position_Of_Nul + (Into : char_array; Found : out Boolean; Index : out size_t); + -- If into contains a Nul character, Found is set to True and Index + -- contains the position of the first Nul character in Into. Otherwise + -- Found is set to False and the value of Index is not meaningful. -- We can't use directly System.Memory because the categorization is not -- compatible, so we directly import here the malloc and free routines. @@ -107,6 +110,7 @@ is -------------------- function New_Char_Array (Chars : char_array) return chars_ptr is + Found : Boolean; Index : size_t; Pointer : chars_ptr; @@ -114,24 +118,25 @@ is -- Get index of position of null. If Index > Chars'Last, -- nul is absent and must be added explicitly. - Index := Position_Of_Nul (Into => Chars); - Pointer := Memory_Alloc ((Index - Chars'First + 1)); + Position_Of_Nul (Into => Chars, Found => Found, Index => Index); -- If nul is present, transfer string up to and including nul - if Index <= Chars'Last then - Update (Item => Pointer, - Offset => 0, - Chars => Chars (Chars'First .. Index), - Check => False); + if Found then + Pointer := Memory_Alloc (Index - Chars'First + 1); + + Update + (Item => Pointer, + Offset => 0, + Chars => Chars (Chars'First .. Index), + Check => False); else -- If original string has no nul, transfer whole string and add -- terminator explicitly. - Update (Item => Pointer, - Offset => 0, - Chars => Chars, - Check => False); + Pointer := Memory_Alloc (Chars'Length + 1); + + Update (Item => Pointer, Offset => 0, Chars => Chars, Check => False); Poke (nul, Into => Pointer + size_t'(Chars'Length)); end if; @@ -148,20 +153,33 @@ is -- the result, and doesn't copy the string on the stack, otherwise its -- use is limited when used from tasks on large strings. - Result : constant chars_ptr := Memory_Alloc (Str'Length + 1); + Len : Natural := 0; + -- Length of the longest prefix of Str that doesn't contain NUL - Result_Array : char_array (1 .. Str'Length + 1); - for Result_Array'Address use To_Address (Result); - pragma Import (Ada, Result_Array); + Result : chars_ptr; + begin + for C of Str loop + if C = ASCII.NUL then + exit; + end if; + Len := Len + 1; + end loop; - Count : size_t; + Result := Memory_Alloc (size_t (Len) + 1); + + declare + Result_Array : char_array (1 .. size_t (Len) + 1) + with Address => To_Address (Result), Import, Convention => Ada; + + Count : size_t; + begin + To_C + (Item => Str (Str'First .. Str'First + Len - 1), + Target => Result_Array, + Count => Count, + Append_Nul => True); + end; - begin - To_C - (Item => Str, - Target => Result_Array, - Count => Count, - Append_Nul => True); return Result; end New_String; @@ -187,19 +205,19 @@ is -- Position_Of_Nul -- --------------------- - function Position_Of_Nul (Into : char_array) return size_t is + procedure Position_Of_Nul + (Into : char_array; Found : out Boolean; Index : out size_t) is begin - pragma Annotate (Gnatcheck, Exempt_On, "Improper_Returns", - "early returns for performance"); + Found := False; + Index := 0; + for J in Into'Range loop if Into (J) = nul then - return J; + Found := True; + Index := J; + return; end if; end loop; - - return Into'Last + 1; - - pragma Annotate (Gnatcheck, Exempt_Off, "Improper_Returns"); end Position_Of_Nul; ------------ @@ -231,19 +249,22 @@ is (Item : char_array_access; Nul_Check : Boolean := False) return chars_ptr is + Found : Boolean; + Index : size_t; begin pragma Annotate (Gnatcheck, Exempt_On, "Improper_Returns", "early returns for performance"); if Item = null then return Null_Ptr; - elsif Nul_Check - and then Position_Of_Nul (Into => Item.all) > Item'Last - then - raise Terminator_Error; - else - return To_chars_ptr (Item (Item'First)'Address); + elsif Nul_Check then + Position_Of_Nul (Item.all, Found, Index); + if not Found then + raise Terminator_Error; + end if; end if; + return To_chars_ptr (Item (Item'First)'Address); + pragma Annotate (Gnatcheck, Exempt_Off, "Improper_Returns"); end To_Chars_Ptr; @@ -260,6 +281,11 @@ is Index : chars_ptr := Item + Offset; begin + -- Check for null pointer as mandated by the RM. + if Item = Null_Ptr then + raise Dereference_Error; + end if; + if Check and then Offset + Chars'Length > Strlen (Item) then raise Update_Error; end if; diff --git a/gcc/ada/libgnat/s-aridou.adb b/gcc/ada/libgnat/s-aridou.adb index e4140e8..dd2f150 100644 --- a/gcc/ada/libgnat/s-aridou.adb +++ b/gcc/ada/libgnat/s-aridou.adb @@ -29,74 +29,20 @@ -- -- ------------------------------------------------------------------------------ -pragma Annotate (Gnatcheck, Exempt_On, "Metrics_LSLOC", - "limit exceeded due to proof code"); - with Ada.Unchecked_Conversion; -with System.SPARK.Cut_Operations; use System.SPARK.Cut_Operations; package body System.Arith_Double with SPARK_Mode is - -- Contracts, ghost code, loop invariants and assertions in this unit are - -- meant for analysis only, not for run-time checking, as it would be too - -- costly otherwise. This is enforced by setting the assertion policy to - -- Ignore. - - pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore, - Loop_Invariant => Ignore, - Assert => Ignore, - Assert_And_Cut => Ignore); - pragma Suppress (Overflow_Check); pragma Suppress (Range_Check); - pragma Warnings - (Off, "statement has no effect", - Reason => "Ghost code on dead paths is used for verification only"); - function To_Uns is new Ada.Unchecked_Conversion (Double_Int, Double_Uns); function To_Int is new Ada.Unchecked_Conversion (Double_Uns, Double_Int); Double_Size : constant Natural := Double_Int'Size; Single_Size : constant Natural := Double_Int'Size / 2; - -- Log of Single_Size in base 2, so that Single_Size = 2 ** Log_Single_Size - Log_Single_Size : constant Natural := - (case Single_Size is - when 32 => 5, - when 64 => 6, - when 128 => 7, - when others => raise Program_Error) - with Ghost; - - -- Power-of-two constants - - pragma Warnings - (Off, "non-preelaborable call not allowed in preelaborated unit", - Reason => "Ghost code is not compiled"); - pragma Warnings - (Off, "non-static constant in preelaborated unit", - Reason => "Ghost code is not compiled"); - Big_0 : constant Big_Integer := - Big (Double_Uns'(0)) - with Ghost; - Big_2xxSingle : constant Big_Integer := - Big (Double_Int'(2 ** Single_Size)) - with Ghost; - Big_2xxDouble_Minus_1 : constant Big_Integer := - Big (Double_Uns'(2 ** (Double_Size - 1))) - with Ghost; - Big_2xxDouble : constant Big_Integer := - Big (Double_Uns'(2 ** Double_Size - 1)) + 1 - with Ghost; - pragma Warnings - (On, "non-preelaborable call not allowed in preelaborated unit"); - pragma Warnings (On, "non-static constant in preelaborated unit"); - pragma Annotate (Gnatcheck, Exempt_On, "Improper_Returns", "early returns for performance"); @@ -115,9 +61,7 @@ is -- Length doubling multiplication function "/" (A : Double_Uns; B : Single_Uns) return Double_Uns is - (A / Double_Uns (B)) - with - Pre => B /= 0; + (A / Double_Uns (B)); -- Length doubling division function "&" (Hi, Lo : Single_Uns) return Double_Uns is @@ -127,37 +71,15 @@ is function "abs" (X : Double_Int) return Double_Uns is (if X = Double_Int'First then Double_Uns'(2 ** (Double_Size - 1)) - else Double_Uns (Double_Int'(abs X))) - with Post => abs Big (X) = Big ("abs"'Result), - Annotate => (GNATprove, Hide_Info, "Expression_Function_Body"); + else Double_Uns (Double_Int'(abs X))); -- Convert absolute value of X to unsigned. Note that we can't just use -- the expression of the Else since it overflows for X = Double_Int'First. function "rem" (A : Double_Uns; B : Single_Uns) return Double_Uns is - (A rem Double_Uns (B)) - with - Pre => B /= 0; + (A rem Double_Uns (B)); -- Length doubling remainder - function Big_2xx (N : Natural) return Big_Positive is - (Big (Double_Uns'(2 ** N))) - with - Ghost, - Pre => N < Double_Size, - Post => Big_2xx'Result > 0; - -- 2**N as a big integer - - function Big3 (X1, X2, X3 : Single_Uns) return Big_Natural is - (Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (X1)) - + Big_2xxSingle * Big (Double_Uns (X2)) - + Big (Double_Uns (X3))) - with - Ghost; - -- X1&X2&X3 as a big integer - - function Le3 (X1, X2, X3, Y1, Y2, Y3 : Single_Uns) return Boolean - with - Post => Le3'Result = (Big3 (X1, X2, X3) <= Big3 (Y1, Y2, Y3)); + function Le3 (X1, X2, X3, Y1, Y2, Y3 : Single_Uns) return Boolean; -- Determines if (3 * Single_Size)-bit value X1&X2&X3 <= Y1&Y2&Y3 function Lo (A : Double_Uns) return Single_Uns is @@ -168,654 +90,41 @@ is (Single_Uns (Shift_Right (A, Single_Size))); -- High order half of double value - procedure Sub3 (X1, X2, X3 : in out Single_Uns; Y1, Y2, Y3 : Single_Uns) - with - Pre => Big3 (X1, X2, X3) >= Big3 (Y1, Y2, Y3), - Post => Big3 (X1, X2, X3) = Big3 (X1, X2, X3)'Old - Big3 (Y1, Y2, Y3); + procedure Sub3 (X1, X2, X3 : in out Single_Uns; Y1, Y2, Y3 : Single_Uns); -- Computes X1&X2&X3 := X1&X2&X3 - Y1&Y1&Y3 mod 2 ** (3 * Single_Size) - function To_Neg_Int (A : Double_Uns) return Double_Int - with - Pre => In_Double_Int_Range (-Big (A)), - Post => Big (To_Neg_Int'Result) = -Big (A); + function To_Neg_Int (A : Double_Uns) return Double_Int; -- Convert to negative integer equivalent. If the input is in the range -- 0 .. 2 ** (Double_Size - 1), then the corresponding nonpositive signed -- integer (obtained by negating the given value) is returned, otherwise -- constraint error is raised. - function To_Pos_Int (A : Double_Uns) return Double_Int - with - Pre => In_Double_Int_Range (Big (A)), - Post => Big (To_Pos_Int'Result) = Big (A); + function To_Pos_Int (A : Double_Uns) return Double_Int; -- Convert to positive integer equivalent. If the input is in the range -- 0 .. 2 ** (Double_Size - 1) - 1, then the corresponding non-negative -- signed integer is returned, otherwise constraint error is raised. - procedure Raise_Error with - Exceptional_Cases => (Constraint_Error => True); - pragma No_Return (Raise_Error); + procedure Raise_Error with No_Return; -- Raise constraint error with appropriate message - ------------------ - -- Local Lemmas -- - ------------------ - - procedure Inline_Le3 (X1, X2, X3, Y1, Y2, Y3 : Single_Uns) - with - Ghost, - Pre => Le3 (X1, X2, X3, Y1, Y2, Y3), - Post => Big3 (X1, X2, X3) <= Big3 (Y1, Y2, Y3); - - procedure Lemma_Abs_Commutation (X : Double_Int) - with - Ghost, - Post => abs Big (X) = Big (Double_Uns'(abs X)); - - procedure Lemma_Abs_Div_Commutation (X, Y : Big_Integer) - with - Ghost, - Pre => Y /= 0, - Post => abs (X / Y) = abs X / abs Y; - - procedure Lemma_Abs_Mult_Commutation (X, Y : Big_Integer) - with - Ghost, - Post => abs (X * Y) = abs X * abs Y; - - procedure Lemma_Abs_Range (X : Big_Integer) - with - Ghost, - Pre => In_Double_Int_Range (X), - Post => abs X <= Big_2xxDouble_Minus_1 - and then In_Double_Int_Range (-abs X); - - procedure Lemma_Abs_Rem_Commutation (X, Y : Big_Integer) - with - Ghost, - Pre => Y /= 0, - Post => abs (X rem Y) = (abs X) rem (abs Y); - - procedure Lemma_Add_Commutation (X : Double_Uns; Y : Single_Uns) - with - Ghost, - Pre => X <= 2 ** Double_Size - 2 ** Single_Size, - Post => Big (X) + Big (Double_Uns (Y)) = Big (X + Double_Uns (Y)); - - procedure Lemma_Add_One (X : Double_Uns) - with - Ghost, - Pre => X /= Double_Uns'Last, - Post => Big (X + Double_Uns'(1)) = Big (X) + 1; - - procedure Lemma_Big_Of_Double_Uns (X : Double_Uns) - with - Ghost, - Post => Big (X) < Big_2xxDouble; - - procedure Lemma_Big_Of_Double_Uns_Of_Single_Uns (X : Single_Uns) - with - Ghost, - Post => Big (Double_Uns (X)) >= 0 - and then Big (Double_Uns (X)) < Big_2xxSingle; - - procedure Lemma_Bounded_Powers_Of_2_Increasing (M, N : Natural) - with - Ghost, - Pre => M < N and then N < Double_Size, - Post => Double_Uns'(2)**M < Double_Uns'(2)**N; - - procedure Lemma_Concat_Definition (X, Y : Single_Uns) - with - Ghost, - Post => Big (X & Y) = Big_2xxSingle * Big (Double_Uns (X)) - + Big (Double_Uns (Y)); - - procedure Lemma_Deep_Mult_Commutation - (Factor : Big_Integer; - X, Y : Single_Uns) - with - Ghost, - Post => - Factor * Big (Double_Uns (X)) * Big (Double_Uns (Y)) = - Factor * Big (Double_Uns (X) * Double_Uns (Y)); - - procedure Lemma_Div_Commutation (X, Y : Double_Uns) - with - Ghost, - Pre => Y /= 0, - Post => Big (X) / Big (Y) = Big (X / Y); - - procedure Lemma_Div_Definition - (A : Double_Uns; - B : Single_Uns; - Q : Double_Uns; - R : Double_Uns) - with - Ghost, - Pre => B /= 0 and then Q = A / B and then R = A rem B, - Post => Big (A) = Big (Double_Uns (B)) * Big (Q) + Big (R); - - procedure Lemma_Div_Ge (X, Y, Z : Big_Integer) - with - Ghost, - Pre => Z > 0 and then X >= Y * Z, - Post => X / Z >= Y; - - procedure Lemma_Div_Lt (X, Y, Z : Big_Natural) - with - Ghost, - Pre => Z > 0 and then X < Y * Z, - Post => X / Z < Y; - - procedure Lemma_Div_Eq (A, B, S, R : Big_Integer) - with - Ghost, - Pre => A * S = B * S + R and then S /= 0, - Post => A = B + R / S; - - procedure Lemma_Div_Mult (X : Big_Natural; Y : Big_Positive) - with - Ghost, - Post => X / Y * Y > X - Y; - - procedure Lemma_Double_Big_2xxSingle - with - Ghost, - Post => Big_2xxSingle * Big_2xxSingle = Big_2xxDouble; - - procedure Lemma_Double_Shift (X : Double_Uns; S, S1 : Double_Uns) - with - Ghost, - Pre => S <= Double_Uns (Double_Size) - and then S1 <= Double_Uns (Double_Size), - Post => Shift_Left (Shift_Left (X, Natural (S)), Natural (S1)) = - Shift_Left (X, Natural (S + S1)); - - procedure Lemma_Double_Shift (X : Single_Uns; S, S1 : Natural) - with - Ghost, - Pre => S <= Single_Size - S1, - Post => Shift_Left (Shift_Left (X, S), S1) = Shift_Left (X, S + S1); - - procedure Lemma_Double_Shift (X : Double_Uns; S, S1 : Natural) - with - Ghost, - Pre => S <= Double_Size - S1, - Post => Shift_Left (Shift_Left (X, S), S1) = Shift_Left (X, S + S1); - - procedure Lemma_Double_Shift_Left (X : Double_Uns; S, S1 : Double_Uns) - with - Ghost, - Pre => S <= Double_Uns (Double_Size) - and then S1 <= Double_Uns (Double_Size), - Post => Shift_Left (Shift_Left (X, Natural (S)), Natural (S1)) = - Shift_Left (X, Natural (S + S1)); - - procedure Lemma_Double_Shift_Left (X : Double_Uns; S, S1 : Natural) - with - Ghost, - Pre => S <= Double_Size - S1, - Post => Shift_Left (Shift_Left (X, S), S1) = Shift_Left (X, S + S1); - - procedure Lemma_Double_Shift_Right (X : Double_Uns; S, S1 : Double_Uns) - with - Ghost, - Pre => S <= Double_Uns (Double_Size) - and then S1 <= Double_Uns (Double_Size), - Post => Shift_Right (Shift_Right (X, Natural (S)), Natural (S1)) = - Shift_Right (X, Natural (S + S1)); - - procedure Lemma_Double_Shift_Right (X : Double_Uns; S, S1 : Natural) - with - Ghost, - Pre => S <= Double_Size - S1, - Post => Shift_Right (Shift_Right (X, S), S1) = Shift_Right (X, S + S1); - - procedure Lemma_Ge_Commutation (A, B : Double_Uns) - with - Ghost, - Pre => A >= B, - Post => Big (A) >= Big (B); - - procedure Lemma_Ge_Mult (A, B, C, D : Big_Integer) - with - Ghost, - Pre => A >= B and then B * C >= D and then C > 0, - Post => A * C >= D; - - procedure Lemma_Gt_Commutation (A, B : Double_Uns) - with - Ghost, - Pre => A > B, - Post => Big (A) > Big (B); - - procedure Lemma_Gt_Mult (A, B, C, D : Big_Integer) - with - Ghost, - Pre => A >= B and then B * C > D and then C > 0, - Post => A * C > D; - - procedure Lemma_Hi_Lo (Xu : Double_Uns; Xhi, Xlo : Single_Uns) - with - Ghost, - Pre => Xhi = Hi (Xu) and Xlo = Lo (Xu), - Post => Big (Xu) = - Big_2xxSingle * Big (Double_Uns (Xhi)) + Big (Double_Uns (Xlo)); - - procedure Lemma_Hi_Lo_3 (Xu : Double_Uns; Xhi, Xlo : Single_Uns) - with - Ghost, - Pre => Xhi = Hi (Xu) and then Xlo = Lo (Xu), - Post => Big (Xu) = Big3 (0, Xhi, Xlo); - - procedure Lemma_Lo_Is_Ident (X : Double_Uns) - with - Ghost, - Pre => Big (X) < Big_2xxSingle, - Post => Double_Uns (Lo (X)) = X; - - procedure Lemma_Lt_Commutation (A, B : Double_Uns) - with - Ghost, - Pre => A < B, - Post => Big (A) < Big (B); - - procedure Lemma_Lt_Mult (A, B, C, D : Big_Integer) - with - Ghost, - Pre => A < B and then B * C <= D and then C > 0, - Post => A * C < D; - - procedure Lemma_Mult_Commutation (X, Y : Single_Uns) - with - Ghost, - Post => - Big (Double_Uns (X)) * Big (Double_Uns (Y)) = - Big (Double_Uns (X) * Double_Uns (Y)); - - procedure Lemma_Mult_Commutation (X, Y : Double_Int) - with - Ghost, - Pre => In_Double_Int_Range (Big (X) * Big (Y)), - Post => Big (X) * Big (Y) = Big (X * Y); - - procedure Lemma_Mult_Commutation (X, Y, Z : Double_Uns) - with - Ghost, - Pre => Big (X) * Big (Y) < Big_2xxDouble and then Z = X * Y, - Post => Big (X) * Big (Y) = Big (Z); - - procedure Lemma_Mult_Decomposition - (Mult : Big_Integer; - Xu, Yu : Double_Uns; - Xhi, Xlo, Yhi, Ylo : Single_Uns) - with - Ghost, - Pre => Mult = Big (Xu) * Big (Yu) - and then Xhi = Hi (Xu) - and then Xlo = Lo (Xu) - and then Yhi = Hi (Yu) - and then Ylo = Lo (Yu), - Post => Mult = - Big_2xxSingle * Big_2xxSingle * (Big (Double_Uns'(Xhi * Yhi))) - + Big_2xxSingle * (Big (Double_Uns'(Xhi * Ylo))) - + Big_2xxSingle * (Big (Double_Uns'(Xlo * Yhi))) - + (Big (Double_Uns'(Xlo * Ylo))); - - procedure Lemma_Mult_Distribution (X, Y, Z : Big_Integer) - with - Ghost, - Post => X * (Y + Z) = X * Y + X * Z; - - procedure Lemma_Mult_Div (A, B : Big_Integer) - with - Ghost, - Pre => B /= 0, - Post => A * B / B = A; - - procedure Lemma_Mult_Non_Negative (X, Y : Big_Integer) - with - Ghost, - Pre => (X >= 0 and then Y >= 0) - or else (X <= 0 and then Y <= 0), - Post => X * Y >= 0; - - procedure Lemma_Mult_Non_Positive (X, Y : Big_Integer) - with - Ghost, - Pre => (X <= Big_0 and then Y >= Big_0) - or else (X >= Big_0 and then Y <= Big_0), - Post => X * Y <= Big_0; - - procedure Lemma_Mult_Positive (X, Y : Big_Integer) - with - Ghost, - Pre => (X > Big_0 and then Y > Big_0) - or else (X < Big_0 and then Y < Big_0), - Post => X * Y > Big_0; - - procedure Lemma_Neg_Div (X, Y : Big_Integer) - with - Ghost, - Pre => Y /= 0, - Post => X / Y = (-X) / (-Y); - - procedure Lemma_Neg_Rem (X, Y : Big_Integer) - with - Ghost, - Pre => Y /= 0, - Post => X rem Y = X rem (-Y); - - procedure Lemma_Not_In_Range_Big2xx64 - with - Post => not In_Double_Int_Range (Big_2xxDouble) - and then not In_Double_Int_Range (-Big_2xxDouble); - - procedure Lemma_Powers (A : Big_Natural; B, C : Natural) - with - Ghost, - Pre => B <= Natural'Last - C, - Post => A**B * A**C = A**(B + C); - - procedure Lemma_Powers_Of_2 (M, N : Natural) - with - Ghost, - Pre => M < Double_Size - and then N < Double_Size - and then M + N <= Double_Size, - Post => - Big_2xx (M) * Big_2xx (N) = - (if M + N = Double_Size then Big_2xxDouble else Big_2xx (M + N)); - - procedure Lemma_Powers_Of_2_Commutation (M : Natural) - with - Ghost, - Subprogram_Variant => (Decreases => M), - Pre => M <= Double_Size, - Post => Big (Double_Uns'(2))**M = - (if M < Double_Size then Big_2xx (M) else Big_2xxDouble); - - procedure Lemma_Powers_Of_2_Increasing (M, N : Natural) - with - Ghost, - Subprogram_Variant => (Increases => M), - Pre => M < N, - Post => Big (Double_Uns'(2))**M < Big (Double_Uns'(2))**N; - - procedure Lemma_Rem_Abs (X, Y : Big_Integer) - with - Ghost, - Pre => Y /= 0, - Post => X rem Y = X rem (abs Y); - pragma Unreferenced (Lemma_Rem_Abs); - - procedure Lemma_Rem_Commutation (X, Y : Double_Uns) - with - Ghost, - Pre => Y /= 0, - Post => Big (X) rem Big (Y) = Big (X rem Y); - - procedure Lemma_Rem_Is_Ident (X, Y : Big_Integer) - with - Ghost, - Pre => abs X < abs Y, - Post => X rem Y = X; - pragma Unreferenced (Lemma_Rem_Is_Ident); - - procedure Lemma_Rem_Sign (X, Y : Big_Integer) - with - Ghost, - Pre => Y /= 0, - Post => Same_Sign (X rem Y, X); - pragma Unreferenced (Lemma_Rem_Sign); - - procedure Lemma_Rev_Div_Definition (A, B, Q, R : Big_Natural) - with - Ghost, - Pre => A = B * Q + R and then R < B, - Post => Q = A / B and then R = A rem B; - - procedure Lemma_Shift_Left (X : Double_Uns; Shift : Natural) - with - Ghost, - Pre => Shift < Double_Size - and then Big (X) * Big_2xx (Shift) < Big_2xxDouble, - Post => Big (Shift_Left (X, Shift)) = Big (X) * Big_2xx (Shift); - - procedure Lemma_Shift_Right (X : Double_Uns; Shift : Natural) - with - Ghost, - Pre => Shift < Double_Size, - Post => Big (Shift_Right (X, Shift)) = Big (X) / Big_2xx (Shift); - - procedure Lemma_Shift_Without_Drop - (X, Y : Double_Uns; - Mask : Single_Uns; - Shift : Natural) - with - Ghost, - Pre => (Hi (X) and Mask) = 0 -- X has the first Shift bits off - and then Shift <= Single_Size - and then Mask = Shift_Left (Single_Uns'Last, Single_Size - Shift) - and then Y = Shift_Left (X, Shift), - Post => Big (Y) = Big_2xx (Shift) * Big (X); - - procedure Lemma_Simplify (X, Y : Big_Integer) - with - Ghost, - Pre => Y /= 0, - Post => X * Y / Y = X; - - procedure Lemma_Substitution (A, B, C, C1, D : Big_Integer) - with - Ghost, - Pre => C = C1 and then A = B * C + D, - Post => A = B * C1 + D; - - procedure Lemma_Subtract_Commutation (X, Y : Double_Uns) - with - Ghost, - Pre => X >= Y, - Post => Big (X) - Big (Y) = Big (X - Y); - - procedure Lemma_Subtract_Double_Uns (X, Y : Double_Int) - with - Ghost, - Pre => X >= 0 and then X <= Y, - Post => Double_Uns (Y - X) = Double_Uns (Y) - Double_Uns (X); - - procedure Lemma_Word_Commutation (X : Single_Uns) - with - Ghost, - Post => Big_2xxSingle * Big (Double_Uns (X)) - = Big (2**Single_Size * Double_Uns (X)); - - ----------------------------- - -- Local lemma null bodies -- - ----------------------------- - - procedure Inline_Le3 (X1, X2, X3, Y1, Y2, Y3 : Single_Uns) is null; - procedure Lemma_Abs_Commutation (X : Double_Int) is null; - procedure Lemma_Abs_Mult_Commutation (X, Y : Big_Integer) is null; - procedure Lemma_Abs_Range (X : Big_Integer) is null; - procedure Lemma_Add_Commutation (X : Double_Uns; Y : Single_Uns) is null; - procedure Lemma_Add_One (X : Double_Uns) is null; - procedure Lemma_Big_Of_Double_Uns (X : Double_Uns) is null; - procedure Lemma_Big_Of_Double_Uns_Of_Single_Uns (X : Single_Uns) is null; - procedure Lemma_Bounded_Powers_Of_2_Increasing (M, N : Natural) is null; - procedure Lemma_Deep_Mult_Commutation - (Factor : Big_Integer; - X, Y : Single_Uns) - is null; - procedure Lemma_Div_Commutation (X, Y : Double_Uns) is null; - procedure Lemma_Div_Definition - (A : Double_Uns; - B : Single_Uns; - Q : Double_Uns; - R : Double_Uns) - is null; - procedure Lemma_Div_Ge (X, Y, Z : Big_Integer) is null; - procedure Lemma_Div_Lt (X, Y, Z : Big_Natural) is null; - procedure Lemma_Div_Mult (X : Big_Natural; Y : Big_Positive) is null; - procedure Lemma_Double_Big_2xxSingle is null; - procedure Lemma_Double_Shift (X : Double_Uns; S, S1 : Double_Uns) is null; - procedure Lemma_Double_Shift (X : Single_Uns; S, S1 : Natural) is null; - procedure Lemma_Double_Shift_Left (X : Double_Uns; S, S1 : Double_Uns) - is null; - procedure Lemma_Double_Shift_Right (X : Double_Uns; S, S1 : Double_Uns) - is null; - procedure Lemma_Ge_Commutation (A, B : Double_Uns) is null; - procedure Lemma_Ge_Mult (A, B, C, D : Big_Integer) is null; - procedure Lemma_Gt_Commutation (A, B : Double_Uns) is null; - procedure Lemma_Gt_Mult (A, B, C, D : Big_Integer) is null; - procedure Lemma_Lo_Is_Ident (X : Double_Uns) is null; - procedure Lemma_Lt_Commutation (A, B : Double_Uns) is null; - procedure Lemma_Lt_Mult (A, B, C, D : Big_Integer) is null; - procedure Lemma_Mult_Commutation (X, Y : Single_Uns) is null; - procedure Lemma_Mult_Commutation (X, Y : Double_Int) is null; - procedure Lemma_Mult_Commutation (X, Y, Z : Double_Uns) is null; - procedure Lemma_Mult_Distribution (X, Y, Z : Big_Integer) is null; - procedure Lemma_Mult_Non_Negative (X, Y : Big_Integer) is null; - procedure Lemma_Mult_Non_Positive (X, Y : Big_Integer) is null; - procedure Lemma_Mult_Positive (X, Y : Big_Integer) is null; - procedure Lemma_Neg_Rem (X, Y : Big_Integer) is null; - procedure Lemma_Not_In_Range_Big2xx64 is null; - procedure Lemma_Powers (A : Big_Natural; B, C : Natural) is null; - procedure Lemma_Rem_Commutation (X, Y : Double_Uns) is null; - procedure Lemma_Rem_Is_Ident (X, Y : Big_Integer) is null; - procedure Lemma_Rem_Sign (X, Y : Big_Integer) is null; - procedure Lemma_Rev_Div_Definition (A, B, Q, R : Big_Natural) is null; - procedure Lemma_Simplify (X, Y : Big_Integer) is null; - procedure Lemma_Substitution (A, B, C, C1, D : Big_Integer) is null; - procedure Lemma_Subtract_Commutation (X, Y : Double_Uns) is null; - procedure Lemma_Subtract_Double_Uns (X, Y : Double_Int) is null; - procedure Lemma_Word_Commutation (X : Single_Uns) is null; - -------------------------- -- Add_With_Ovflo_Check -- -------------------------- function Add_With_Ovflo_Check (X, Y : Double_Int) return Double_Int is R : constant Double_Int := To_Int (To_Uns (X) + To_Uns (Y)); - - -- Local lemmas - - procedure Prove_Negative_X - with - Ghost, - Pre => X < 0 and then (Y > 0 or else R < 0), - Post => R = X + Y; - - procedure Prove_Non_Negative_X - with - Ghost, - Pre => X >= 0 and then (Y < 0 or else R >= 0), - Post => R = X + Y; - - procedure Prove_Overflow_Case - with - Ghost, - Pre => - (if X >= 0 then Y >= 0 and then R < 0 - else Y <= 0 and then R >= 0), - Post => not In_Double_Int_Range (Big (X) + Big (Y)); - - ---------------------- - -- Prove_Negative_X -- - ---------------------- - - procedure Prove_Negative_X is - begin - if X = Double_Int'First then - if Y > 0 then - null; - else - pragma Assert - (To_Uns (X) + To_Uns (Y) = - 2 ** (Double_Size - 1) - Double_Uns (-Y)); - pragma Assert -- as R < 0 - (To_Uns (X) + To_Uns (Y) >= 2 ** (Double_Size - 1)); - pragma Assert (Y = 0); - end if; - - elsif Y = Double_Int'First then - pragma Assert - (To_Uns (X) + To_Uns (Y) = - 2 ** (Double_Size - 1) - Double_Uns (-X)); - pragma Assert (False); - - elsif Y <= 0 then - pragma Assert - (To_Uns (X) + To_Uns (Y) = -Double_Uns (-X) - Double_Uns (-Y)); - - else -- Y > 0, 0 > X > Double_Int'First - declare - Ru : constant Double_Uns := To_Uns (X) + To_Uns (Y); - begin - pragma Assert (Ru = -Double_Uns (-X) + Double_Uns (Y)); - if Ru < 2 ** (Double_Size - 1) then -- R >= 0 - Lemma_Subtract_Double_Uns (-X, Y); - pragma Assert (Ru = Double_Uns (X + Y)); - - elsif Ru = 2 ** (Double_Size - 1) then - pragma Assert (Double_Uns (Y) < 2 ** (Double_Size - 1)); - pragma Assert (Double_Uns (-X) < 2 ** (Double_Size - 1)); - pragma Assert (False); - - else - pragma Assert - (R = -Double_Int (-(-Double_Uns (-X) + Double_Uns (Y)))); - pragma Assert - (R = -Double_Int (-Double_Uns (Y) + Double_Uns (-X))); - end if; - end; - end if; - end Prove_Negative_X; - - -------------------------- - -- Prove_Non_Negative_X -- - -------------------------- - - procedure Prove_Non_Negative_X is - begin - if Y >= 0 or else Y = Double_Int'First then - null; - else - pragma Assert - (To_Uns (X) + To_Uns (Y) = Double_Uns (X) - Double_Uns (-Y)); - end if; - end Prove_Non_Negative_X; - - ------------------------- - -- Prove_Overflow_Case -- - ------------------------- - - procedure Prove_Overflow_Case is - begin - if X < 0 and then X /= Double_Int'First and then Y /= Double_Int'First - then - pragma Assert - (To_Uns (X) + To_Uns (Y) = -Double_Uns (-X) - Double_Uns (-Y)); - end if; - end Prove_Overflow_Case; - - -- Start of processing for Add_With_Ovflo_Check - begin if X >= 0 then if Y < 0 or else R >= 0 then - Prove_Non_Negative_X; return R; end if; else -- X < 0 if Y > 0 or else R < 0 then - Prove_Negative_X; return R; end if; end if; - Prove_Overflow_Case; Raise_Error; end Add_With_Ovflo_Check; @@ -823,8 +132,6 @@ is -- Double_Divide -- ------------------- - pragma Annotate (Gnatcheck, Exempt_On, "Metrics_Cyclomatic_Complexity", - "limit exceeded due to proof code"); procedure Double_Divide (X, Y, Z : Double_Int; Q, R : out Double_Int; @@ -844,183 +151,11 @@ is Du, Qu, Ru : Double_Uns; Den_Pos : constant Boolean := (Y < 0) = (Z < 0); - -- Local ghost variables - - Mult : constant Big_Integer := abs (Big (Y) * Big (Z)) with Ghost; - Quot : Big_Integer with Ghost; - Big_R : Big_Integer with Ghost; - Big_Q : Big_Integer with Ghost; - - -- Local lemmas - - procedure Prove_Overflow_Case - with - Ghost, - Pre => X = Double_Int'First and then Big (Y) * Big (Z) = -1, - Post => not In_Double_Int_Range (Big (X) / (Big (Y) * Big (Z))) - and then not In_Double_Int_Range - (Round_Quotient (Big (X), Big (Y) * Big (Z), - Big (X) / (Big (Y) * Big (Z)), - Big (X) rem (Big (Y) * Big (Z)))); - -- Proves the special case where -2**(Double_Size - 1) is divided by -1, - -- generating an overflow. - - procedure Prove_Quotient_Zero - with - Ghost, - Pre => Mult >= Big_2xxDouble - and then - not (Mult = Big_2xxDouble - and then X = Double_Int'First - and then Round) - and then Q = 0 - and then R = X, - Post => Big (R) = Big (X) rem (Big (Y) * Big (Z)) - and then - (if Round then - Big (Q) = Round_Quotient (Big (X), Big (Y) * Big (Z), - Big (X) / (Big (Y) * Big (Z)), - Big (R)) - else Big (Q) = Big (X) / (Big (Y) * Big (Z))); - -- Proves the general case where divisor doesn't fit in Double_Uns and - -- quotient is 0. - - procedure Prove_Round_To_One - with - Ghost, - Pre => Mult = Big_2xxDouble - and then X = Double_Int'First - and then Q = (if Den_Pos then -1 else 1) - and then R = X - and then Round, - Post => Big (R) = Big (X) rem (Big (Y) * Big (Z)) - and then Big (Q) = Round_Quotient (Big (X), Big (Y) * Big (Z), - Big (X) / (Big (Y) * Big (Z)), - Big (R)); - -- Proves the special case where the divisor doesn't fit in Double_Uns - -- but quotient is still 1 or -1 due to rounding - -- (abs (Y*Z) = 2**Double_Size and X = -2**(Double_Size - 1) and Round). - - procedure Prove_Rounding_Case - with - Ghost, - Pre => Mult /= 0 - and then Quot = Big (X) / (Big (Y) * Big (Z)) - and then Big_R = Big (X) rem (Big (Y) * Big (Z)) - and then Big_Q = - Round_Quotient (Big (X), Big (Y) * Big (Z), Quot, Big_R) - and then Big (Ru) = abs Big_R - and then Big (Du) = Mult - and then Big (Qu) = - (if Ru > (Du - Double_Uns'(1)) / Double_Uns'(2) - then abs Quot + 1 - else abs Quot), - Post => abs Big_Q = Big (Qu); - -- Proves correctness of the rounding of the unsigned quotient - - procedure Prove_Sign_Quotient - with - Ghost, - Pre => Mult /= 0 - and then Quot = Big (X) / (Big (Y) * Big (Z)) - and then Big_R = Big (X) rem (Big (Y) * Big (Z)) - and then Big_Q = - (if Round then - Round_Quotient (Big (X), Big (Y) * Big (Z), Quot, Big_R) - else Quot), - Post => - (if X >= 0 then - (if Den_Pos then Big_Q >= 0 else Big_Q <= 0) - else - (if Den_Pos then Big_Q <= 0 else Big_Q >= 0)); - -- Proves the correct sign of the signed quotient Big_Q - - procedure Prove_Signs - with - Ghost, - Pre => Mult /= 0 - and then Quot = Big (X) / (Big (Y) * Big (Z)) - and then Big_R = Big (X) rem (Big (Y) * Big (Z)) - and then Big_Q = - (if Round then - Round_Quotient (Big (X), Big (Y) * Big (Z), Quot, Big_R) - else Quot) - and then Big (Ru) = abs Big_R - and then Big (Qu) = abs Big_Q - and then R = (if X >= 0 then To_Int (Ru) else To_Int (-Ru)) - and then - Q = (if (X >= 0) = Den_Pos then To_Int (Qu) else To_Int (-Qu)) - and then not (X = Double_Int'First and then Big (Y) * Big (Z) = -1), - Post => Big (R) = Big (X) rem (Big (Y) * Big (Z)) - and then - (if Round then - Big (Q) = Round_Quotient (Big (X), Big (Y) * Big (Z), - Big (X) / (Big (Y) * Big (Z)), - Big (R)) - else Big (Q) = Big (X) / (Big (Y) * Big (Z))); - -- Proves final signs match the intended result after the unsigned - -- division is done. - - ----------------------------- - -- Local lemma null bodies -- - ----------------------------- - - procedure Prove_Overflow_Case is null; - procedure Prove_Quotient_Zero is null; - procedure Prove_Round_To_One is null; - procedure Prove_Sign_Quotient is null; - - ------------------------- - -- Prove_Rounding_Case -- - ------------------------- - - procedure Prove_Rounding_Case is - begin - if Same_Sign (Big (X), Big (Y) * Big (Z)) then - pragma Assert (abs Big_Q = Big (Qu)); - end if; - end Prove_Rounding_Case; - - ----------------- - -- Prove_Signs -- - ----------------- - - procedure Prove_Signs is - begin - if (X >= 0) = Den_Pos then - pragma Assert (Quot >= 0); - pragma Assert (Big_Q >= 0); - pragma Assert (Q >= 0); - pragma Assert (Big (Q) = Big_Q); - else - pragma Assert ((X >= 0) /= (Big (Y) * Big (Z) >= 0)); - pragma Assert (Quot <= 0); - pragma Assert (Big_Q <= 0); - pragma Assert (if X >= 0 then R >= 0); - pragma Assert (if X < 0 then R <= 0); - pragma Assert (Big (R) = Big_R); - end if; - end Prove_Signs; - - -- Start of processing for Double_Divide - begin if Yu = 0 or else Zu = 0 then Raise_Error; end if; - pragma Assert (Mult /= 0); - pragma Assert (Den_Pos = (Big (Y) * Big (Z) > 0)); - Quot := Big (X) / (Big (Y) * Big (Z)); - Big_R := Big (X) rem (Big (Y) * Big (Z)); - if Round then - Big_Q := Round_Quotient (Big (X), Big (Y) * Big (Z), Quot, Big_R); - else - Big_Q := Quot; - end if; - Lemma_Abs_Mult_Commutation (Big (Y), Big (Z)); - Lemma_Mult_Decomposition (Mult, Yu, Zu, Yhi, Ylo, Zhi, Zlo); - -- Compute Y * Z. Note that if the result overflows Double_Uns, then -- the rounded result is zero, except for the very special case where -- X = -2 ** (Double_Size - 1) and abs (Y * Z) = 2 ** Double_Size, when @@ -1040,66 +175,21 @@ is and then Round then Q := (if Den_Pos then -1 else 1); - - Prove_Round_To_One; - else Q := 0; - - pragma Assert (Double_Uns'(Yhi * Zhi) >= Double_Uns (Yhi)); - pragma Assert (Double_Uns'(Yhi * Zhi) >= Double_Uns (Zhi)); - pragma Assert (Big (Double_Uns'(Yhi * Zhi)) >= 1); - if Yhi > 1 or else Zhi > 1 then - pragma Assert (Big (Double_Uns'(Yhi * Zhi)) > 1); - pragma Assert (if X = Double_Int'First and then Round then - Mult > Big_2xxDouble); - elsif Zlo > 0 then - pragma Assert (Big (Double_Uns'(Yhi * Zlo)) > 0); - pragma Assert (if X = Double_Int'First and then Round then - Mult > Big_2xxDouble); - elsif Ylo > 0 then - pragma Assert (Double_Uns'(Ylo * Zhi) > 0); - pragma Assert (Big (Double_Uns'(Ylo * Zhi)) > 0); - pragma Assert (if X = Double_Int'First and then Round then - Mult > Big_2xxDouble); - else - pragma Assert (not (X = Double_Int'First and then Round)); - end if; - Prove_Quotient_Zero; end if; return; else T2 := Yhi * Zlo; - pragma Assert (Big (T2) = Big (Double_Uns'(Yhi * Zlo))); - pragma Assert (Big_0 = Big (Double_Uns'(Ylo * Zhi))); end if; - else T2 := Ylo * Zhi; - pragma Assert (Big (T2) = Big (Double_Uns'(Ylo * Zhi))); - pragma Assert (Big_0 = Big (Double_Uns'(Yhi * Zlo))); end if; T1 := Ylo * Zlo; - - Lemma_Mult_Distribution (Big_2xxSingle, - Big (Double_Uns'(Yhi * Zlo)), - Big (Double_Uns'(Ylo * Zhi))); - Lemma_Hi_Lo (T1, Hi (T1), Lo (T1)); - Lemma_Mult_Distribution (Big_2xxSingle, - Big (T2), - Big (Double_Uns (Hi (T1)))); - Lemma_Add_Commutation (T2, Hi (T1)); - T2 := T2 + Hi (T1); - Lemma_Hi_Lo (T2, Hi (T2), Lo (T2)); - Lemma_Mult_Distribution (Big_2xxSingle, - Big (Double_Uns (Hi (T2))), - Big (Double_Uns (Lo (T2)))); - Lemma_Double_Big_2xxSingle; - if Hi (T2) /= 0 then R := X; @@ -1112,41 +202,8 @@ is and then Round then Q := (if Den_Pos then -1 else 1); - - Prove_Round_To_One; - else Q := 0; - - pragma Assert (Big (Double_Uns (Hi (T2))) >= 1); - pragma Assert (Big (Double_Uns (Lo (T2))) >= 0); - pragma Assert (Big (Double_Uns (Lo (T1))) >= 0); - pragma Assert (Big_2xxSingle * Big (Double_Uns (Lo (T2))) - + Big (Double_Uns (Lo (T1))) >= 0); - pragma Assert (Mult >= Big_2xxDouble * Big (Double_Uns (Hi (T2)))); - pragma Assert (Mult >= Big_2xxDouble); - if Hi (T2) > 1 then - pragma Assert (Big (Double_Uns (Hi (T2))) > 1); - pragma Assert (if X = Double_Int'First and then Round then - Mult > Big_2xxDouble); - elsif Lo (T2) > 0 then - pragma Assert (Big (Double_Uns (Lo (T2))) > 0); - pragma Assert (Big_2xxSingle > 0); - pragma Assert (Big_2xxSingle * Big (Double_Uns (Lo (T2))) > 0); - pragma Assert (Big_2xxSingle * Big (Double_Uns (Lo (T2))) - + Big (Double_Uns (Lo (T1))) > 0); - pragma Assert (if X = Double_Int'First and then Round then - Mult > Big_2xxDouble); - elsif Lo (T1) > 0 then - pragma Assert (Double_Uns (Lo (T1)) > 0); - Lemma_Gt_Commutation (Double_Uns (Lo (T1)), 0); - pragma Assert (Big (Double_Uns (Lo (T1))) > 0); - pragma Assert (if X = Double_Int'First and then Round then - Mult > Big_2xxDouble); - else - pragma Assert (not (X = Double_Int'First and then Round)); - end if; - Prove_Quotient_Zero; end if; return; @@ -1154,22 +211,9 @@ is Du := Lo (T2) & Lo (T1); - Lemma_Hi_Lo (Du, Lo (T2), Lo (T1)); - pragma Assert (Mult = Big (Du)); - pragma Assert (Du /= 0); - -- Multiplication of 2-limb arguments Yu and Zu leads to 4-limb result - -- (where each limb is a single value). Cases where 4 limbs are needed - -- require Yhi /= 0 and Zhi /= 0 and lead to early exit. Remaining cases - -- where 3 limbs are needed correspond to Hi(T2) /= 0 and lead to early - -- exit. Thus, at this point, the result fits in 2 limbs which are - -- exactly Lo (T2) and Lo (T1), which corresponds to the value of Du. - -- As the case where one of Yu or Zu is null also led to early exit, - -- we have Du /= 0 here. - -- Check overflow case of largest negative number divided by -1 if X = Double_Int'First and then Du = 1 and then not Den_Pos then - Prove_Overflow_Case; Raise_Error; end if; @@ -1188,29 +232,14 @@ is Qu := Xu / Du; Ru := Xu rem Du; - Lemma_Div_Commutation (Xu, Du); - Lemma_Abs_Div_Commutation (Big (X), Big (Y) * Big (Z)); - Lemma_Abs_Commutation (X); - pragma Assert (abs Quot = Big (Qu)); - Lemma_Rem_Commutation (Xu, Du); - Lemma_Abs_Rem_Commutation (Big (X), Big (Y) * Big (Z)); - pragma Assert (abs Big_R = Big (Ru)); - -- Deal with rounding case if Round then if Ru > (Du - Double_Uns'(1)) / Double_Uns'(2) then - Lemma_Add_Commutation (Qu, 1); - Qu := Qu + Double_Uns'(1); end if; - - Prove_Rounding_Case; end if; - pragma Assert (abs Big_Q = Big (Qu)); - Prove_Sign_Quotient; - -- Set final signs (RM 4.5.5(27-30)) -- Case of dividend (X) sign positive @@ -1229,10 +258,7 @@ is R := To_Int (-Ru); Q := (if Den_Pos then To_Int (-Qu) else To_Int (Qu)); end if; - - Prove_Signs; end Double_Divide; - pragma Annotate (Gnatcheck, Exempt_Off, "Metrics_Cyclomatic_Complexity"); --------- -- Le3 -- @@ -1254,418 +280,6 @@ is end Le3; ------------------------------- - -- Lemma_Abs_Div_Commutation -- - ------------------------------- - - procedure Lemma_Abs_Div_Commutation (X, Y : Big_Integer) is - begin - if Y < 0 then - if X < 0 then - pragma Assert (abs (X / Y) = abs (X / (-Y))); - else - Lemma_Neg_Div (X, Y); - pragma Assert (abs (X / Y) = abs ((-X) / (-Y))); - end if; - end if; - end Lemma_Abs_Div_Commutation; - - ------------------------------- - -- Lemma_Abs_Rem_Commutation -- - ------------------------------- - - procedure Lemma_Abs_Rem_Commutation (X, Y : Big_Integer) is - begin - if Y < 0 then - Lemma_Neg_Rem (X, Y); - if X < 0 then - pragma Assert (X rem Y = -((-X) rem (-Y))); - pragma Assert (abs (X rem Y) = (abs X) rem (abs Y)); - else - pragma Assert (abs (X rem Y) = (abs X) rem (abs Y)); - end if; - end if; - end Lemma_Abs_Rem_Commutation; - - ----------------------------- - -- Lemma_Concat_Definition -- - ----------------------------- - - procedure Lemma_Concat_Definition (X, Y : Single_Uns) is - Hi : constant Double_Uns := Shift_Left (Double_Uns (X), Single_Size); - Lo : constant Double_Uns := Double_Uns (Y); - begin - pragma Assert (Hi = Double_Uns'(2 ** Single_Size) * Double_Uns (X)); - pragma Assert ((Hi or Lo) = Hi + Lo); - end Lemma_Concat_Definition; - - ------------------ - -- Lemma_Div_Eq -- - ------------------ - - procedure Lemma_Div_Eq (A, B, S, R : Big_Integer) is - begin - pragma Assert ((A - B) * S = R); - pragma Assert ((A - B) * S / S = R / S); - Lemma_Mult_Div (A - B, S); - pragma Assert (A - B = R / S); - end Lemma_Div_Eq; - - ------------------------ - -- Lemma_Double_Shift -- - ------------------------ - - procedure Lemma_Double_Shift (X : Double_Uns; S, S1 : Natural) is - begin - Lemma_Double_Shift (X, Double_Uns (S), Double_Uns (S1)); - pragma Assert (Shift_Left (Shift_Left (X, S), S1) - = Shift_Left (Shift_Left (X, S), Natural (Double_Uns (S1)))); - pragma Assert (Shift_Left (X, S + S1) - = Shift_Left (X, Natural (Double_Uns (S + S1)))); - end Lemma_Double_Shift; - - ----------------------------- - -- Lemma_Double_Shift_Left -- - ----------------------------- - - procedure Lemma_Double_Shift_Left (X : Double_Uns; S, S1 : Natural) is - begin - Lemma_Double_Shift_Left (X, Double_Uns (S), Double_Uns (S1)); - pragma Assert (Shift_Left (Shift_Left (X, S), S1) - = Shift_Left (Shift_Left (X, S), Natural (Double_Uns (S1)))); - pragma Assert (Shift_Left (X, S + S1) - = Shift_Left (X, Natural (Double_Uns (S + S1)))); - end Lemma_Double_Shift_Left; - - ------------------------------ - -- Lemma_Double_Shift_Right -- - ------------------------------ - - procedure Lemma_Double_Shift_Right (X : Double_Uns; S, S1 : Natural) is - begin - Lemma_Double_Shift_Right (X, Double_Uns (S), Double_Uns (S1)); - pragma Assert (Shift_Right (Shift_Right (X, S), S1) - = Shift_Right (Shift_Right (X, S), Natural (Double_Uns (S1)))); - pragma Assert (Shift_Right (X, S + S1) - = Shift_Right (X, Natural (Double_Uns (S + S1)))); - end Lemma_Double_Shift_Right; - - ----------------- - -- Lemma_Hi_Lo -- - ----------------- - - procedure Lemma_Hi_Lo (Xu : Double_Uns; Xhi, Xlo : Single_Uns) is - begin - pragma Assert (Double_Uns (Xhi) = Xu / Double_Uns'(2 ** Single_Size)); - pragma Assert (Double_Uns (Xlo) = Xu mod 2 ** Single_Size); - end Lemma_Hi_Lo; - - ------------------- - -- Lemma_Hi_Lo_3 -- - ------------------- - - procedure Lemma_Hi_Lo_3 (Xu : Double_Uns; Xhi, Xlo : Single_Uns) is - begin - Lemma_Hi_Lo (Xu, Xhi, Xlo); - end Lemma_Hi_Lo_3; - - ------------------------------ - -- Lemma_Mult_Decomposition -- - ------------------------------ - - procedure Lemma_Mult_Decomposition - (Mult : Big_Integer; - Xu, Yu : Double_Uns; - Xhi, Xlo, Yhi, Ylo : Single_Uns) - is - begin - Lemma_Hi_Lo (Xu, Xhi, Xlo); - Lemma_Hi_Lo (Yu, Yhi, Ylo); - - pragma Assert - (Mult = - (Big_2xxSingle * Big (Double_Uns (Xhi)) + Big (Double_Uns (Xlo))) * - (Big_2xxSingle * Big (Double_Uns (Yhi)) + Big (Double_Uns (Ylo)))); - pragma Assert (Mult = - Big_2xxSingle - * Big_2xxSingle * Big (Double_Uns (Xhi)) * Big (Double_Uns (Yhi)) - + Big_2xxSingle * Big (Double_Uns (Xhi)) * Big (Double_Uns (Ylo)) - + Big_2xxSingle * Big (Double_Uns (Xlo)) * Big (Double_Uns (Yhi)) - + Big (Double_Uns (Xlo)) * Big (Double_Uns (Ylo))); - Lemma_Deep_Mult_Commutation (Big_2xxSingle * Big_2xxSingle, Xhi, Yhi); - Lemma_Deep_Mult_Commutation (Big_2xxSingle, Xhi, Ylo); - Lemma_Deep_Mult_Commutation (Big_2xxSingle, Xlo, Yhi); - Lemma_Mult_Commutation (Xlo, Ylo); - pragma Assert (Mult = - Big_2xxSingle * Big_2xxSingle * Big (Double_Uns'(Xhi * Yhi)) - + Big_2xxSingle * Big (Double_Uns'(Xhi * Ylo)) - + Big_2xxSingle * Big (Double_Uns'(Xlo * Yhi)) - + Big (Double_Uns'(Xlo * Ylo))); - end Lemma_Mult_Decomposition; - - -------------------- - -- Lemma_Mult_Div -- - -------------------- - - procedure Lemma_Mult_Div (A, B : Big_Integer) is - begin - if B > 0 then - pragma Assert (A * B / B = A); - else - pragma Assert (A * (-B) / (-B) = A); - end if; - end Lemma_Mult_Div; - - ------------------- - -- Lemma_Neg_Div -- - ------------------- - - procedure Lemma_Neg_Div (X, Y : Big_Integer) is - begin - pragma Assert ((-X) / (-Y) = -(X / (-Y))); - pragma Assert (X / (-Y) = -(X / Y)); - end Lemma_Neg_Div; - - ----------------------- - -- Lemma_Powers_Of_2 -- - ----------------------- - - procedure Lemma_Powers_Of_2 (M, N : Natural) is - begin - if M + N < Double_Size then - pragma Assert (Double_Uns'(2**M) * Double_Uns'(2**N) - = Double_Uns'(2**(M + N))); - end if; - - Lemma_Powers_Of_2_Commutation (M); - Lemma_Powers_Of_2_Commutation (N); - Lemma_Powers_Of_2_Commutation (M + N); - Lemma_Powers (Big (Double_Uns'(2)), M, N); - - if M + N < Double_Size then - pragma Assert (Big (Double_Uns'(2))**M * Big (Double_Uns'(2))**N - = Big (Double_Uns'(2))**(M + N)); - Lemma_Powers_Of_2_Increasing (M + N, Double_Size); - Lemma_Mult_Commutation (2 ** M, 2 ** N, 2 ** (M + N)); - else - pragma Assert (Big (Double_Uns'(2))**M * Big (Double_Uns'(2))**N - = Big (Double_Uns'(2))**(M + N)); - end if; - end Lemma_Powers_Of_2; - - ----------------------------------- - -- Lemma_Powers_Of_2_Commutation -- - ----------------------------------- - - procedure Lemma_Powers_Of_2_Commutation (M : Natural) is - begin - if M > 0 then - Lemma_Powers_Of_2_Commutation (M - 1); - pragma Assert (Big (Double_Uns'(2))**(M - 1) = Big_2xx (M - 1)); - pragma Assert (Big (Double_Uns'(2))**M = Big_2xx (M - 1) * 2); - if M < Double_Size then - Lemma_Powers_Of_2_Increasing (M - 1, Double_Size - 1); - Lemma_Bounded_Powers_Of_2_Increasing (M - 1, Double_Size - 1); - pragma Assert (Double_Uns'(2 ** (M - 1)) * 2 = Double_Uns'(2**M)); - Lemma_Mult_Commutation - (Double_Uns'(2 ** (M - 1)), 2, Double_Uns'(2**M)); - pragma Assert (Big (Double_Uns'(2))**M = Big_2xx (M)); - end if; - else - pragma Assert (Big (Double_Uns'(2))**M = Big_2xx (M)); - end if; - end Lemma_Powers_Of_2_Commutation; - - ---------------------------------- - -- Lemma_Powers_Of_2_Increasing -- - ---------------------------------- - - procedure Lemma_Powers_Of_2_Increasing (M, N : Natural) is - begin - if M + 1 < N then - Lemma_Powers_Of_2_Increasing (M + 1, N); - end if; - end Lemma_Powers_Of_2_Increasing; - - ------------------- - -- Lemma_Rem_Abs -- - ------------------- - - procedure Lemma_Rem_Abs (X, Y : Big_Integer) is - begin - Lemma_Neg_Rem (X, Y); - end Lemma_Rem_Abs; - - ---------------------- - -- Lemma_Shift_Left -- - ---------------------- - - procedure Lemma_Shift_Left (X : Double_Uns; Shift : Natural) is - - procedure Lemma_Mult_Pow2 (X : Double_Uns; I : Natural) - with - Ghost, - Pre => I < Double_Size - 1, - Post => X * Double_Uns'(2) ** I * Double_Uns'(2) - = X * Double_Uns'(2) ** (I + 1); - - procedure Lemma_Mult_Pow2 (X : Double_Uns; I : Natural) is - Mul1 : constant Double_Uns := Double_Uns'(2) ** I; - Mul2 : constant Double_Uns := Double_Uns'(2); - Left : constant Double_Uns := X * Mul1 * Mul2; - begin - pragma Assert (Left = X * (Mul1 * Mul2)); - pragma Assert (Mul1 * Mul2 = Double_Uns'(2) ** (I + 1)); - end Lemma_Mult_Pow2; - - XX : Double_Uns := X; - - begin - for J in 1 .. Shift loop - declare - Cur_XX : constant Double_Uns := XX; - begin - XX := Shift_Left (XX, 1); - pragma Assert (XX = Cur_XX * Double_Uns'(2)); - Lemma_Mult_Pow2 (X, J - 1); - end; - Lemma_Double_Shift_Left (X, J - 1, 1); - pragma Loop_Invariant (XX = Shift_Left (X, J)); - pragma Loop_Invariant (XX = X * Double_Uns'(2) ** J); - end loop; - end Lemma_Shift_Left; - - ----------------------- - -- Lemma_Shift_Right -- - ----------------------- - - procedure Lemma_Shift_Right (X : Double_Uns; Shift : Natural) is - - procedure Lemma_Div_Pow2 (X : Double_Uns; I : Natural) - with - Ghost, - Pre => I < Double_Size - 1, - Post => X / Double_Uns'(2) ** I / Double_Uns'(2) - = X / Double_Uns'(2) ** (I + 1); - - procedure Lemma_Quot_Rem (X, Div, Q, R : Double_Uns) - with - Ghost, - Pre => Div /= 0 - and then X = Q * Div + R - and then Q <= Double_Uns'Last / Div - and then R <= Double_Uns'Last - Q * Div - and then R < Div, - Post => Q = X / Div; - pragma Annotate (GNATprove, False_Positive, "postcondition might fail", - "Q is the quotient of X by Div"); - - procedure Lemma_Div_Pow2 (X : Double_Uns; I : Natural) is - - -- Local lemmas - - procedure Lemma_Mult_Le (X, Y, Z : Double_Uns) - with - Ghost, - Pre => X <= 1, - Post => X * Z <= Z; - - procedure Lemma_Mult_Le (X, Y, Z : Double_Uns) is null; - - -- Local variables - - Div1 : constant Double_Uns := Double_Uns'(2) ** I; - Div2 : constant Double_Uns := Double_Uns'(2); - Left : constant Double_Uns := X / Div1 / Div2; - R2 : constant Double_Uns := X / Div1 - Left * Div2; - pragma Assert (R2 <= Div2 - 1); - R1 : constant Double_Uns := X - X / Div1 * Div1; - pragma Assert (R1 < Div1); - - -- Start of processing for Lemma_Div_Pow2 - - begin - pragma Assert (X = Left * (Div1 * Div2) + R2 * Div1 + R1); - Lemma_Mult_Le (R2, Div2 - 1, Div1); - pragma Assert (R2 * Div1 + R1 < Div1 * Div2); - Lemma_Quot_Rem (X, Div1 * Div2, Left, R2 * Div1 + R1); - pragma Assert (Left = X / (Div1 * Div2)); - pragma Assert (Div1 * Div2 = Double_Uns'(2) ** (I + 1)); - end Lemma_Div_Pow2; - - procedure Lemma_Quot_Rem (X, Div, Q, R : Double_Uns) is null; - - XX : Double_Uns := X; - - begin - for J in 1 .. Shift loop - declare - Cur_XX : constant Double_Uns := XX; - begin - XX := Shift_Right (XX, 1); - pragma Assert (XX = Cur_XX / Double_Uns'(2)); - Lemma_Div_Pow2 (X, J - 1); - end; - Lemma_Double_Shift_Right (X, J - 1, 1); - pragma Loop_Invariant (XX = Shift_Right (X, J)); - pragma Loop_Invariant (XX = X / Double_Uns'(2) ** J); - end loop; - Lemma_Div_Commutation (X, Double_Uns'(2) ** Shift); - end Lemma_Shift_Right; - - ------------------------------ - -- Lemma_Shift_Without_Drop -- - ------------------------------ - - procedure Lemma_Shift_Without_Drop - (X, Y : Double_Uns; - Mask : Single_Uns; - Shift : Natural) - is - pragma Unreferenced (Mask); - - procedure Lemma_Bound - with - Pre => Shift <= Single_Size - and then X <= 2**Single_Size - * Double_Uns'(2**(Single_Size - Shift) - 1) - + Single_Uns'(2**Single_Size - 1), - Post => X <= 2**(Double_Size - Shift) - 1; - - procedure Lemma_Exp_Pos (N : Integer) - with - Pre => N in 0 .. Double_Size - 1, - Post => Double_Uns'(2**N) > 0; - - ----------------------------- - -- Local lemma null bodies -- - ----------------------------- - - procedure Lemma_Bound is null; - procedure Lemma_Exp_Pos (N : Integer) is null; - - -- Start of processing for Lemma_Shift_Without_Drop - - begin - if Shift = 0 then - pragma Assert (Big (Y) = Big_2xx (Shift) * Big (X)); - return; - end if; - - Lemma_Bound; - Lemma_Exp_Pos (Double_Size - Shift); - pragma Assert (X < 2**(Double_Size - Shift)); - pragma Assert (Big (X) < Big_2xx (Double_Size - Shift)); - pragma Assert (Y = 2**Shift * X); - Lemma_Lt_Mult (Big (X), Big_2xx (Double_Size - Shift), Big_2xx (Shift), - Big_2xx (Shift) * Big_2xx (Double_Size - Shift)); - pragma Assert (Big_2xx (Shift) * Big (X) - < Big_2xx (Shift) * Big_2xx (Double_Size - Shift)); - Lemma_Powers_Of_2 (Shift, Double_Size - Shift); - Lemma_Mult_Commutation (2**Shift, X, Y); - pragma Assert (Big (Y) = Big_2xx (Shift) * Big (X)); - end Lemma_Shift_Without_Drop; - - ------------------------------- -- Multiply_With_Ovflo_Check -- ------------------------------- @@ -1680,160 +294,16 @@ is T1, T2 : Double_Uns; - -- Local ghost variables - - Mult : constant Big_Integer := abs (Big (X) * Big (Y)) with Ghost; - - -- Local lemmas - - procedure Prove_Both_Too_Large - with - Ghost, - Pre => Xhi /= 0 - and then Yhi /= 0 - and then Mult = - Big_2xxSingle * Big_2xxSingle * (Big (Double_Uns'(Xhi * Yhi))) - + Big_2xxSingle * (Big (Double_Uns'(Xhi * Ylo))) - + Big_2xxSingle * (Big (Double_Uns'(Xlo * Yhi))) - + (Big (Double_Uns'(Xlo * Ylo))), - Post => not In_Double_Int_Range (Big (X) * Big (Y)); - - procedure Prove_Final_Decomposition - with - Ghost, - Pre => In_Double_Int_Range (Big (X) * Big (Y)) - and then Mult = Big_2xxSingle * Big (T2) + Big (Double_Uns (Lo (T1))) - and then Hi (T2) = 0, - Post => Mult = Big (Lo (T2) & Lo (T1)); - - procedure Prove_Neg_Int - with - Ghost, - Pre => In_Double_Int_Range (Big (X) * Big (Y)) - and then Mult = Big (T2) - and then ((X >= 0 and then Y < 0) or else (X < 0 and then Y >= 0)), - Post => To_Neg_Int (T2) = X * Y; - - procedure Prove_Pos_Int - with - Ghost, - Pre => In_Double_Int_Range (Big (X) * Big (Y)) - and then Mult = Big (T2) - and then ((X >= 0 and then Y >= 0) or else (X < 0 and then Y < 0)), - Post => In_Double_Int_Range (Big (T2)) - and then To_Pos_Int (T2) = X * Y; - - procedure Prove_Result_Too_Large - with - Ghost, - Pre => Mult = Big_2xxSingle * Big (T2) + Big (Double_Uns (Lo (T1))) - and then Hi (T2) /= 0, - Post => not In_Double_Int_Range (Big (X) * Big (Y)); - - procedure Prove_Too_Large - with - Ghost, - Pre => abs (Big (X) * Big (Y)) >= Big_2xxDouble, - Post => not In_Double_Int_Range (Big (X) * Big (Y)); - - -------------------------- - -- Prove_Both_Too_Large -- - -------------------------- - - procedure Prove_Both_Too_Large is - begin - pragma Assert (Mult >= - Big_2xxSingle * Big_2xxSingle * Big (Double_Uns'(Xhi * Yhi))); - pragma Assert (Double_Uns (Xhi) * Double_Uns (Yhi) >= 1); - pragma Assert (Mult >= Big_2xxSingle * Big_2xxSingle); - Prove_Too_Large; - end Prove_Both_Too_Large; - - ------------------------------- - -- Prove_Final_Decomposition -- - ------------------------------- - - procedure Prove_Final_Decomposition is - begin - Lemma_Hi_Lo (T2, Hi (T2), Lo (T2)); - pragma Assert (Mult = Big_2xxSingle * Big (Double_Uns (Lo (T2))) - + Big (Double_Uns (Lo (T1)))); - pragma Assert (Mult <= Big_2xxDouble_Minus_1); - Lemma_Mult_Commutation (X, Y); - pragma Assert (Mult = abs Big (X * Y)); - Lemma_Word_Commutation (Lo (T2)); - pragma Assert (Mult = Big (Double_Uns'(2 ** Single_Size) - * Double_Uns (Lo (T2))) - + Big (Double_Uns (Lo (T1)))); - Lemma_Add_Commutation (Double_Uns'(2 ** Single_Size) - * Double_Uns (Lo (T2)), - Lo (T1)); - pragma Assert (Mult = Big (Double_Uns'(2 ** Single_Size) - * Double_Uns (Lo (T2)) + Lo (T1))); - pragma Assert (Lo (T2) & Lo (T1) = Double_Uns'(2 ** Single_Size) - * Double_Uns (Lo (T2)) + Lo (T1)); - end Prove_Final_Decomposition; - - ------------------- - -- Prove_Neg_Int -- - ------------------- - - procedure Prove_Neg_Int is - begin - pragma Assert (X * Y <= 0); - pragma Assert (Mult = -Big (X * Y)); - end Prove_Neg_Int; - - ------------------- - -- Prove_Pos_Int -- - ------------------- - - procedure Prove_Pos_Int is - begin - pragma Assert (X * Y >= 0); - pragma Assert (Mult = Big (X * Y)); - end Prove_Pos_Int; - - ---------------------------- - -- Prove_Result_Too_Large -- - ---------------------------- - - procedure Prove_Result_Too_Large is - begin - pragma Assert (Mult >= Big_2xxSingle * Big (T2)); - Lemma_Hi_Lo (T2, Hi (T2), Lo (T2)); - pragma Assert (Mult >= - Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (Hi (T2)))); - pragma Assert (Double_Uns (Hi (T2)) >= 1); - pragma Assert (Mult >= Big_2xxSingle * Big_2xxSingle); - Prove_Too_Large; - end Prove_Result_Too_Large; - - --------------------- - -- Prove_Too_Large -- - --------------------- - - procedure Prove_Too_Large is null; - - -- Start of processing for Multiply_With_Ovflo_Check - begin - Lemma_Mult_Decomposition (Mult, Xu, Yu, Xhi, Xlo, Yhi, Ylo); - if Xhi /= 0 then if Yhi /= 0 then - Prove_Both_Too_Large; Raise_Error; else T2 := Xhi * Ylo; - pragma Assert (Big (T2) = Big (Double_Uns'(Xhi * Ylo)) - + Big (Double_Uns'(Xlo * Yhi))); end if; elsif Yhi /= 0 then T2 := Xlo * Yhi; - pragma Assert (Big (T2) = Big (Double_Uns'(Xhi * Ylo)) - + Big (Double_Uns'(Xlo * Yhi))); else -- Yhi = Xhi = 0 T2 := 0; @@ -1843,57 +313,27 @@ is -- result from the upper halves of the input values. T1 := Xlo * Ylo; - - pragma Assert (Big (T2) = Big (Double_Uns'(Xhi * Ylo)) - + Big (Double_Uns'(Xlo * Yhi))); - Lemma_Mult_Distribution (Big_2xxSingle, Big (Double_Uns'(Xhi * Ylo)), - Big (Double_Uns'(Xlo * Yhi))); - pragma Assert (Mult = Big_2xxSingle * Big (T2) + Big (T1)); - Lemma_Add_Commutation (T2, Hi (T1)); - pragma Assert - (Big (T2 + Hi (T1)) = Big (T2) + Big (Double_Uns (Hi (T1)))); - T2 := T2 + Hi (T1); - Lemma_Hi_Lo (T1, Hi (T1), Lo (T1)); - pragma Assert - (Mult = Big_2xxSingle * Big (T2) + Big (Double_Uns (Lo (T1)))); - if Hi (T2) /= 0 then - Prove_Result_Too_Large; Raise_Error; end if; - Prove_Final_Decomposition; - T2 := Lo (T2) & Lo (T1); - pragma Assert (Mult = Big (T2)); - if X >= 0 then if Y >= 0 then - Prove_Pos_Int; return To_Pos_Int (T2); - pragma Annotate (CodePeer, Intentional, "precondition", - "Intentional Unsigned->Signed conversion"); else - Prove_Neg_Int; - Lemma_Abs_Range (Big (X) * Big (Y)); return To_Neg_Int (T2); end if; else -- X < 0 if Y < 0 then - Prove_Pos_Int; return To_Pos_Int (T2); - pragma Annotate (CodePeer, Intentional, "precondition", - "Intentional Unsigned->Signed conversion"); else - Prove_Neg_Int; - Lemma_Abs_Range (Big (X) * Big (Y)); return To_Neg_Int (T2); end if; end if; - end Multiply_With_Ovflo_Check; ----------------- @@ -1909,8 +349,6 @@ is -- Scaled_Divide -- ------------------- - pragma Annotate (Gnatcheck, Exempt_On, "Metrics_Cyclomatic_Complexity", - "limit exceeded due to proof code"); procedure Scaled_Divide (X, Y, Z : Double_Int; Q, R : out Double_Int; @@ -1928,10 +366,10 @@ is Zhi : Single_Uns := Hi (Zu); Zlo : Single_Uns := Lo (Zu); - D : array (1 .. 4) of Single_Uns with Relaxed_Initialization; + D : array (1 .. 4) of Single_Uns; -- The dividend, four digits (D(1) is high order) - Qd : array (1 .. 2) of Single_Uns with Relaxed_Initialization; + Qd : array (1 .. 2) of Single_Uns; -- The quotient digits, two digits (Qd(1) is high order) S1, S2, S3 : Single_Uns; @@ -1956,605 +394,6 @@ is T1, T2, T3 : Double_Uns; -- Temporary values - -- Local ghost variables - - Mult : constant Big_Natural := abs (Big (X) * Big (Y)) with Ghost; - Quot : Big_Integer with Ghost; - Big_R : Big_Integer with Ghost; - Big_Q : Big_Integer with Ghost; - Inter : Natural with Ghost; - - -- Local ghost functions - - function Is_Mult_Decomposition - (D1, D2, D3, D4 : Big_Integer) - return Boolean - is - (Mult = Big_2xxSingle * Big_2xxSingle * Big_2xxSingle * D1 - + Big_2xxSingle * Big_2xxSingle * D2 - + Big_2xxSingle * D3 - + D4) - with - Ghost, - Annotate => (GNATprove, Inline_For_Proof); - - function Is_Scaled_Mult_Decomposition - (D1, D2, D3, D4 : Big_Integer) - return Boolean - is - (Mult * Big_2xx (Scale) - = Big_2xxSingle * Big_2xxSingle * Big_2xxSingle * D1 - + Big_2xxSingle * Big_2xxSingle * D2 - + Big_2xxSingle * D3 - + D4) - with - Ghost, - Annotate => (GNATprove, Inline_For_Proof), - Pre => Scale < Double_Size; - - -- Local lemmas - - procedure Prove_Dividend_Scaling - with - Ghost, - Pre => D'Initialized - and then Scale <= Single_Size - and then Is_Mult_Decomposition (Big (Double_Uns (D (1))), - Big (Double_Uns (D (2))), - Big (Double_Uns (D (3))), - Big (Double_Uns (D (4)))) - and then Big (D (1) & D (2)) * Big_2xx (Scale) < Big_2xxDouble - and then T1 = Shift_Left (D (1) & D (2), Scale) - and then T2 = Shift_Left (Double_Uns (D (3)), Scale) - and then T3 = Shift_Left (Double_Uns (D (4)), Scale), - Post => Is_Scaled_Mult_Decomposition - (Big (Double_Uns (Hi (T1))), - Big (Double_Uns (Lo (T1) or Hi (T2))), - Big (Double_Uns (Lo (T2) or Hi (T3))), - Big (Double_Uns (Lo (T3)))); - -- Proves the scaling of the 4-digit dividend actually multiplies it by - -- 2**Scale. - - procedure Prove_Multiplication (Q : Single_Uns) - with - Ghost, - Pre => T1 = Q * Lo (Zu) - and then T2 = Q * Hi (Zu) - and then S3 = Lo (T1) - and then T3 = Hi (T1) + Lo (T2) - and then S2 = Lo (T3) - and then S1 = Hi (T3) + Hi (T2), - Post => Big3 (S1, S2, S3) = Big (Double_Uns (Q)) * Big (Zu); - -- Proves correctness of the multiplication of divisor by quotient to - -- compute amount to subtract. - - procedure Prove_Mult_Decomposition_Split2 - (D1, D2, D2_Hi, D2_Lo, D3, D4 : Big_Integer) - with - Ghost, - Pre => Is_Mult_Decomposition (D1, D2, D3, D4) - and then D2 = Big_2xxSingle * D2_Hi + D2_Lo, - Post => Is_Mult_Decomposition (D1 + D2_Hi, D2_Lo, D3, D4); - -- Proves decomposition of Mult after splitting second component - - procedure Prove_Mult_Decomposition_Split3 - (D1, D2, D3, D3_Hi, D3_Lo, D4 : Big_Integer) - with - Ghost, - Pre => Is_Mult_Decomposition (D1, D2, D3, D4) - and then D3 = Big_2xxSingle * D3_Hi + D3_Lo, - Post => Is_Mult_Decomposition (D1, D2 + D3_Hi, D3_Lo, D4); - -- Proves decomposition of Mult after splitting third component - - procedure Prove_Negative_Dividend - with - Ghost, - Pre => Z /= 0 - and then Big (Qu) = abs Big_Q - and then In_Double_Int_Range (Big_Q) - and then Big (Ru) = abs Big_R - and then ((X >= 0 and Y < 0) or (X < 0 and Y >= 0)) - and then Big_Q = - (if Round then Round_Quotient (Big (X) * Big (Y), Big (Z), - Big (X) * Big (Y) / Big (Z), - Big (X) * Big (Y) rem Big (Z)) - else Big (X) * Big (Y) / Big (Z)) - and then Big_R = Big (X) * Big (Y) rem Big (Z), - Post => - (if Z > 0 then Big_Q <= Big_0 - and then In_Double_Int_Range (-Big (Qu)) - else Big_Q >= Big_0 - and then In_Double_Int_Range (Big (Qu))) - and then In_Double_Int_Range (-Big (Ru)); - -- Proves the sign of rounded quotient when dividend is non-positive - - procedure Prove_Overflow - with - Ghost, - Pre => Z /= 0 - and then Mult >= Big_2xxDouble * Big (Double_Uns'(abs Z)), - Post => not In_Double_Int_Range (Big (X) * Big (Y) / Big (Z)) - and then not In_Double_Int_Range - (Round_Quotient (Big (X) * Big (Y), Big (Z), - Big (X) * Big (Y) / Big (Z), - Big (X) * Big (Y) rem Big (Z))); - -- Proves overflow case when the quotient has at least 3 digits - - procedure Prove_Positive_Dividend - with - Ghost, - Pre => Z /= 0 - and then Big (Qu) = abs Big_Q - and then In_Double_Int_Range (Big_Q) - and then Big (Ru) = abs Big_R - and then ((X >= 0 and Y >= 0) or (X < 0 and Y < 0)) - and then Big_Q = - (if Round then Round_Quotient (Big (X) * Big (Y), Big (Z), - Big (X) * Big (Y) / Big (Z), - Big (X) * Big (Y) rem Big (Z)) - else Big (X) * Big (Y) / Big (Z)) - and then Big_R = Big (X) * Big (Y) rem Big (Z), - Post => - (if Z > 0 then Big_Q >= Big_0 - and then In_Double_Int_Range (Big (Qu)) - else Big_Q <= Big_0 - and then In_Double_Int_Range (-Big (Qu))) - and then In_Double_Int_Range (Big (Ru)); - -- Proves the sign of rounded quotient when dividend is non-negative - - procedure Prove_Qd_Calculation_Part_1 (J : Integer) - with - Ghost, - Pre => J in 1 .. 2 - and then D'Initialized - and then D (J) < Zhi - and then Hi (Zu) = Zhi - and then Qd (J)'Initialized - and then Qd (J) = Lo ((D (J) & D (J + 1)) / Zhi), - Post => Big (Double_Uns (Qd (J))) >= - Big3 (D (J), D (J + 1), D (J + 2)) / Big (Zu); - -- When dividing 3 digits by 2 digits, proves the initial calculation - -- of the quotient given by dividing the first 2 digits of the dividend - -- by the first digit of the divisor is not an underestimate (so - -- readjusting down works). - - procedure Prove_Q_Too_Big - with - Ghost, - Pre => In_Double_Int_Range (Big_Q) - and then abs Big_Q = Big_2xxDouble, - Post => False; - -- Proves the inconsistency when Q is equal to Big_2xx64 - - procedure Prove_Rescaling - with - Ghost, - Pre => Scale <= Single_Size - and then Z /= 0 - and then Mult * Big_2xx (Scale) = Big (Zu) * Big (Qu) + Big (Ru) - and then Big (Ru) < Big (Zu) - and then Big (Zu) = Big (Double_Uns'(abs Z)) * Big_2xx (Scale) - and then Quot = Big (X) * Big (Y) / Big (Z) - and then Big_R = Big (X) * Big (Y) rem Big (Z), - Post => abs Quot = Big (Qu) - and then abs Big_R = Big (Shift_Right (Ru, Scale)); - -- Proves scaling back only the remainder is the right thing to do after - -- computing the scaled division. - - procedure Prove_Rounding_Case - with - Ghost, - Pre => Z /= 0 - and then Quot = Big (X) * Big (Y) / Big (Z) - and then Big_R = Big (X) * Big (Y) rem Big (Z) - and then Big_Q = - Round_Quotient (Big (X) * Big (Y), Big (Z), Quot, Big_R) - and then Big (Ru) = abs Big_R - and then Big (Zu) = Big (Double_Uns'(abs Z)), - Post => abs Big_Q = - (if Ru > (Zu - Double_Uns'(1)) / Double_Uns'(2) - then abs Quot + 1 - else abs Quot); - -- Proves correctness of the rounding of the unsigned quotient - - procedure Prove_Scaled_Mult_Decomposition_Regroup24 - (D1, D2, D3, D4 : Big_Integer) - with - Ghost, - Pre => Scale < Double_Size - and then Is_Scaled_Mult_Decomposition (D1, D2, D3, D4), - Post => Is_Scaled_Mult_Decomposition - (0, Big_2xxSingle * D1 + D2, 0, Big_2xxSingle * D3 + D4); - -- Proves scaled decomposition of Mult after regrouping on second and - -- fourth component. - - procedure Prove_Scaled_Mult_Decomposition_Regroup3 - (D1, D2, D3, D4 : Single_Uns) - with - Ghost, - Pre => Scale < Double_Size - and then Is_Scaled_Mult_Decomposition - (Big (Double_Uns (D1)), Big (Double_Uns (D2)), - Big (Double_Uns (D3)), Big (Double_Uns (D4))), - Post => Is_Scaled_Mult_Decomposition (0, 0, Big3 (D1, D2, D3), - Big (Double_Uns (D4))); - -- Proves scaled decomposition of Mult after regrouping on third - -- component. - - procedure Prove_Sign_R - with - Ghost, - Pre => Z /= 0 and then Big_R = Big (X) * Big (Y) rem Big (Z), - Post => In_Double_Int_Range (Big_R); - - procedure Prove_Signs - with - Ghost, - Pre => Z /= 0 - and then Quot = Big (X) * Big (Y) / Big (Z) - and then Big_R = Big (X) * Big (Y) rem Big (Z) - and then Big_Q = - (if Round then - Round_Quotient (Big (X) * Big (Y), Big (Z), Quot, Big_R) - else Quot) - and then Big (Ru) = abs Big_R - and then Big (Qu) = abs Big_Q - and then In_Double_Int_Range (Big_Q) - and then In_Double_Int_Range (Big_R) - and then R = - (if (X >= 0) = (Y >= 0) then To_Pos_Int (Ru) else To_Neg_Int (Ru)) - and then Q = - (if ((X >= 0) = (Y >= 0)) = (Z >= 0) then To_Pos_Int (Qu) - else To_Neg_Int (Qu)), -- need to ensure To_Pos_Int precondition - Post => Big (R) = Big_R and then Big (Q) = Big_Q; - -- Proves final signs match the intended result after the unsigned - -- division is done. - - procedure Prove_Z_Low - with - Ghost, - Pre => Z /= 0 - and then D'Initialized - and then Hi (abs Z) = 0 - and then Lo (abs Z) = Zlo - and then Mult = - Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (D (2))) - + Big_2xxSingle * Big (Double_Uns (D (3))) - + Big (Double_Uns (D (4))) - and then D (2) < Zlo - and then Quot = (Big (X) * Big (Y)) / Big (Z) - and then Big_R = (Big (X) * Big (Y)) rem Big (Z) - and then T1 = D (2) & D (3) - and then T2 = Lo (T1 rem Zlo) & D (4) - and then Qu = Lo (T1 / Zlo) & Lo (T2 / Zlo) - and then Ru = T2 rem Zlo, - Post => Big (Qu) = abs Quot - and then Big (Ru) = abs Big_R; - -- Proves the case where the divisor is only one digit - - ---------------------------- - -- Prove_Dividend_Scaling -- - ---------------------------- - - procedure Prove_Dividend_Scaling is - Big_D12 : constant Big_Integer := - Big_2xx (Scale) * Big (D (1) & D (2)); - Big_T1 : constant Big_Integer := Big (T1); - Big_D3 : constant Big_Integer := - Big_2xx (Scale) * Big (Double_Uns (D (3))); - Big_T2 : constant Big_Integer := Big (T2); - Big_D4 : constant Big_Integer := - Big_2xx (Scale) * Big (Double_Uns (D (4))); - Big_T3 : constant Big_Integer := Big (T3); - - begin - Lemma_Shift_Left (D (1) & D (2), Scale); - Lemma_Ge_Mult (Big_2xxSingle, Big_2xx (Scale), Big_2xxSingle, - Big_2xxSingle * Big_2xx (Scale)); - Lemma_Lt_Mult (Big (Double_Uns (D (3))), Big_2xxSingle, - Big_2xx (Scale), Big_2xxDouble); - Lemma_Shift_Left (Double_Uns (D (3)), Scale); - Lemma_Lt_Mult (Big (Double_Uns (D (4))), Big_2xxSingle, - Big_2xx (Scale), Big_2xxDouble); - Lemma_Shift_Left (Double_Uns (D (4)), Scale); - Lemma_Hi_Lo (D (1) & D (2), D (1), D (2)); - pragma Assert (Mult * Big_2xx (Scale) = - Big_2xxSingle * Big_2xxSingle * Big_D12 - + Big_2xxSingle * Big_D3 - + Big_D4); - pragma Assert (Big_2xx (Scale) > 0); - declare - Two_xx_Scale : constant Double_Uns := Double_Uns'(2 ** Scale); - D12 : constant Double_Uns := D (1) & D (2); - begin - pragma Assert (Big_2xx (Scale) * Big (D12) < Big_2xxDouble); - pragma Assert (Big (Two_xx_Scale) * Big (D12) < Big_2xxDouble); - Lemma_Mult_Commutation (Two_xx_Scale, D12, T1); - end; - pragma Assert (Big_D12 = Big_T1); - pragma Assert (Big_2xxSingle * Big_2xxSingle * Big_D12 - = Big_2xxSingle * Big_2xxSingle * Big_T1); - Lemma_Mult_Commutation (2 ** Scale, Double_Uns (D (3)), T2); - pragma Assert (Big_D3 = Big_T2); - pragma Assert (Big_2xxSingle * Big_D3 = Big_2xxSingle * Big_T2); - Lemma_Mult_Commutation (2 ** Scale, Double_Uns (D (4)), T3); - pragma Assert - (Is_Scaled_Mult_Decomposition (0, Big_T1, Big_T2, Big_T3)); - Lemma_Hi_Lo (T1, Hi (T1), Lo (T1)); - Lemma_Hi_Lo (T2, Hi (T2), Lo (T2)); - Lemma_Hi_Lo (T3, Hi (T3), Lo (T3)); - Lemma_Mult_Distribution (Big_2xxSingle * Big_2xxSingle, - Big_2xxSingle * Big (Double_Uns (Hi (T1))), - Big (Double_Uns (Lo (T1)))); - Lemma_Mult_Distribution (Big_2xxSingle, - Big_2xxSingle * Big (Double_Uns (Hi (T2))), - Big (Double_Uns (Lo (T2)))); - Lemma_Mult_Distribution (Big_2xxSingle * Big_2xxSingle, - Big (Double_Uns (Lo (T1))), - Big (Double_Uns (Hi (T2)))); - Lemma_Mult_Distribution (Big_2xxSingle, - Big (Double_Uns (Lo (T2))), - Big (Double_Uns (Hi (T3)))); - Lemma_Mult_Distribution (Big_2xxSingle * Big_2xxSingle, - Big (Double_Uns (Lo (T1))), - Big (Double_Uns (Hi (T2)))); - pragma Assert (Double_Uns (Lo (T1) or Hi (T2)) = - Double_Uns (Lo (T1)) + Double_Uns (Hi (T2))); - pragma Assert (Double_Uns (Lo (T2) or Hi (T3)) = - Double_Uns (Lo (T2)) + Double_Uns (Hi (T3))); - Lemma_Add_Commutation (Double_Uns (Lo (T1)), Hi (T2)); - Lemma_Add_Commutation (Double_Uns (Lo (T2)), Hi (T3)); - end Prove_Dividend_Scaling; - - -------------------------- - -- Prove_Multiplication -- - -------------------------- - - procedure Prove_Multiplication (Q : Single_Uns) is - begin - Lemma_Hi_Lo (Zu, Hi (Zu), Lo (Zu)); - Lemma_Hi_Lo (T1, Hi (T1), S3); - Lemma_Hi_Lo (T2, Hi (T2), Lo (T2)); - Lemma_Hi_Lo (T3, Hi (T3), S2); - Lemma_Mult_Commutation (Double_Uns (Q), Double_Uns (Lo (Zu)), T1); - Lemma_Mult_Commutation (Double_Uns (Q), Double_Uns (Hi (Zu)), T2); - Lemma_Mult_Distribution (Big (Double_Uns (Q)), - Big_2xxSingle * Big (Double_Uns (Hi (Zu))), - Big (Double_Uns (Lo (Zu)))); - Lemma_Substitution - (Big (Double_Uns (Q)) * Big (Zu), - Big (Double_Uns (Q)), - Big (Zu), - Big_2xxSingle * Big (Double_Uns (Hi (Zu))) - + Big (Double_Uns (Lo (Zu))), - Big_0); - pragma Assert (Big (Double_Uns (Q)) * Big (Zu) = - Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (Hi (T2))) - + Big_2xxSingle * Big (Double_Uns (Lo (T2))) - + Big_2xxSingle * Big (Double_Uns (Hi (T1))) - + Big (Double_Uns (S3))); - Lemma_Add_Commutation (Double_Uns (Lo (T2)), Hi (T1)); - pragma Assert - (By (Big (Double_Uns (Q)) * Big (Zu) = - Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (Hi (T2))) - + Big_2xxSingle * Big (T3) - + Big (Double_Uns (S3)), - By (Big_2xxSingle * Big (Double_Uns (Lo (T2))) - + Big_2xxSingle * Big (Double_Uns (Hi (T1))) - = Big_2xxSingle * Big (T3), - Double_Uns (Lo (T2)) - + Double_Uns (Hi (T1)) = T3))); - pragma Assert (Double_Uns (Hi (T3)) + Hi (T2) = Double_Uns (S1)); - Lemma_Add_Commutation (Double_Uns (Hi (T3)), Hi (T2)); - pragma Assert - (Big (Double_Uns (Hi (T3))) + Big (Double_Uns (Hi (T2))) = - Big (Double_Uns (S1))); - Lemma_Mult_Distribution (Big_2xxSingle * Big_2xxSingle, - Big (Double_Uns (Hi (T3))), - Big (Double_Uns (Hi (T2)))); - end Prove_Multiplication; - - ------------------------------------- - -- Prove_Mult_Decomposition_Split2 -- - ------------------------------------- - - procedure Prove_Mult_Decomposition_Split2 - (D1, D2, D2_Hi, D2_Lo, D3, D4 : Big_Integer) - is null; - - ------------------------------------- - -- Prove_Mult_Decomposition_Split3 -- - ------------------------------------- - - procedure Prove_Mult_Decomposition_Split3 - (D1, D2, D3, D3_Hi, D3_Lo, D4 : Big_Integer) - is null; - - ----------------------------- - -- Prove_Negative_Dividend -- - ----------------------------- - - procedure Prove_Negative_Dividend is - begin - Lemma_Mult_Non_Positive (Big (X), Big (Y)); - end Prove_Negative_Dividend; - - -------------------- - -- Prove_Overflow -- - -------------------- - - procedure Prove_Overflow is - begin - Lemma_Div_Ge (Mult, Big_2xxDouble, Big (Double_Uns'(abs Z))); - Lemma_Abs_Commutation (Z); - Lemma_Abs_Div_Commutation (Big (X) * Big (Y), Big (Z)); - end Prove_Overflow; - - ----------------------------- - -- Prove_Positive_Dividend -- - ----------------------------- - - procedure Prove_Positive_Dividend is - begin - Lemma_Mult_Non_Negative (Big (X), Big (Y)); - end Prove_Positive_Dividend; - - --------------------------------- - -- Prove_Qd_Calculation_Part_1 -- - --------------------------------- - - procedure Prove_Qd_Calculation_Part_1 (J : Integer) is - begin - Lemma_Hi_Lo (D (J) & D (J + 1), D (J), D (J + 1)); - Lemma_Lt_Commutation (Double_Uns (D (J)), Double_Uns (Zhi)); - Lemma_Gt_Mult (Big (Double_Uns (Zhi)), - Big (Double_Uns (D (J))) + 1, - Big_2xxSingle, Big (D (J) & D (J + 1))); - Lemma_Div_Lt - (Big (D (J) & D (J + 1)), Big_2xxSingle, Big (Double_Uns (Zhi))); - Lemma_Div_Commutation (D (J) & D (J + 1), Double_Uns (Zhi)); - Lemma_Lo_Is_Ident ((D (J) & D (J + 1)) / Zhi); - Lemma_Div_Definition (D (J) & D (J + 1), Zhi, Double_Uns (Qd (J)), - (D (J) & D (J + 1)) rem Zhi); - Lemma_Lt_Commutation - ((D (J) & D (J + 1)) rem Zhi, Double_Uns (Zhi)); - Lemma_Gt_Mult - ((Big (Double_Uns (Qd (J))) + 1) * Big (Double_Uns (Zhi)), - Big (D (J) & D (J + 1)) + 1, Big_2xxSingle, - Big3 (D (J), D (J + 1), D (J + 2))); - Lemma_Hi_Lo (Zu, Zhi, Lo (Zu)); - Lemma_Gt_Mult (Big (Zu), Big_2xxSingle * Big (Double_Uns (Zhi)), - Big (Double_Uns (Qd (J))) + 1, - Big3 (D (J), D (J + 1), D (J + 2))); - Lemma_Div_Lt (Big3 (D (J), D (J + 1), D (J + 2)), - Big (Double_Uns (Qd (J))) + 1, Big (Zu)); - end Prove_Qd_Calculation_Part_1; - - --------------------- - -- Prove_Q_Too_Big -- - --------------------- - - procedure Prove_Q_Too_Big is - begin - pragma Assert (Big_Q = Big_2xxDouble or Big_Q = -Big_2xxDouble); - Lemma_Not_In_Range_Big2xx64; - end Prove_Q_Too_Big; - - --------------------- - -- Prove_Rescaling -- - --------------------- - - procedure Prove_Rescaling is - begin - Lemma_Div_Lt (Big (Ru), Big (Double_Uns'(abs Z)), Big_2xx (Scale)); - Lemma_Div_Eq (Mult, Big (Double_Uns'(abs Z)) * Big (Qu), - Big_2xx (Scale), Big (Ru)); - Lemma_Rev_Div_Definition (Mult, Big (Double_Uns'(abs Z)), - Big (Qu), Big (Ru) / Big_2xx (Scale)); - Lemma_Abs_Div_Commutation (Big (X) * Big (Y), Big (Z)); - Lemma_Abs_Rem_Commutation (Big (X) * Big (Y), Big (Z)); - Lemma_Abs_Commutation (Z); - Lemma_Shift_Right (Ru, Scale); - end Prove_Rescaling; - - ------------------------- - -- Prove_Rounding_Case -- - ------------------------- - - procedure Prove_Rounding_Case is - begin - if Same_Sign (Big (X) * Big (Y), Big (Z)) then - pragma Assert - (abs Big_Q = - (if Ru > (Zu - Double_Uns'(1)) / Double_Uns'(2) - then abs Quot + 1 - else abs Quot)); - end if; - end Prove_Rounding_Case; - - ----------------------------------------------- - -- Prove_Scaled_Mult_Decomposition_Regroup24 -- - ----------------------------------------------- - - procedure Prove_Scaled_Mult_Decomposition_Regroup24 - (D1, D2, D3, D4 : Big_Integer) - is null; - - ---------------------------------------------- - -- Prove_Scaled_Mult_Decomposition_Regroup3 -- - ---------------------------------------------- - - procedure Prove_Scaled_Mult_Decomposition_Regroup3 - (D1, D2, D3, D4 : Single_Uns) - is null; - - ------------------ - -- Prove_Sign_R -- - ------------------ - - procedure Prove_Sign_R is - begin - pragma Assert (In_Double_Int_Range (Big (Z))); - end Prove_Sign_R; - - ----------------- - -- Prove_Signs -- - ----------------- - - procedure Prove_Signs is null; - - ----------------- - -- Prove_Z_Low -- - ----------------- - - procedure Prove_Z_Low is - begin - Lemma_Hi_Lo (T1, D (2), D (3)); - Lemma_Add_Commutation (Double_Uns (D (2)), 1); - pragma Assert - (Big (Double_Uns (D (2))) + 1 <= Big (Double_Uns (Zlo))); - Lemma_Div_Definition (T1, Zlo, T1 / Zlo, T1 rem Zlo); - pragma Assert - (By (Lo (T1 rem Zlo) = Hi (T2), - By (Double_Uns (Lo (T1 rem Zlo)) = T1 rem Zlo, - T1 rem Zlo <= Double_Uns (Zlo)))); - Lemma_Hi_Lo (T2, Lo (T1 rem Zlo), D (4)); - pragma Assert (T1 rem Zlo < Double_Uns (Zlo)); - pragma Assert (T1 rem Zlo + Double_Uns'(1) <= Double_Uns (Zlo)); - Lemma_Ge_Commutation (Double_Uns (Zlo), T1 rem Zlo + Double_Uns'(1)); - Lemma_Add_Commutation (T1 rem Zlo, 1); - pragma Assert (Big (T1 rem Zlo) + 1 <= Big (Double_Uns (Zlo))); - Lemma_Div_Definition (T2, Zlo, T2 / Zlo, Ru); - pragma Assert - (By (Big_2xxSingle * Big (Double_Uns (D (2))) - + Big (Double_Uns (D (3))) - < Big_2xxSingle * (Big (Double_Uns (D (2))) + 1), - Mult = Big (Double_Uns (Zlo)) * - (Big_2xxSingle * Big (T1 / Zlo) + Big (T2 / Zlo)) + Big (Ru))); - Lemma_Div_Lt (Big (T1), Big_2xxSingle, Big (Double_Uns (Zlo))); - Lemma_Div_Commutation (T1, Double_Uns (Zlo)); - Lemma_Lo_Is_Ident (T1 / Zlo); - pragma Assert - (Big (T2) <= Big_2xxSingle * (Big (Double_Uns (Zlo)) - 1) - + Big (Double_Uns (D (4)))); - Lemma_Hi_Lo (Qu, Lo (T1 / Zlo), Lo (T2 / Zlo)); - Lemma_Div_Lt (Big (T2), Big_2xxSingle, Big (Double_Uns (Zlo))); - Lemma_Div_Commutation (T2, Double_Uns (Zlo)); - Lemma_Lo_Is_Ident (T2 / Zlo); - Lemma_Substitution (Mult, Big (Double_Uns (Zlo)), - Big_2xxSingle * Big (T1 / Zlo) + Big (T2 / Zlo), - Big (Qu), Big (Ru)); - pragma Assert - (By (Ru < Double_Uns (Zlo), Ru = T2 rem Zlo)); - Lemma_Lt_Commutation (Ru, Double_Uns (Zlo)); - Lemma_Rev_Div_Definition - (Mult, Big (Double_Uns (Zlo)), Big (Qu), Big (Ru)); - pragma Assert (Double_Uns (Zlo) = abs Z); - Lemma_Abs_Commutation (Z); - Lemma_Abs_Div_Commutation (Big (X) * Big (Y), Big (Z)); - Lemma_Abs_Rem_Commutation (Big (X) * Big (Y), Big (Z)); - end Prove_Z_Low; - -- Start of processing for Scaled_Divide begin @@ -2562,237 +401,56 @@ is Raise_Error; end if; - Quot := Big (X) * Big (Y) / Big (Z); - Big_R := Big (X) * Big (Y) rem Big (Z); - if Round then - Big_Q := Round_Quotient (Big (X) * Big (Y), Big (Z), Quot, Big_R); - else - Big_Q := Quot; - end if; - -- First do the multiplication, giving the four digit dividend - Lemma_Abs_Mult_Commutation (Big (X), Big (Y)); - Lemma_Abs_Commutation (X); - Lemma_Abs_Commutation (Y); - Lemma_Mult_Decomposition (Mult, Xu, Yu, Xhi, Xlo, Yhi, Ylo); - T1 := Xlo * Ylo; D (4) := Lo (T1); D (3) := Hi (T1); - Lemma_Hi_Lo (T1, D (3), D (4)); - if Yhi /= 0 then T1 := Xlo * Yhi; - - Lemma_Hi_Lo (T1, Hi (T1), Lo (T1)); - T2 := D (3) + Lo (T1); - Lemma_Add_Commutation (Double_Uns (Lo (T1)), D (3)); - Lemma_Mult_Distribution (Big_2xxSingle, - Big (Double_Uns (D (3))), - Big (Double_Uns (Lo (T1)))); - Lemma_Hi_Lo (T2, Hi (T2), Lo (T2)); - D (3) := Lo (T2); D (2) := Hi (T1) + Hi (T2); - pragma Assert (Double_Uns (Hi (T1)) + Hi (T2) = Double_Uns (D (2))); - Lemma_Add_Commutation (Double_Uns (Hi (T1)), Hi (T2)); - pragma Assert - (Big (Double_Uns (Hi (T1))) + Big (Double_Uns (Hi (T2))) = - Big (Double_Uns (D (2)))); - if Xhi /= 0 then T1 := Xhi * Ylo; - - Lemma_Hi_Lo (T1, Hi (T1), Lo (T1)); - T2 := D (3) + Lo (T1); - Lemma_Add_Commutation (Double_Uns (D (3)), Lo (T1)); - Lemma_Hi_Lo (T2, Hi (T2), Lo (T2)); - Prove_Mult_Decomposition_Split3 - (D1 => 0, - D2 => Big (Double_Uns'(Xhi * Yhi)) + Big (Double_Uns (D (2))) - + Big (Double_Uns (Hi (T1))), - D3 => Big (T2), - D3_Hi => Big (Double_Uns (Hi (T2))), - D3_Lo => Big (Double_Uns (Lo (T2))), - D4 => Big (Double_Uns (D (4)))); - D (3) := Lo (T2); T3 := D (2) + Hi (T1); - Lemma_Add_Commutation (Double_Uns (D (2)), Hi (T1)); - Lemma_Add_Commutation (T3, Hi (T2)); - T3 := T3 + Hi (T2); T2 := Double_Uns'(Xhi * Yhi); - Lemma_Hi_Lo (T2, Hi (T2), Lo (T2)); - pragma Assert - (Is_Mult_Decomposition - (D1 => Big (Double_Uns (Hi (T2))), - D2 => Big (T3) + Big (Double_Uns (Lo (T2))), - D3 => Big (Double_Uns (D (3))), - D4 => Big (Double_Uns (D (4))))); - T1 := T3 + Lo (T2); D (2) := Lo (T1); - - Lemma_Add_Commutation (T3, Lo (T2)); - Lemma_Hi_Lo (T1, Hi (T1), Lo (T1)); - Prove_Mult_Decomposition_Split2 - (D1 => Big (Double_Uns (Hi (T2))), - D2 => Big (T1), - D2_Lo => Big (Double_Uns (Lo (T1))), - D2_Hi => Big (Double_Uns (Hi (T1))), - D3 => Big (Double_Uns (D (3))), - D4 => Big (Double_Uns (D (4)))); - D (1) := Hi (T2) + Hi (T1); - pragma Assert_And_Cut - (D'Initialized - and Is_Mult_Decomposition (D1 => Big (Double_Uns (D (1))), - D2 => Big (Double_Uns (D (2))), - D3 => Big (Double_Uns (D (3))), - D4 => Big (Double_Uns (D (4))))); else - pragma Assert - (Is_Mult_Decomposition - (D1 => 0, - D2 => Big (Double_Uns (D (2))), - D3 => Big (Double_Uns (D (3))) - + Big (Double_Uns (Xhi)) * Big (Yu), - D4 => Big (Double_Uns (D (4))))); - D (1) := 0; - - pragma Assert_And_Cut - (D'Initialized - and Is_Mult_Decomposition (D1 => Big (Double_Uns (D (1))), - D2 => Big (Double_Uns (D (2))), - D3 => Big (Double_Uns (D (3))), - D4 => Big (Double_Uns (D (4))))); end if; - else if Xhi /= 0 then T1 := Xhi * Ylo; - - Lemma_Hi_Lo (T1, Hi (T1), Lo (T1)); - pragma Assert - (Is_Mult_Decomposition - (D1 => 0, - D2 => Big (Double_Uns (Hi (T1))), - D3 => Big (Double_Uns (Lo (T1))) + Big (Double_Uns (D (3))), - D4 => Big (Double_Uns (D (4))))); - T2 := D (3) + Lo (T1); - Lemma_Add_Commutation (Double_Uns (Lo (T1)), D (3)); - pragma Assert - (Is_Mult_Decomposition - (D1 => 0, - D2 => Big (Double_Uns (Hi (T1))), - D3 => Big (T2), - D4 => Big (Double_Uns (D (4))))); - Lemma_Hi_Lo (T2, Hi (T2), Lo (T2)); - D (3) := Lo (T2); D (2) := Hi (T1) + Hi (T2); - pragma Assert - (Double_Uns (Hi (T1)) + Hi (T2) = Double_Uns (D (2))); - Lemma_Add_Commutation (Double_Uns (Hi (T1)), Hi (T2)); - pragma Assert - (Big (Double_Uns (Hi (T1))) + Big (Double_Uns (Hi (T2))) = - Big (Double_Uns (D (2)))); - pragma Assert - (Is_Mult_Decomposition - (D1 => 0, - D2 => Big (Double_Uns (D (2))), - D3 => Big (Double_Uns (D (3))), - D4 => Big (Double_Uns (D (4))))); else D (2) := 0; - - pragma Assert - (Is_Mult_Decomposition - (D1 => 0, - D2 => Big (Double_Uns (D (2))), - D3 => Big (Double_Uns (D (3))), - D4 => Big (Double_Uns (D (4))))); end if; D (1) := 0; - - pragma Assert_And_Cut - (D'Initialized - and Is_Mult_Decomposition (D1 => Big (Double_Uns (D (1))), - D2 => Big (Double_Uns (D (2))), - D3 => Big (Double_Uns (D (3))), - D4 => Big (Double_Uns (D (4))))); end if; - pragma Assert_And_Cut - -- Restate the precondition - (Z /= 0 - and then In_Double_Int_Range - (if Round then Round_Quotient (Big (X) * Big (Y), Big (Z), - Big (X) * Big (Y) / Big (Z), - Big (X) * Big (Y) rem Big (Z)) - else Big (X) * Big (Y) / Big (Z)) - -- Restate the value of local variables - and then Zu = abs Z - and then Zhi = Hi (Zu) - and then Zlo = Lo (Zu) - and then Mult = abs (Big (X) * Big (Y)) - and then Quot = Big (X) * Big (Y) / Big (Z) - and then Big_R = Big (X) * Big (Y) rem Big (Z) - and then - (if Round then - Big_Q = Round_Quotient (Big (X) * Big (Y), Big (Z), Quot, Big_R) - else - Big_Q = Quot) - -- Summarize first part of the procedure - and then D'Initialized - and then Is_Mult_Decomposition (D1 => Big (Double_Uns (D (1))), - D2 => Big (Double_Uns (D (2))), - D3 => Big (Double_Uns (D (3))), - D4 => Big (Double_Uns (D (4))))); - -- Now it is time for the dreaded multiple precision division. First an -- easy case, check for the simple case of a one digit divisor. if Zhi = 0 then if D (1) /= 0 or else D (2) >= Zlo then - if D (1) > 0 then - Lemma_Double_Big_2xxSingle; - Lemma_Mult_Positive (Big_2xxDouble, Big_2xxSingle); - Lemma_Ge_Mult (Big (Double_Uns (D (1))), - 1, - Big_2xxDouble * Big_2xxSingle, - Big_2xxDouble * Big_2xxSingle); - Lemma_Mult_Positive (Big_2xxSingle, Big (Double_Uns (D (1)))); - Lemma_Ge_Mult (Big_2xxSingle * Big_2xxSingle, Big_2xxDouble, - Big_2xxSingle * Big (Double_Uns (D (1))), - Big_2xxDouble * Big_2xxSingle); - pragma Assert (Mult >= Big_2xxDouble * Big_2xxSingle); - Lemma_Ge_Commutation (2 ** Single_Size, Zu); - Lemma_Ge_Mult (Big_2xxSingle, Big (Zu), Big_2xxDouble, - Big_2xxDouble * Big (Zu)); - pragma Assert (Mult >= Big_2xxDouble * Big (Zu)); - else - Lemma_Ge_Commutation (Double_Uns (D (2)), Zu); - pragma Assert (Mult >= Big_2xxDouble * Big (Zu)); - end if; - - Prove_Overflow; Raise_Error; -- Here we are dividing at most three digits by one digit @@ -2803,18 +461,11 @@ is Qu := Lo (T1 / Zlo) & Lo (T2 / Zlo); Ru := T2 rem Zlo; - - Prove_Z_Low; end if; -- If divisor is double digit and dividend is too large, raise error elsif (D (1) & D (2)) >= Zu then - Lemma_Hi_Lo (D (1) & D (2), D (1), D (2)); - Lemma_Ge_Commutation (D (1) & D (2), Zu); - pragma Assert - (Mult >= Big_2xxSingle * Big_2xxSingle * Big (D (1) & D (2))); - Prove_Overflow; Raise_Error; -- This is the complex case where we definitely have a double digit @@ -2827,489 +478,87 @@ is -- First normalize the divisor so that it has the leading bit on. -- We do this by finding the appropriate left shift amount. - Lemma_Hi_Lo (D (1) & D (2), D (1), D (2)); - Lemma_Lt_Commutation (D (1) & D (2), Zu); - pragma Assert - (Mult < Big_2xxDouble * Big (Zu)); - Shift := Single_Size; Mask := Single_Uns'Last; Scale := 0; - Inter := 0; - pragma Assert (Big_2xx (Scale) = 1); - while Shift > 1 loop - pragma Loop_Invariant (Scale <= Single_Size - Shift); - pragma Loop_Invariant ((Hi (Zu) and Mask) /= 0); - pragma Loop_Invariant - (Mask = Shift_Left (Single_Uns'Last, Single_Size - Shift)); - pragma Loop_Invariant (Zu = Shift_Left (abs Z, Scale)); - pragma Loop_Invariant (Big (Zu) = - Big (Double_Uns'(abs Z)) * Big_2xx (Scale)); - pragma Loop_Invariant (Inter in 0 .. Log_Single_Size - 1); - pragma Loop_Invariant (Shift = 2 ** (Log_Single_Size - Inter)); - pragma Loop_Invariant (Shift mod 2 = 0); - - declare - -- Local ghost variables - - Shift_Prev : constant Natural := Shift with Ghost; - Mask_Prev : constant Single_Uns := Mask with Ghost; - Zu_Prev : constant Double_Uns := Zu with Ghost; - - -- Local lemmas - - procedure Prove_Power - with - Ghost, - Pre => Inter in 0 .. Log_Single_Size - 1 - and then Shift = 2 ** (Log_Single_Size - Inter), - Post => Shift / 2 = 2 ** (Log_Single_Size - (Inter + 1)) - and then (Shift = 2 or (Shift / 2) mod 2 = 0); - - procedure Prove_Prev_And_Mask (Prev, Mask : Single_Uns) - with - Ghost, - Pre => Prev /= 0 - and then (Prev and Mask) = 0, - Post => (Prev and not Mask) /= 0; - - procedure Prove_Shift_Progress - with - Ghost, - Pre => Shift <= Single_Size / 2 - and then Shift_Prev = 2 * Shift - and then Mask_Prev = - Shift_Left (Single_Uns'Last, Single_Size - Shift_Prev) - and then Mask = - Shift_Left (Single_Uns'Last, - Single_Size - Shift_Prev + Shift), - Post => Mask_Prev = - Shift_Left (Single_Uns'Last, Single_Size - 2 * Shift) - and then Mask = - Shift_Left (Single_Uns'Last, Single_Size - Shift); - - procedure Prove_Shifting - with - Ghost, - Pre => Shift <= Single_Size / 2 - and then Zu = Shift_Left (Zu_Prev, Shift) - and then Mask_Prev = - Shift_Left (Single_Uns'Last, Single_Size - 2 * Shift) - and then Mask = - Shift_Left (Single_Uns'Last, Single_Size - Shift) - and then (Hi (Zu_Prev) and Mask_Prev and not Mask) /= 0, - Post => (Hi (Zu) and Mask) /= 0; - - ----------------------------- - -- Local lemma null bodies -- - ----------------------------- - - procedure Prove_Prev_And_Mask (Prev, Mask : Single_Uns) is null; - procedure Prove_Power is null; - procedure Prove_Shifting is null; - procedure Prove_Shift_Progress is null; - - begin - pragma Assert (Mask = Shift_Left (Single_Uns'Last, - Single_Size - Shift_Prev)); - Prove_Power; - - Shift := Shift / 2; - - Inter := Inter + 1; - pragma Assert (Shift_Prev = 2 * Shift); - - Mask := Shift_Left (Mask, Shift); - - Lemma_Double_Shift - (Single_Uns'Last, Single_Size - Shift_Prev, Shift); - Prove_Shift_Progress; - - if (Hi (Zu) and Mask) = 0 then - Zu := Shift_Left (Zu, Shift); - - pragma Assert ((Hi (Zu_Prev) and Mask_Prev) /= 0); - pragma Assert - (By ((Hi (Zu_Prev) and Mask_Prev and Mask) = 0, - (Hi (Zu_Prev) and Mask) = 0 - and then - (Hi (Zu_Prev) and Mask_Prev and Mask) - = (Hi (Zu_Prev) and Mask and Mask_Prev) - )); - Prove_Prev_And_Mask (Hi (Zu_Prev) and Mask_Prev, Mask); - Prove_Shifting; - pragma Assert (Big (Zu_Prev) = - Big (Double_Uns'(abs Z)) * Big_2xx (Scale)); - Lemma_Shift_Without_Drop (Zu_Prev, Zu, Mask, Shift); - Lemma_Substitution - (Big (Zu), Big_2xx (Shift), - Big (Zu_Prev), Big (Double_Uns'(abs Z)) * Big_2xx (Scale), - 0); - Lemma_Powers_Of_2 (Shift, Scale); - Lemma_Substitution - (Big (Zu), Big (Double_Uns'(abs Z)), - Big_2xx (Shift) * Big_2xx (Scale), - Big_2xx (Shift + Scale), 0); - Lemma_Double_Shift (abs Z, Scale, Shift); - - Scale := Scale + Shift; - - pragma Assert (Zu = Shift_Left (abs Z, Scale)); - pragma Assert - (Big (Zu) = Big (Double_Uns'(abs Z)) * Big_2xx (Scale)); - end if; - - pragma Assert - (Big (Zu) = Big (Double_Uns'(abs Z)) * Big_2xx (Scale)); - end; + Shift := Shift / 2; + Mask := Shift_Left (Mask, Shift); + + if (Hi (Zu) and Mask) = 0 then + Zu := Shift_Left (Zu, Shift); + Scale := Scale + Shift; + end if; end loop; - pragma Assert_And_Cut - (Scale <= Single_Size - 1 - and then (Hi (Zu) and Mask) /= 0 - and then Mask = Shift_Left (Single_Uns'Last, Single_Size - 1) - and then Zu = Shift_Left (abs Z, Scale) - and then Big (Zu) = Big (Double_Uns'(abs Z)) * Big_2xx (Scale) - and then Mult < Big_2xxDouble * Big (Double_Uns'(abs Z))); Zhi := Hi (Zu); Zlo := Lo (Zu); - pragma Assert ((Zhi and Mask) /= 0); - pragma Assert (Zhi >= 2 ** (Single_Size - 1)); - pragma Assert (Big (Zu) = Big (Double_Uns'(abs Z)) * Big_2xx (Scale)); - -- We have Hi (Zu) /= 0 before normalization. The sequence of - -- Shift_Left operations results in the leading bit of Zu being 1 by - -- moving the leftmost 1-bit in Zu to leading position, thus - -- Zhi = Hi (Zu) >= 2 ** (Single_Size - 1) here. - -- Note that when we scale up the dividend, it still fits in four -- digits, since we already tested for overflow, and scaling does -- not change the invariant that (D (1) & D (2)) < Zu. - Lemma_Lt_Commutation (D (1) & D (2), abs Z); - Lemma_Big_Of_Double_Uns (Zu); - Lemma_Lt_Mult (Big (D (1) & D (2)), - Big (Double_Uns'(abs Z)), Big_2xx (Scale), - Big_2xxDouble); - T1 := Shift_Left (D (1) & D (2), Scale); T2 := Shift_Left (Double_Uns (D (3)), Scale); T3 := Shift_Left (Double_Uns (D (4)), Scale); - Prove_Dividend_Scaling; - D (1) := Hi (T1); D (2) := Lo (T1) or Hi (T2); D (3) := Lo (T2) or Hi (T3); D (4) := Lo (T3); - pragma Assert (D (1) = Hi (T1) and D (2) = (Lo (T1) or Hi (T2)) - and D (3) = (Lo (T2) or Hi (T3)) and D (4) = Lo (T3)); - Lemma_Substitution (Big_2xxDouble * Big (Zu), Big_2xxDouble, Big (Zu), - Big (Double_Uns'(abs Z)) * Big_2xx (Scale), 0); - pragma Assert (Mult < Big_2xxDouble * Big (Double_Uns'(abs Z))); - Lemma_Lt_Mult (Mult, Big_2xxDouble * Big (Double_Uns'(abs Z)), - Big_2xx (Scale), Big_2xxDouble * Big (Zu)); - pragma Assert (Mult >= Big_0); - pragma Assert (Big_2xx (Scale) >= Big_0); - Lemma_Mult_Non_Negative (Mult, Big_2xx (Scale)); - Lemma_Div_Lt (Mult * Big_2xx (Scale), Big (Zu), Big_2xxDouble); - Lemma_Concat_Definition (D (1), D (2)); - Lemma_Double_Big_2xxSingle; - Prove_Scaled_Mult_Decomposition_Regroup24 - (Big (Double_Uns (D (1))), - Big (Double_Uns (D (2))), - Big (Double_Uns (D (3))), - Big (Double_Uns (D (4)))); - Lemma_Substitution - (Mult * Big_2xx (Scale), Big_2xxSingle * Big_2xxSingle, - Big_2xxSingle * Big (Double_Uns (D (1))) - + Big (Double_Uns (D (2))), - Big (D (1) & D (2)), - Big_2xxSingle * Big (Double_Uns (D (3))) - + Big (Double_Uns (D (4)))); - pragma Assert - (By (Big (D (1) & D (2)) < Big (Zu), - Big_2xxDouble * (Big (Zu) - Big (D (1) & D (2))) > - Big_2xxSingle * Big (Double_Uns (D (3))) - + Big (Double_Uns (D (4))))); - -- Loop to compute quotient digits, runs twice for Qd (1) and Qd (2) - declare - -- Local lemmas - - procedure Prove_First_Iteration (X1, X2, X3, X4 : Single_Uns) - with - Ghost, - Pre => X1 = 0, - Post => - Big_2xxSingle * Big3 (X1, X2, X3) + Big (Double_Uns (X4)) - = Big3 (X2, X3, X4); - - --------------------------- - -- Prove_First_Iteration -- - --------------------------- - - procedure Prove_First_Iteration (X1, X2, X3, X4 : Single_Uns) is - null; - - -- Local ghost variables - - Qd1 : Single_Uns := 0 with Ghost; - D234 : Big_Integer with Ghost, Relaxed_Initialization; - D123 : constant Big_Integer := Big3 (D (1), D (2), D (3)) - with Ghost; - D4 : constant Big_Integer := Big (Double_Uns (D (4))) - with Ghost; - - begin - Prove_Scaled_Mult_Decomposition_Regroup3 - (D (1), D (2), D (3), D (4)); - pragma Assert - (By (Mult * Big_2xx (Scale) = Big_2xxSingle * D123 + D4, - Is_Scaled_Mult_Decomposition (0, 0, D123, D4))); - - for J in 1 .. 2 loop - Lemma_Hi_Lo (D (J) & D (J + 1), D (J), D (J + 1)); - pragma Assert (Big (D (J) & D (J + 1)) < Big (Zu)); - - -- Compute next quotient digit. We have to divide three digits - -- by two digits. We estimate the quotient by dividing the - -- leading two digits by the leading digit. Given the scaling - -- we did above which ensured the first bit of the divisor is - -- set, this gives an estimate of the quotient that is at most - -- two too high. - - if D (J) > Zhi then - Lemma_Lt_Commutation (Zu, D (J) & D (J + 1)); - pragma Assert (False); - - elsif D (J) = Zhi then - Qd (J) := Single_Uns'Last; - - Lemma_Concat_Definition (D (J), D (J + 1)); - Lemma_Big_Of_Double_Uns_Of_Single_Uns (D (J + 2)); - pragma Assert (Big_2xxSingle > Big (Double_Uns (D (J + 2)))); - pragma Assert - (By (Big3 (D (J), D (J + 1), 0) + Big_2xxSingle - > Big3 (D (J), D (J + 1), D (J + 2)), - Big3 (D (J), D (J + 1), 0) = - Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (D (J))) - + Big_2xxSingle * Big (Double_Uns (D (J + 1))))); - pragma Assert (Big (Double_Uns'(0)) = 0); - pragma Assert (Big (D (J) & D (J + 1)) * Big_2xxSingle = - Big_2xxSingle * (Big_2xxSingle * Big (Double_Uns (D (J))) - + Big (Double_Uns (D (J + 1))))); - pragma Assert (Big (D (J) & D (J + 1)) * Big_2xxSingle = - Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (D (J))) - + Big_2xxSingle * Big (Double_Uns (D (J + 1)))); - pragma Assert (Big (D (J) & D (J + 1)) * Big_2xxSingle - = Big3 (D (J), D (J + 1), 0)); - pragma Assert ((Big (D (J) & D (J + 1)) + 1) * Big_2xxSingle - = Big3 (D (J), D (J + 1), 0) + Big_2xxSingle); - Lemma_Gt_Mult (Big (Zu), Big (D (J) & D (J + 1)) + 1, - Big_2xxSingle, - Big3 (D (J), D (J + 1), D (J + 2))); - Lemma_Div_Lt - (Big3 (D (J), D (J + 1), D (J + 2)), - Big_2xxSingle, Big (Zu)); - pragma Assert - (By (Big (Double_Uns (Qd (J))) >= - Big3 (D (J), D (J + 1), D (J + 2)) / Big (Zu), - Big (Double_Uns (Qd (J))) = Big_2xxSingle - 1)); - - else - Qd (J) := Lo ((D (J) & D (J + 1)) / Zhi); - - Prove_Qd_Calculation_Part_1 (J); - end if; - - pragma Assert (for all K in 1 .. J => Qd (K)'Initialized); - Lemma_Div_Mult (Big3 (D (J), D (J + 1), D (J + 2)), Big (Zu)); - Lemma_Gt_Mult - (Big (Double_Uns (Qd (J))), - Big3 (D (J), D (J + 1), D (J + 2)) / Big (Zu), - Big (Zu), Big3 (D (J), D (J + 1), D (J + 2)) - Big (Zu)); - - -- Compute amount to subtract - - T1 := Qd (J) * Zlo; - T2 := Qd (J) * Zhi; - S3 := Lo (T1); - T3 := Hi (T1) + Lo (T2); - S2 := Lo (T3); - S1 := Hi (T3) + Hi (T2); - - Prove_Multiplication (Qd (J)); - - -- Adjust quotient digit if it was too high - - -- We use the version of the algorithm in the 2nd Edition - -- of "The Art of Computer Programming". This had a bug not - -- discovered till 1995, see Vol 2 errata: - -- http://www-cs-faculty.stanford.edu/~uno/err2-2e.ps.gz. - -- Under rare circumstances the expression in the test could - -- overflow. This version was further corrected in 2005, see - -- Vol 2 errata: - -- http://www-cs-faculty.stanford.edu/~uno/all2-pre.ps.gz. - -- This implementation is not impacted by these bugs, due - -- to the use of a word-size comparison done in function Le3 - -- instead of a comparison on two-word integer quantities in - -- the original algorithm. - - Lemma_Hi_Lo_3 (Zu, Zhi, Zlo); - - while not Le3 (S1, S2, S3, D (J), D (J + 1), D (J + 2)) loop - pragma Loop_Invariant - (Qd (1)'Initialized - and (if J = 2 then Qd (2)'Initialized)); - pragma Loop_Invariant (if J = 2 then Qd (1) = Qd1); - pragma Loop_Invariant - (Big3 (S1, S2, S3) = Big (Double_Uns (Qd (J))) * Big (Zu)); - pragma Loop_Invariant - (Big3 (S1, S2, S3) > Big3 (D (J), D (J + 1), D (J + 2))); - pragma Assert (Big3 (S1, S2, S3) > 0); - if Qd (J) = 0 then - pragma Assert (Big3 (S1, S2, S3) = 0); - pragma Assert (False); - end if; - Lemma_Ge_Commutation (Double_Uns (Qd (J)), 1); - Lemma_Ge_Mult - (Big (Double_Uns (Qd (J))), 1, Big (Zu), Big (Zu)); - - Sub3 (S1, S2, S3, 0, Zhi, Zlo); - - pragma Assert - (Big3 (S1, S2, S3) > - Big3 (D (J), D (J + 1), D (J + 2)) - Big (Zu)); - Lemma_Subtract_Commutation (Double_Uns (Qd (J)), 1); - pragma Assert (Double_Uns (Qd (J)) - Double_Uns'(1) - = Double_Uns (Qd (J) - 1)); - pragma Assert (Big (Double_Uns'(1)) = 1); - - declare - Prev : constant Single_Uns := Qd (J) with Ghost; - begin - Qd (J) := Qd (J) - 1; - Lemma_Substitution (Big3 (S1, S2, S3), Big (Zu), - Big (Double_Uns (Prev)) - 1, - Big (Double_Uns (Qd (J))), 0); - end; - - pragma Assert - (Big3 (S1, S2, S3) = Big (Double_Uns (Qd (J))) * Big (Zu)); - end loop; - - pragma Assert_And_Cut - (Qd (1)'Initialized - and then (if J = 2 then Qd (2)'Initialized and Qd (1) = Qd1) - and then D'Initialized - and then (if J = 2 then D234'Initialized) - and then Big3 (D (J), D (J + 1), D (J + 2)) = - (if J = 1 then D123 else D234) - and then (if J = 1 then D4 = Big (Double_Uns (D (4)))) - and then Big3 (S1, S2, S3) = - Big (Double_Uns (Qd (J))) * Big (Zu) - and then Le3 (S1, S2, S3, D (J), D (J + 1), D (J + 2)) - and then Big3 (D (J), D (J + 1), D (J + 2)) - - Big3 (S1, S2, S3) < Big (Zu)); - - -- Now subtract S1&S2&S3 from D1&D2&D3 ready for next step - - Inline_Le3 (S1, S2, S3, D (J), D (J + 1), D (J + 2)); - - declare - D4_G : constant Single_Uns := D (4) with Ghost; - begin - Sub3 (D (J), D (J + 1), D (J + 2), S1, S2, S3); - pragma Assert (if J = 1 then D (4) = D4_G); - pragma Assert - (By - (D'Initialized, - D (1)'Initialized and D (2)'Initialized - and D (3)'Initialized and D (4)'Initialized)); - pragma Assert - (Big3 (D (J), D (J + 1), D (J + 2)) = - (if J = 1 then D123 else D234) - - Big3 (S1, S2, S3)); - end; - - pragma Assert - (Big3 (D (J), D (J + 1), D (J + 2)) < Big (Zu)); - - if D (J) > 0 then - Lemma_Double_Big_2xxSingle; - pragma Assert (Big3 (D (J), D (J + 1), D (J + 2)) = - Big_2xxSingle - * Big_2xxSingle * Big (Double_Uns (D (J))) - + Big_2xxSingle * Big (Double_Uns (D (J + 1))) - + Big (Double_Uns (D (J + 2)))); - pragma Assert (Big_2xxSingle >= 0); - Lemma_Big_Of_Double_Uns_Of_Single_Uns (D (J + 1)); - pragma Assert (Big (Double_Uns (D (J + 1))) >= 0); - Lemma_Mult_Non_Negative - (Big_2xxSingle, Big (Double_Uns (D (J + 1)))); - pragma Assert - (Big3 (D (J), D (J + 1), D (J + 2)) >= - Big_2xxSingle * Big_2xxSingle - * Big (Double_Uns (D (J)))); - Lemma_Ge_Commutation (Double_Uns (D (J)), Double_Uns'(1)); - Lemma_Ge_Mult (Big (Double_Uns (D (J))), - Big (Double_Uns'(1)), - Big_2xxDouble, - Big (Double_Uns'(1)) * Big_2xxDouble); - pragma Assert - (Big_2xxDouble * Big (Double_Uns'(1)) = Big_2xxDouble); - pragma Assert - (Big3 (D (J), D (J + 1), D (J + 2)) >= Big_2xxDouble); - pragma Assert (False); - end if; - - if J = 1 then - Qd1 := Qd (1); - D234 := Big3 (D (2), D (3), D (4)); - pragma Assert (D4 = Big (Double_Uns (D (4)))); - Lemma_Substitution - (Mult * Big_2xx (Scale), Big_2xxSingle, D123, - Big3 (D (1), D (2), D (3)) + Big3 (S1, S2, S3), - Big (Double_Uns (D (4)))); - Prove_First_Iteration (D (1), D (2), D (3), D (4)); - Lemma_Substitution (Mult * Big_2xx (Scale), Big_2xxSingle, - Big3 (S1, S2, S3), - Big (Double_Uns (Qd1)) * Big (Zu), - D234); - else - pragma Assert (Qd1 = Qd (1)); - pragma Assert - (By (Mult * Big_2xx (Scale) = - Big_2xxSingle * Big (Double_Uns (Qd (1))) * Big (Zu) - + Big (Double_Uns (Qd (2))) * Big (Zu) - + Big_2xxSingle * Big (Double_Uns (D (3))) - + Big (Double_Uns (D (4))), - By (Mult * Big_2xx (Scale) = - Big_2xxSingle * Big (Double_Uns (Qd (1))) * Big (Zu) - + Big3 (D (2), D (3), D (4)) + Big3 (S1, S2, S3), - Mult * Big_2xx (Scale) = - Big_2xxSingle * Big (Double_Uns (Qd (1))) * Big (Zu) - + D234))); - - end if; + for J in 1 .. 2 loop + -- Compute next quotient digit. We have to divide three digits + -- by two digits. We estimate the quotient by dividing the + -- leading two digits by the leading digit. Given the scaling + -- we did above which ensured the first bit of the divisor is + -- set, this gives an estimate of the quotient that is at most + -- two too high. + + pragma Assert (D (J) <= Zhi); + + if D (J) = Zhi then + Qd (J) := Single_Uns'Last; + else + Qd (J) := Lo ((D (J) & D (J + 1)) / Zhi); + end if; + + -- Compute amount to subtract + + T1 := Qd (J) * Zlo; + T2 := Qd (J) * Zhi; + S3 := Lo (T1); + T3 := Hi (T1) + Lo (T2); + S2 := Lo (T3); + S1 := Hi (T3) + Hi (T2); + + -- Adjust quotient digit if it was too high + + -- We use the version of the algorithm in the 2nd Edition + -- of "The Art of Computer Programming". This had a bug not + -- discovered till 1995, see Vol 2 errata: + -- http://www-cs-faculty.stanford.edu/~uno/err2-2e.ps.gz. + -- Under rare circumstances the expression in the test could + -- overflow. This version was further corrected in 2005, see + -- Vol 2 errata: + -- http://www-cs-faculty.stanford.edu/~uno/all2-pre.ps.gz. + -- This implementation is not impacted by these bugs, due + -- to the use of a word-size comparison done in function Le3 + -- instead of a comparison on two-word integer quantities in + -- the original algorithm. + + while not Le3 (S1, S2, S3, D (J), D (J + 1), D (J + 2)) loop + Sub3 (S1, S2, S3, 0, Zhi, Zlo); + Qd (J) := Qd (J) - 1; end loop; - pragma Assert_And_Cut - (Qd (1)'Initialized and then Qd (2)'Initialized - and then D'Initialized - and then Big_2xxSingle * Big (Double_Uns (D (3))) - + Big (Double_Uns (D (4))) < Big (Zu) - and then Mult * Big_2xx (Scale) = - Big_2xxSingle * Big (Double_Uns (Qd (1))) * Big (Zu) - + Big (Double_Uns (Qd (2))) * Big (Zu) - + Big_2xxSingle * Big (Double_Uns (D (3))) - + Big (Double_Uns (D (4)))); - end; + -- Now subtract S1&S2&S3 from D1&D2&D3 ready for next step + + Sub3 (D (J), D (J + 1), D (J + 2), S1, S2, S3); + end loop; -- The two quotient digits are now set, and the remainder of the -- scaled division is in D3&D4. To get the remainder for the @@ -3321,271 +570,68 @@ is Qu := Qd (1) & Qd (2); Ru := D (3) & D (4); - Lemma_Hi_Lo (Qu, Qd (1), Qd (2)); - Lemma_Hi_Lo (Ru, D (3), D (4)); - Lemma_Substitution - (Mult * Big_2xx (Scale), Big (Zu), - Big_2xxSingle * Big (Double_Uns (Qd (1))) - + Big (Double_Uns (Qd (2))), - Big (Qu), Big (Ru)); - Prove_Rescaling; - Ru := Shift_Right (Ru, Scale); - declare - -- Local lemma required to help automatic provers - procedure Lemma_Div_Congruent - (X, Y : Big_Natural; - Z : Big_Positive) - with - Ghost, - Pre => X = Y, - Post => X / Z = Y / Z; - - procedure Lemma_Div_Congruent - (X, Y : Big_Natural; - Z : Big_Positive) - is null; - - begin - Lemma_Shift_Right (Zu, Scale); - Lemma_Div_Congruent (Big (Zu), - Big (Double_Uns'(abs Z)) * Big_2xx (Scale), - Big_2xx (Scale)); - - Zu := Shift_Right (Zu, Scale); - - Lemma_Simplify (Big (Double_Uns'(abs Z)), Big_2xx (Scale)); - pragma Assert (Big (Zu) = Big (Double_Uns'(abs Z))); - end; + Zu := Shift_Right (Zu, Scale); end if; - pragma Assert (Big (Ru) = abs Big_R); - pragma Assert (Big (Qu) = abs Quot); - pragma Assert (Big (Zu) = Big (Double_Uns'(abs Z))); - -- Deal with rounding case if Round then - Prove_Rounding_Case; - if Ru > (Zu - Double_Uns'(1)) / Double_Uns'(2) then - pragma Assert (abs Big_Q = Big (Qu) + 1); - -- Protect against wrapping around when rounding, by signaling -- an overflow when the quotient is too large. if Qu = Double_Uns'Last then - Prove_Q_Too_Big; Raise_Error; end if; - Lemma_Add_One (Qu); - Qu := Qu + Double_Uns'(1); end if; end if; - pragma Assert (Big (Qu) = abs Big_Q); - -- Set final signs (RM 4.5.5(27-30)) -- Case of dividend (X * Y) sign positive if (X >= 0 and then Y >= 0) or else (X < 0 and then Y < 0) then - Prove_Positive_Dividend; - R := To_Pos_Int (Ru); Q := (if Z > 0 then To_Pos_Int (Qu) else To_Neg_Int (Qu)); -- Case of dividend (X * Y) sign negative else - Prove_Negative_Dividend; - R := To_Neg_Int (Ru); Q := (if Z > 0 then To_Neg_Int (Qu) else To_Pos_Int (Qu)); end if; - - Prove_Sign_R; - Prove_Signs; end Scaled_Divide; - pragma Annotate (Gnatcheck, Exempt_Off, "Metrics_Cyclomatic_Complexity"); ---------- -- Sub3 -- ---------- procedure Sub3 (X1, X2, X3 : in out Single_Uns; Y1, Y2, Y3 : Single_Uns) is - - -- Local ghost variables - - XX1 : constant Single_Uns := X1 with Ghost; - XX2 : constant Single_Uns := X2 with Ghost; - XX3 : constant Single_Uns := X3 with Ghost; - - -- Local lemmas - - procedure Lemma_Add3_No_Carry (X1, X2, X3, Y1, Y2, Y3 : Single_Uns) - with - Ghost, - Pre => X1 <= Single_Uns'Last - Y1 - and then X2 <= Single_Uns'Last - Y2 - and then X3 <= Single_Uns'Last - Y3, - Post => Big3 (X1 + Y1, X2 + Y2, X3 + Y3) - = Big3 (X1, X2, X3) + Big3 (Y1, Y2, Y3); - - procedure Lemma_Ge_Expand (X1, X2, X3, Y1, Y2, Y3 : Single_Uns) - with - Ghost, - Pre => Big3 (X1, X2, X3) >= Big3 (Y1, Y2, Y3), - Post => X1 > Y1 - or else (X1 = Y1 and then X2 > Y2) - or else (X1 = Y1 and then X2 = Y2 and then X3 >= Y3); - - procedure Lemma_Sub3_No_Carry (X1, X2, X3, Y1, Y2, Y3 : Single_Uns) - with - Ghost, - Pre => X1 >= Y1 and then X2 >= Y2 and then X3 >= Y3, - Post => Big3 (X1 - Y1, X2 - Y2, X3 - Y3) - = Big3 (X1, X2, X3) - Big3 (Y1, Y2, Y3); - - procedure Lemma_Sub3_With_Carry2 (X1, X2, X3, Y2 : Single_Uns) - with - Ghost, - Pre => X2 < Y2, - Post => Big3 (X1, X2 - Y2, X3) - = Big3 (X1, X2, X3) + Big3 (Single_Uns'(1), 0, 0) - Big3 (0, Y2, 0); - - procedure Lemma_Sub3_With_Carry3 (X1, X2, X3, Y3 : Single_Uns) - with - Ghost, - Pre => X3 < Y3, - Post => Big3 (X1, X2, X3 - Y3) - = Big3 (X1, X2, X3) + Big3 (Single_Uns'(0), 1, 0) - Big3 (0, 0, Y3); - - ------------------------- - -- Lemma_Add3_No_Carry -- - ------------------------- - - procedure Lemma_Add3_No_Carry (X1, X2, X3, Y1, Y2, Y3 : Single_Uns) is - begin - Lemma_Add_Commutation (Double_Uns (X1), Y1); - Lemma_Add_Commutation (Double_Uns (X2), Y2); - Lemma_Add_Commutation (Double_Uns (X3), Y3); - end Lemma_Add3_No_Carry; - - --------------------- - -- Lemma_Ge_Expand -- - --------------------- - - procedure Lemma_Ge_Expand (X1, X2, X3, Y1, Y2, Y3 : Single_Uns) is null; - - ------------------------- - -- Lemma_Sub3_No_Carry -- - ------------------------- - - procedure Lemma_Sub3_No_Carry (X1, X2, X3, Y1, Y2, Y3 : Single_Uns) is - begin - Lemma_Subtract_Commutation (Double_Uns (X1), Double_Uns (Y1)); - Lemma_Subtract_Commutation (Double_Uns (X2), Double_Uns (Y2)); - Lemma_Subtract_Commutation (Double_Uns (X3), Double_Uns (Y3)); - end Lemma_Sub3_No_Carry; - - ---------------------------- - -- Lemma_Sub3_With_Carry2 -- - ---------------------------- - - procedure Lemma_Sub3_With_Carry2 (X1, X2, X3, Y2 : Single_Uns) is - pragma Unreferenced (X1, X3); - begin - Lemma_Add_Commutation - (Double_Uns'(2 ** Single_Size) - Double_Uns (Y2), X2); - Lemma_Subtract_Commutation - (Double_Uns'(2 ** Single_Size), Double_Uns (Y2)); - end Lemma_Sub3_With_Carry2; - - ---------------------------- - -- Lemma_Sub3_With_Carry3 -- - ---------------------------- - - procedure Lemma_Sub3_With_Carry3 (X1, X2, X3, Y3 : Single_Uns) is - pragma Unreferenced (X1, X2); - begin - Lemma_Add_Commutation - (Double_Uns'(2 ** Single_Size) - Double_Uns (Y3), X3); - Lemma_Subtract_Commutation - (Double_Uns'(2 ** Single_Size), Double_Uns (Y3)); - end Lemma_Sub3_With_Carry3; - - -- Start of processing for Sub3 - begin - Lemma_Ge_Expand (X1, X2, X3, Y1, Y2, Y3); - if Y3 > X3 then if X2 = 0 then pragma Assert (X1 >= 1); - Lemma_Sub3_No_Carry (X1, X2, X3, 1, 0, 0); X1 := X1 - 1; - - pragma Assert - (Big3 (X1, X2, X3) = - Big3 (XX1, XX2, XX3) - Big3 (Single_Uns'(1), 0, 0)); - pragma Assert - (Big3 (X1, X2, X3) = Big3 (XX1, XX2, XX3) - - Big3 (Single_Uns'(0), Single_Uns'Last, 0) - - Big3 (Single_Uns'(0), 1, 0)); - Lemma_Add3_No_Carry (X1, X2, X3, 0, Single_Uns'Last, 0); - else - Lemma_Sub3_No_Carry (X1, X2, X3, 0, 1, 0); end if; X2 := X2 - 1; - - pragma Assert - (Big3 (X1, X2, X3) = - Big3 (XX1, XX2, XX3) - Big3 (Single_Uns'(0), 1, 0)); - Lemma_Sub3_With_Carry3 (X1, X2, X3, Y3); - else - Lemma_Sub3_No_Carry (X1, X2, X3, 0, 0, Y3); end if; X3 := X3 - Y3; - pragma Assert - (Big3 (X1, X2, X3) = Big3 (XX1, XX2, XX3) - Big3 (0, 0, Y3)); - if Y2 > X2 then pragma Assert (X1 >= 1); - Lemma_Sub3_No_Carry (X1, X2, X3, 1, 0, 0); X1 := X1 - 1; - - pragma Assert - (Big3 (X1, X2, X3) = Big3 (XX1, XX2, XX3) - - Big3 (0, 0, Y3) - Big3 (Single_Uns'(1), 0, 0)); - Lemma_Sub3_With_Carry2 (X1, X2, X3, Y2); - else - Lemma_Sub3_No_Carry (X1, X2, X3, 0, Y2, 0); end if; X2 := X2 - Y2; - - pragma Assert - (Big3 (X1, X2, X3) = Big3 (XX1, XX2, XX3) - Big3 (0, Y2, Y3)); - pragma Assert (X1 >= Y1); - Lemma_Sub3_No_Carry (X1, Y2, X3, Y1, 0, 0); - X1 := X1 - Y1; - - pragma Assert - (Big3 (X1, X2, X3) = Big3 (XX1, XX2, XX3) - - Big3 (0, Y2, Y3) - Big3 (Y1, 0, 0)); - Lemma_Add3_No_Carry (0, Y2, Y3, Y1, 0, 0); - pragma Assert - (Big3 (X1, X2, X3) = Big3 (XX1, XX2, XX3) - Big3 (Y1, Y2, Y3)); end Sub3; ------------------------------- @@ -3594,128 +640,18 @@ is function Subtract_With_Ovflo_Check (X, Y : Double_Int) return Double_Int is R : constant Double_Int := To_Int (To_Uns (X) - To_Uns (Y)); - - -- Local lemmas - - procedure Prove_Negative_X - with - Ghost, - Pre => X < 0 and then (Y <= 0 or else R < 0), - Post => R = X - Y; - - procedure Prove_Non_Negative_X - with - Ghost, - Pre => X >= 0 and then (Y > 0 or else R >= 0), - Post => R = X - Y; - - procedure Prove_Overflow_Case - with - Ghost, - Pre => - (if X >= 0 then Y <= 0 and then R < 0 - else Y > 0 and then R >= 0), - Post => not In_Double_Int_Range (Big (X) - Big (Y)); - - ---------------------- - -- Prove_Negative_X -- - ---------------------- - - procedure Prove_Negative_X is - begin - if X = Double_Int'First then - if Y = Double_Int'First or else Y > 0 then - null; - else - pragma Assert - (To_Uns (X) - To_Uns (Y) = - 2 ** (Double_Size - 1) + Double_Uns (-Y)); - end if; - - elsif Y >= 0 or else Y = Double_Int'First then - null; - - else - pragma Assert - (To_Uns (X) - To_Uns (Y) = -Double_Uns (-X) + Double_Uns (-Y)); - end if; - end Prove_Negative_X; - - -------------------------- - -- Prove_Non_Negative_X -- - -------------------------- - - procedure Prove_Non_Negative_X is - begin - if Y > 0 then - declare - Ru : constant Double_Uns := To_Uns (X) - To_Uns (Y); - begin - pragma Assert (Ru = Double_Uns (X) - Double_Uns (Y)); - if Ru < 2 ** (Double_Size - 1) then -- R >= 0 - pragma Assert (To_Uns (Y) <= To_Uns (X)); - Lemma_Subtract_Double_Uns (X => Y, Y => X); - pragma Assert (Ru = Double_Uns (X - Y)); - - elsif Ru = 2 ** (Double_Size - 1) then - pragma Assert (Double_Uns (Y) < 2 ** (Double_Size - 1)); - pragma Assert (False); - - else - pragma Assert - (R = -Double_Int (-(Double_Uns (X) - Double_Uns (Y)))); - pragma Assert - (R = -Double_Int (-Double_Uns (X) + Double_Uns (Y))); - pragma Assert - (R = -Double_Int (Double_Uns (Y) - Double_Uns (X))); - end if; - end; - - elsif Y = Double_Int'First then - pragma Assert - (To_Uns (X) - To_Uns (Y) = - Double_Uns (X) - 2 ** (Double_Size - 1)); - pragma Assert (False); - - else - pragma Assert - (To_Uns (X) - To_Uns (Y) = Double_Uns (X) + Double_Uns (-Y)); - end if; - end Prove_Non_Negative_X; - - ------------------------- - -- Prove_Overflow_Case -- - ------------------------- - - procedure Prove_Overflow_Case is - begin - if X >= 0 and then Y /= Double_Int'First then - pragma Assert - (To_Uns (X) - To_Uns (Y) = Double_Uns (X) + Double_Uns (-Y)); - - elsif X < 0 and then X /= Double_Int'First then - pragma Assert - (To_Uns (X) - To_Uns (Y) = -Double_Uns (-X) - Double_Uns (Y)); - end if; - end Prove_Overflow_Case; - - -- Start of processing for Subtract_With_Ovflo_Check - begin if X >= 0 then if Y > 0 or else R >= 0 then - Prove_Non_Negative_X; return R; end if; else -- X < 0 if Y <= 0 or else R < 0 then - Prove_Negative_X; return R; end if; end if; - Prove_Overflow_Case; Raise_Error; end Subtract_With_Ovflo_Check; @@ -3752,5 +688,3 @@ is pragma Annotate (Gnatcheck, Exempt_Off, "Improper_Returns"); end System.Arith_Double; - -pragma Annotate (Gnatcheck, Exempt_Off, "Metrics_LSLOC"); diff --git a/gcc/ada/libgnat/s-aridou.ads b/gcc/ada/libgnat/s-aridou.ads index 5524cd0..f7240de 100644 --- a/gcc/ada/libgnat/s-aridou.ads +++ b/gcc/ada/libgnat/s-aridou.ads @@ -33,8 +33,6 @@ -- double word signed integer values in cases where either overflow checking -- is required, or intermediate results are longer than the result type. -with Ada.Numerics.Big_Numbers.Big_Integers_Ghost; - generic type Double_Int is range <>; @@ -55,51 +53,7 @@ generic package System.Arith_Double with Pure, SPARK_Mode is - -- Preconditions in this unit are meant for analysis only, not for run-time - -- checking, so that the expected exceptions are raised. This is enforced - -- by setting the corresponding assertion policy to Ignore. Postconditions - -- and contract cases should not be executed at runtime as well, in order - -- not to slow down the execution of these functions. - - pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore); - - package BI_Ghost renames Ada.Numerics.Big_Numbers.Big_Integers_Ghost; - subtype Big_Integer is BI_Ghost.Big_Integer with Ghost; - subtype Big_Natural is BI_Ghost.Big_Natural with Ghost; - subtype Big_Positive is BI_Ghost.Big_Positive with Ghost; - use type BI_Ghost.Big_Integer; - - package Signed_Conversion is - new BI_Ghost.Signed_Conversions (Int => Double_Int); - - function Big (Arg : Double_Int) return Big_Integer is - (Signed_Conversion.To_Big_Integer (Arg)) - with - Ghost, - Annotate => (GNATprove, Inline_For_Proof); - - package Unsigned_Conversion is - new BI_Ghost.Unsigned_Conversions (Int => Double_Uns); - - function Big (Arg : Double_Uns) return Big_Integer is - (Unsigned_Conversion.To_Big_Integer (Arg)) - with - Ghost, - Annotate => (GNATprove, Inline_For_Proof); - - function In_Double_Int_Range (Arg : Big_Integer) return Boolean is - (BI_Ghost.In_Range (Arg, Big (Double_Int'First), Big (Double_Int'Last))) - with - Ghost, - Annotate => (GNATprove, Inline_For_Proof); - - function Add_With_Ovflo_Check (X, Y : Double_Int) return Double_Int - with - Pre => In_Double_Int_Range (Big (X) + Big (Y)), - Post => Add_With_Ovflo_Check'Result = X + Y; + function Add_With_Ovflo_Check (X, Y : Double_Int) return Double_Int; -- Raises Constraint_Error if sum of operands overflows Double_Int, -- otherwise returns this sum of operands as Double_Int. -- @@ -114,10 +68,7 @@ is -- the exception *Constraint_Error* is raised; otherwise the result is -- correct. - function Subtract_With_Ovflo_Check (X, Y : Double_Int) return Double_Int - with - Pre => In_Double_Int_Range (Big (X) - Big (Y)), - Post => Subtract_With_Ovflo_Check'Result = X - Y; + function Subtract_With_Ovflo_Check (X, Y : Double_Int) return Double_Int; -- Raises Constraint_Error if difference of operands overflows Double_Int, -- otherwise returns this difference of operands as Double_Int. -- @@ -127,10 +78,7 @@ is -- overflow. function Multiply_With_Ovflo_Check (X, Y : Double_Int) return Double_Int - with - Pre => In_Double_Int_Range (Big (X) * Big (Y)), - Post => Multiply_With_Ovflo_Check'Result = X * Y; - pragma Convention (C, Multiply_With_Ovflo_Check); + with Convention => C; -- Raises Constraint_Error if product of operands overflows Double_Int, -- otherwise returns this product of operands as Double_Int. The code -- generator may also generate direct calls to this routine. @@ -140,40 +88,10 @@ is -- signed value is returned. Overflow check is performed by looking at -- higher digits. - function Same_Sign (X, Y : Big_Integer) return Boolean is - (X = Big (Double_Int'(0)) - or else Y = Big (Double_Int'(0)) - or else (X < Big (Double_Int'(0))) = (Y < Big (Double_Int'(0)))) - with Ghost; - - function Round_Quotient (X, Y, Q, R : Big_Integer) return Big_Integer is - (if abs R > (abs Y - Big (Double_Int'(1))) / Big (Double_Int'(2)) then - (if Same_Sign (X, Y) then Q + Big (Double_Int'(1)) - else Q - Big (Double_Int'(1))) - else - Q) - with - Ghost, - Pre => Y /= 0 and then Q = X / Y and then R = X rem Y; - procedure Scaled_Divide (X, Y, Z : Double_Int; Q, R : out Double_Int; - Round : Boolean) - with - Pre => Z /= 0 - and then In_Double_Int_Range - (if Round then Round_Quotient (Big (X) * Big (Y), Big (Z), - Big (X) * Big (Y) / Big (Z), - Big (X) * Big (Y) rem Big (Z)) - else Big (X) * Big (Y) / Big (Z)), - Post => Big (R) = Big (X) * Big (Y) rem Big (Z) - and then - (if Round then - Big (Q) = Round_Quotient (Big (X) * Big (Y), Big (Z), - Big (X) * Big (Y) / Big (Z), Big (R)) - else - Big (Q) = Big (X) * Big (Y) / Big (Z)); + Round : Boolean); -- Performs the division of (``X`` * ``Y``) / ``Z``, storing the quotient -- in ``Q`` and the remainder in ``R``. -- @@ -204,22 +122,7 @@ is procedure Double_Divide (X, Y, Z : Double_Int; Q, R : out Double_Int; - Round : Boolean) - with - Pre => Y /= 0 - and then Z /= 0 - and then In_Double_Int_Range - (if Round then Round_Quotient (Big (X), Big (Y) * Big (Z), - Big (X) / (Big (Y) * Big (Z)), - Big (X) rem (Big (Y) * Big (Z))) - else Big (X) / (Big (Y) * Big (Z))), - Post => Big (R) = Big (X) rem (Big (Y) * Big (Z)) - and then - (if Round then - Big (Q) = Round_Quotient (Big (X), Big (Y) * Big (Z), - Big (X) / (Big (Y) * Big (Z)), Big (R)) - else - Big (Q) = Big (X) / (Big (Y) * Big (Z))); + Round : Boolean); -- Performs the division ``X`` / (``Y`` * ``Z``), storing the quotient in -- ``Q`` and the remainder in ``R``. Constraint_Error is raised if ``Y`` or -- ``Z`` is zero, or if the quotient does not fit in ``Double_Int``. diff --git a/gcc/ada/libgnat/s-arit128.adb b/gcc/ada/libgnat/s-arit128.adb index b9fcbd9..c4ef40d 100644 --- a/gcc/ada/libgnat/s-arit128.adb +++ b/gcc/ada/libgnat/s-arit128.adb @@ -34,7 +34,6 @@ with System.Arith_Double; package body System.Arith_128 with SPARK_Mode is - subtype Uns128 is Interfaces.Unsigned_128; subtype Uns64 is Interfaces.Unsigned_64; diff --git a/gcc/ada/libgnat/s-arit128.ads b/gcc/ada/libgnat/s-arit128.ads index 9181f0b..ea4ef6b 100644 --- a/gcc/ada/libgnat/s-arit128.ads +++ b/gcc/ada/libgnat/s-arit128.ads @@ -36,102 +36,31 @@ pragma Restrictions (No_Elaboration_Code); -- Allow direct call from gigi generated code --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced --- by setting the corresponding assertion policy to Ignore. Postconditions --- and contract cases should not be executed at runtime as well, in order --- not to slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore); - -with Ada.Numerics.Big_Numbers.Big_Integers_Ghost; with Interfaces; package System.Arith_128 with Pure, SPARK_Mode is - use type Ada.Numerics.Big_Numbers.Big_Integers_Ghost.Big_Integer; - use type Interfaces.Integer_128; - subtype Int128 is Interfaces.Integer_128; - subtype Big_Integer is - Ada.Numerics.Big_Numbers.Big_Integers_Ghost.Big_Integer - with Ghost; - - package Signed_Conversion is new - Ada.Numerics.Big_Numbers.Big_Integers_Ghost.Signed_Conversions - (Int => Int128); - - function Big (Arg : Int128) return Big_Integer is - (Signed_Conversion.To_Big_Integer (Arg)) - with Ghost; - - function In_Int128_Range (Arg : Big_Integer) return Boolean is - (Ada.Numerics.Big_Numbers.Big_Integers_Ghost.In_Range - (Arg, Big (Int128'First), Big (Int128'Last))) - with Ghost; - - function Add_With_Ovflo_Check128 (X, Y : Int128) return Int128 - with - Pre => In_Int128_Range (Big (X) + Big (Y)), - Post => Add_With_Ovflo_Check128'Result = X + Y; + function Add_With_Ovflo_Check128 (X, Y : Int128) return Int128; -- Raises Constraint_Error if sum of operands overflows 128 bits, -- otherwise returns the 128-bit signed integer sum. - function Subtract_With_Ovflo_Check128 (X, Y : Int128) return Int128 - with - Pre => In_Int128_Range (Big (X) - Big (Y)), - Post => Subtract_With_Ovflo_Check128'Result = X - Y; + function Subtract_With_Ovflo_Check128 (X, Y : Int128) return Int128; -- Raises Constraint_Error if difference of operands overflows 128 -- bits, otherwise returns the 128-bit signed integer difference. - function Multiply_With_Ovflo_Check128 (X, Y : Int128) return Int128 - with - Pre => In_Int128_Range (Big (X) * Big (Y)), - Post => Multiply_With_Ovflo_Check128'Result = X * Y; + function Multiply_With_Ovflo_Check128 (X, Y : Int128) return Int128; pragma Export (C, Multiply_With_Ovflo_Check128, "__gnat_mulv128"); -- Raises Constraint_Error if product of operands overflows 128 -- bits, otherwise returns the 128-bit signed integer product. -- The code generator may also generate direct calls to this routine. - function Same_Sign (X, Y : Big_Integer) return Boolean is - (X = Big (Int128'(0)) - or else Y = Big (Int128'(0)) - or else (X < Big (Int128'(0))) = (Y < Big (Int128'(0)))) - with Ghost; - - function Round_Quotient (X, Y, Q, R : Big_Integer) return Big_Integer is - (if abs R > (abs Y - Big (Int128'(1))) / Big (Int128'(2)) then - (if Same_Sign (X, Y) then Q + Big (Int128'(1)) - else Q - Big (Int128'(1))) - else - Q) - with - Ghost, - Pre => Y /= 0 and then Q = X / Y and then R = X rem Y; - procedure Scaled_Divide128 (X, Y, Z : Int128; Q, R : out Int128; - Round : Boolean) - with - Pre => Z /= 0 - and then In_Int128_Range - (if Round then Round_Quotient (Big (X) * Big (Y), Big (Z), - Big (X) * Big (Y) / Big (Z), - Big (X) * Big (Y) rem Big (Z)) - else Big (X) * Big (Y) / Big (Z)), - Post => Big (R) = Big (X) * Big (Y) rem Big (Z) - and then - (if Round then - Big (Q) = Round_Quotient (Big (X) * Big (Y), Big (Z), - Big (X) * Big (Y) / Big (Z), Big (R)) - else - Big (Q) = Big (X) * Big (Y) / Big (Z)); + Round : Boolean); -- Performs the division of (X * Y) / Z, storing the quotient in Q -- and the remainder in R. Constraint_Error is raised if Z is zero, -- or if the quotient does not fit in 128 bits. Round indicates if @@ -143,22 +72,7 @@ is procedure Double_Divide128 (X, Y, Z : Int128; Q, R : out Int128; - Round : Boolean) - with - Pre => Y /= 0 - and then Z /= 0 - and then In_Int128_Range - (if Round then Round_Quotient (Big (X), Big (Y) * Big (Z), - Big (X) / (Big (Y) * Big (Z)), - Big (X) rem (Big (Y) * Big (Z))) - else Big (X) / (Big (Y) * Big (Z))), - Post => Big (R) = Big (X) rem (Big (Y) * Big (Z)) - and then - (if Round then - Big (Q) = Round_Quotient (Big (X), Big (Y) * Big (Z), - Big (X) / (Big (Y) * Big (Z)), Big (R)) - else - Big (Q) = Big (X) / (Big (Y) * Big (Z))); + Round : Boolean); -- Performs the division X / (Y * Z), storing the quotient in Q and -- the remainder in R. Constraint_Error is raised if Y or Z is zero, -- or if the quotient does not fit in 128 bits. Round indicates if the diff --git a/gcc/ada/libgnat/s-arit32.adb b/gcc/ada/libgnat/s-arit32.adb index 91082e7..0cc88ed 100644 --- a/gcc/ada/libgnat/s-arit32.adb +++ b/gcc/ada/libgnat/s-arit32.adb @@ -34,20 +34,11 @@ -- would be too costly otherwise. This is enforced by setting the assertion -- policy to Ignore. -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Ghost => Ignore, - Loop_Invariant => Ignore, - Assert => Ignore); - -with Ada.Numerics.Big_Numbers.Big_Integers_Ghost; -use Ada.Numerics.Big_Numbers.Big_Integers_Ghost; with Ada.Unchecked_Conversion; package body System.Arith_32 with SPARK_Mode is - pragma Suppress (Overflow_Check); pragma Suppress (Range_Check); @@ -58,33 +49,6 @@ is function To_Int is new Ada.Unchecked_Conversion (Uns32, Int32); - package Unsigned_Conversion is new Unsigned_Conversions (Int => Uns32); - - function Big (Arg : Uns32) return Big_Integer is - (Unsigned_Conversion.To_Big_Integer (Arg)) - with Ghost; - - package Unsigned_Conversion_64 is new Unsigned_Conversions (Int => Uns64); - - function Big (Arg : Uns64) return Big_Integer is - (Unsigned_Conversion_64.To_Big_Integer (Arg)) - with Ghost; - - pragma Warnings - (Off, "non-preelaborable call not allowed in preelaborated unit", - Reason => "Ghost code is not compiled"); - Big_0 : constant Big_Integer := - Big (Uns32'(0)) - with Ghost; - Big_2xx32 : constant Big_Integer := - Big (Uns32'(2 ** 32 - 1)) + 1 - with Ghost; - Big_2xx64 : constant Big_Integer := - Big (Uns64'(2 ** 64 - 1)) + 1 - with Ghost; - pragma Warnings - (On, "non-preelaborable call not allowed in preelaborated unit"); - ----------------------- -- Local Subprograms -- ----------------------- @@ -96,166 +60,23 @@ is -- Convert absolute value of X to unsigned. Note that we can't just use -- the expression of the Else since it overflows for X = Int32'First. - function Lo (A : Uns64) return Uns32 is (Uns32 (A and (2 ** 32 - 1))); - -- Low order half of 64-bit value - function Hi (A : Uns64) return Uns32 is (Uns32 (Shift_Right (A, 32))); -- High order half of 64-bit value - function To_Neg_Int (A : Uns32) return Int32 - with - Pre => In_Int32_Range (-Big (A)), - Post => Big (To_Neg_Int'Result) = -Big (A); + function To_Neg_Int (A : Uns32) return Int32; -- Convert to negative integer equivalent. If the input is in the range -- 0 .. 2**31, then the corresponding nonpositive signed integer (obtained -- by negating the given value) is returned, otherwise constraint error is -- raised. - function To_Pos_Int (A : Uns32) return Int32 - with - Pre => In_Int32_Range (Big (A)), - Post => Big (To_Pos_Int'Result) = Big (A); + function To_Pos_Int (A : Uns32) return Int32; -- Convert to positive integer equivalent. If the input is in the range -- 0 .. 2**31 - 1, then the corresponding nonnegative signed integer is -- returned, otherwise constraint error is raised. - procedure Raise_Error with - Always_Terminates, - Exceptional_Cases => (Constraint_Error => True); - pragma No_Return (Raise_Error); + procedure Raise_Error with No_Return; -- Raise constraint error with appropriate message - ------------------ - -- Local Lemmas -- - ------------------ - - procedure Lemma_Abs_Commutation (X : Int32) - with - Ghost, - Post => abs Big (X) = Big (Uns32'(abs X)); - - procedure Lemma_Abs_Div_Commutation (X, Y : Big_Integer) - with - Ghost, - Pre => Y /= 0, - Post => abs (X / Y) = abs X / abs Y; - - procedure Lemma_Abs_Mult_Commutation (X, Y : Big_Integer) - with - Ghost, - Post => abs (X * Y) = abs X * abs Y; - - procedure Lemma_Abs_Rem_Commutation (X, Y : Big_Integer) - with - Ghost, - Pre => Y /= 0, - Post => abs (X rem Y) = (abs X) rem (abs Y); - - procedure Lemma_Div_Commutation (X, Y : Uns64) - with - Ghost, - Pre => Y /= 0, - Post => Big (X) / Big (Y) = Big (X / Y); - - procedure Lemma_Div_Ge (X, Y, Z : Big_Integer) - with - Ghost, - Pre => Z > 0 and then X >= Y * Z, - Post => X / Z >= Y; - - procedure Lemma_Ge_Commutation (A, B : Uns32) - with - Ghost, - Pre => A >= B, - Post => Big (A) >= Big (B); - - procedure Lemma_Hi_Lo (Xu : Uns64; Xhi, Xlo : Uns32) - with - Ghost, - Pre => Xhi = Hi (Xu) and Xlo = Lo (Xu), - Post => Big (Xu) = Big_2xx32 * Big (Xhi) + Big (Xlo); - - procedure Lemma_Mult_Commutation (X, Y, Z : Uns64) - with - Ghost, - Pre => Big (X) * Big (Y) < Big_2xx64 and then Z = X * Y, - Post => Big (X) * Big (Y) = Big (Z); - - procedure Lemma_Mult_Non_Negative (X, Y : Big_Integer) - with - Ghost, - Pre => (X >= Big_0 and then Y >= Big_0) - or else (X <= Big_0 and then Y <= Big_0), - Post => X * Y >= Big_0; - - procedure Lemma_Mult_Non_Positive (X, Y : Big_Integer) - with - Ghost, - Pre => (X <= Big_0 and then Y >= Big_0) - or else (X >= Big_0 and then Y <= Big_0), - Post => X * Y <= Big_0; - - procedure Lemma_Neg_Rem (X, Y : Big_Integer) - with - Ghost, - Pre => Y /= 0, - Post => X rem Y = X rem (-Y); - - procedure Lemma_Not_In_Range_Big2xx32 - with - Post => not In_Int32_Range (Big_2xx32) - and then not In_Int32_Range (-Big_2xx32); - - procedure Lemma_Rem_Commutation (X, Y : Uns64) - with - Ghost, - Pre => Y /= 0, - Post => Big (X) rem Big (Y) = Big (X rem Y); - - ----------------------------- - -- Local lemma null bodies -- - ----------------------------- - - procedure Lemma_Abs_Commutation (X : Int32) is null; - procedure Lemma_Abs_Div_Commutation (X, Y : Big_Integer) is null; - procedure Lemma_Abs_Mult_Commutation (X, Y : Big_Integer) is null; - procedure Lemma_Div_Commutation (X, Y : Uns64) is null; - procedure Lemma_Div_Ge (X, Y, Z : Big_Integer) is null; - procedure Lemma_Ge_Commutation (A, B : Uns32) is null; - procedure Lemma_Mult_Commutation (X, Y, Z : Uns64) is null; - procedure Lemma_Mult_Non_Negative (X, Y : Big_Integer) is null; - procedure Lemma_Mult_Non_Positive (X, Y : Big_Integer) is null; - procedure Lemma_Neg_Rem (X, Y : Big_Integer) is null; - procedure Lemma_Not_In_Range_Big2xx32 is null; - procedure Lemma_Rem_Commutation (X, Y : Uns64) is null; - - ------------------------------- - -- Lemma_Abs_Rem_Commutation -- - ------------------------------- - - procedure Lemma_Abs_Rem_Commutation (X, Y : Big_Integer) is - begin - if Y < 0 then - Lemma_Neg_Rem (X, Y); - if X < 0 then - pragma Assert (X rem Y = -((-X) rem (-Y))); - pragma Assert (abs (X rem Y) = (abs X) rem (abs Y)); - else - pragma Assert (abs (X rem Y) = (abs X) rem (abs Y)); - end if; - end if; - end Lemma_Abs_Rem_Commutation; - - ----------------- - -- Lemma_Hi_Lo -- - ----------------- - - procedure Lemma_Hi_Lo (Xu : Uns64; Xhi, Xlo : Uns32) is - begin - pragma Assert (Uns64 (Xhi) = Xu / Uns64'(2 ** 32)); - pragma Assert (Uns64 (Xlo) = Xu mod 2 ** 32); - end Lemma_Hi_Lo; - ----------------- -- Raise_Error -- ----------------- @@ -263,9 +84,6 @@ is procedure Raise_Error is begin raise Constraint_Error with "32-bit arithmetic overflow"; - pragma Annotate - (GNATprove, Intentional, "exception might be raised", - "Procedure Raise_Error is called to signal input errors"); end Raise_Error; ------------------- @@ -288,197 +106,20 @@ is Ru : Uns32; -- Unsigned quotient and remainder - -- Local ghost variables - - Mult : constant Big_Integer := abs (Big (X) * Big (Y)) with Ghost; - Quot : Big_Integer with Ghost; - Big_R : Big_Integer with Ghost; - Big_Q : Big_Integer with Ghost; - - -- Local lemmas - - procedure Prove_Negative_Dividend - with - Ghost, - Pre => Z /= 0 - and then ((X >= 0 and Y < 0) or (X < 0 and Y >= 0)) - and then Big_Q = - (if Round then Round_Quotient (Big (X) * Big (Y), Big (Z), - Big (X) * Big (Y) / Big (Z), - Big (X) * Big (Y) rem Big (Z)) - else Big (X) * Big (Y) / Big (Z)), - Post => - (if Z > 0 then Big_Q <= Big_0 else Big_Q >= Big_0); - -- Proves the sign of rounded quotient when dividend is non-positive - - procedure Prove_Overflow - with - Ghost, - Pre => Z /= 0 and then Mult >= Big_2xx32 * Big (Uns32'(abs Z)), - Post => not In_Int32_Range (Big (X) * Big (Y) / Big (Z)) - and then not In_Int32_Range - (Round_Quotient (Big (X) * Big (Y), Big (Z), - Big (X) * Big (Y) / Big (Z), - Big (X) * Big (Y) rem Big (Z))); - -- Proves overflow case - - procedure Prove_Positive_Dividend - with - Ghost, - Pre => Z /= 0 - and then ((X >= 0 and Y >= 0) or (X < 0 and Y < 0)) - and then Big_Q = - (if Round then Round_Quotient (Big (X) * Big (Y), Big (Z), - Big (X) * Big (Y) / Big (Z), - Big (X) * Big (Y) rem Big (Z)) - else Big (X) * Big (Y) / Big (Z)), - Post => - (if Z > 0 then Big_Q >= Big_0 else Big_Q <= Big_0); - -- Proves the sign of rounded quotient when dividend is non-negative - - procedure Prove_Rounding_Case - with - Ghost, - Pre => Z /= 0 - and then Quot = Big (X) * Big (Y) / Big (Z) - and then Big_R = Big (X) * Big (Y) rem Big (Z) - and then Big_Q = - Round_Quotient (Big (X) * Big (Y), Big (Z), Quot, Big_R) - and then Big (Ru) = abs Big_R - and then Big (Zu) = Big (Uns32'(abs Z)), - Post => abs Big_Q = - (if Ru > (Zu - Uns32'(1)) / Uns32'(2) - then abs Quot + 1 - else abs Quot); - -- Proves correctness of the rounding of the unsigned quotient - - procedure Prove_Sign_R - with - Ghost, - Pre => Z /= 0 and then Big_R = Big (X) * Big (Y) rem Big (Z), - Post => In_Int32_Range (Big_R); - - procedure Prove_Signs - with - Ghost, - Pre => Z /= 0 - and then Quot = Big (X) * Big (Y) / Big (Z) - and then Big_R = Big (X) * Big (Y) rem Big (Z) - and then Big_Q = - (if Round then - Round_Quotient (Big (X) * Big (Y), Big (Z), Quot, Big_R) - else Quot) - and then Big (Ru) = abs Big_R - and then Big (Qu) = abs Big_Q - and then In_Int32_Range (Big_Q) - and then In_Int32_Range (Big_R) - and then R = - (if (X >= 0) = (Y >= 0) then To_Pos_Int (Ru) else To_Neg_Int (Ru)) - and then Q = - (if ((X >= 0) = (Y >= 0)) = (Z >= 0) then To_Pos_Int (Qu) - else To_Neg_Int (Qu)), -- need to ensure To_Pos_Int precondition - Post => Big (R) = Big_R and then Big (Q) = Big_Q; - -- Proves final signs match the intended result after the unsigned - -- division is done. - - ----------------------------- - -- Prove_Negative_Dividend -- - ----------------------------- - - procedure Prove_Negative_Dividend is - begin - Lemma_Mult_Non_Positive (Big (X), Big (Y)); - end Prove_Negative_Dividend; - - -------------------- - -- Prove_Overflow -- - -------------------- - - procedure Prove_Overflow is - begin - Lemma_Div_Ge (Mult, Big_2xx32, Big (Uns32'(abs Z))); - Lemma_Abs_Commutation (Z); - Lemma_Abs_Div_Commutation (Big (X) * Big (Y), Big (Z)); - end Prove_Overflow; - - ----------------------------- - -- Prove_Positive_Dividend -- - ----------------------------- - - procedure Prove_Positive_Dividend is - begin - Lemma_Mult_Non_Negative (Big (X), Big (Y)); - end Prove_Positive_Dividend; - - ------------------------- - -- Prove_Rounding_Case -- - ------------------------- - - procedure Prove_Rounding_Case is - begin - if Same_Sign (Big (X) * Big (Y), Big (Z)) then - pragma Assert - (abs Big_Q = - (if Ru > (Zu - Uns32'(1)) / Uns32'(2) - then abs Quot + 1 - else abs Quot)); - end if; - end Prove_Rounding_Case; - - ------------------ - -- Prove_Sign_R -- - ------------------ - - procedure Prove_Sign_R is - begin - pragma Assert (In_Int32_Range (Big (Z))); - end Prove_Sign_R; - - ----------------- - -- Prove_Signs -- - ----------------- - - procedure Prove_Signs is - begin - if (X >= 0) = (Y >= 0) then - pragma Assert (Big (R) = Big_R and then Big (Q) = Big_Q); - else - pragma Assert (Big (R) = Big_R and then Big (Q) = Big_Q); - end if; - end Prove_Signs; - - -- Start of processing for Scaled_Divide32 - begin -- First do the 64-bit multiplication D := Uns64 (Xu) * Uns64 (Yu); - Lemma_Abs_Mult_Commutation (Big (X), Big (Y)); - pragma Assert (Mult = Big (D)); - Lemma_Hi_Lo (D, Hi (D), Lo (D)); - pragma Assert (Mult = Big_2xx32 * Big (Hi (D)) + Big (Lo (D))); - -- If divisor is zero, raise error if Z = 0 then Raise_Error; end if; - Quot := Big (X) * Big (Y) / Big (Z); - Big_R := Big (X) * Big (Y) rem Big (Z); - if Round then - Big_Q := Round_Quotient (Big (X) * Big (Y), Big (Z), Quot, Big_R); - else - Big_Q := Quot; - end if; - -- If dividend is too large, raise error if Hi (D) >= Zu then - Lemma_Ge_Commutation (Hi (D), Zu); - pragma Assert (Mult >= Big_2xx32 * Big (Zu)); - Prove_Overflow; Raise_Error; end if; @@ -487,35 +128,14 @@ is Qu := Uns32 (D / Uns64 (Zu)); Ru := Uns32 (D rem Uns64 (Zu)); - Lemma_Abs_Div_Commutation (Big (X) * Big (Y), Big (Z)); - Lemma_Abs_Rem_Commutation (Big (X) * Big (Y), Big (Z)); - Lemma_Abs_Commutation (X); - Lemma_Abs_Commutation (Y); - Lemma_Abs_Commutation (Z); - Lemma_Mult_Commutation (Uns64 (Xu), Uns64 (Yu), D); - Lemma_Div_Commutation (D, Uns64 (Zu)); - Lemma_Rem_Commutation (D, Uns64 (Zu)); - - pragma Assert (Uns64 (Qu) = D / Uns64 (Zu)); - pragma Assert (Uns64 (Ru) = D rem Uns64 (Zu)); - pragma Assert (Big (Ru) = abs Big_R); - pragma Assert (Big (Qu) = abs Quot); - pragma Assert (Big (Zu) = Big (Uns32'(abs Z))); - -- Deal with rounding case if Round then - Prove_Rounding_Case; - if Ru > (Zu - Uns32'(1)) / Uns32'(2) then - pragma Assert (abs Big_Q = Big (Qu) + 1); - -- Protect against wrapping around when rounding, by signaling -- an overflow when the quotient is too large. if Qu = Uns32'Last then - pragma Assert (abs Big_Q = Big_2xx32); - Lemma_Not_In_Range_Big2xx32; Raise_Error; end if; @@ -523,31 +143,20 @@ is end if; end if; - pragma Assert (In_Int32_Range (Big_Q)); - pragma Assert (Big (Qu) = abs Big_Q); - pragma Assert (Big (Ru) = abs Big_R); - Prove_Sign_R; - -- Set final signs (RM 4.5.5(27-30)) -- Case of dividend (X * Y) sign positive if (X >= 0 and then Y >= 0) or else (X < 0 and then Y < 0) then - Prove_Positive_Dividend; - R := To_Pos_Int (Ru); Q := (if Z > 0 then To_Pos_Int (Qu) else To_Neg_Int (Qu)); -- Case of dividend (X * Y) sign negative else - Prove_Negative_Dividend; - R := To_Neg_Int (Ru); Q := (if Z > 0 then To_Neg_Int (Qu) else To_Pos_Int (Qu)); end if; - - Prove_Signs; end Scaled_Divide32; ---------------- @@ -559,6 +168,7 @@ is (if A = 2**31 then Int32'First else -To_Int (A)); -- Note that we can't just use the expression of the Else, because it -- overflows for A = 2**31. + begin if R <= 0 then return R; diff --git a/gcc/ada/libgnat/s-arit32.ads b/gcc/ada/libgnat/s-arit32.ads index a8abbdc..856dd59 100644 --- a/gcc/ada/libgnat/s-arit32.ads +++ b/gcc/ada/libgnat/s-arit32.ads @@ -33,79 +33,19 @@ -- signed integer values in cases where either overflow checking is -- required, or intermediate results are longer than 32 bits. --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced --- by setting the corresponding assertion policy to Ignore. Postconditions --- and contract cases should not be executed at runtime as well, in order --- not to slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore); - with Interfaces; -with Ada.Numerics.Big_Numbers.Big_Integers_Ghost; package System.Arith_32 with Pure, SPARK_Mode is - use type Ada.Numerics.Big_Numbers.Big_Integers_Ghost.Big_Integer; use type Interfaces.Integer_32; subtype Int32 is Interfaces.Integer_32; - subtype Big_Integer is - Ada.Numerics.Big_Numbers.Big_Integers_Ghost.Big_Integer - with Ghost; - - package Signed_Conversion is new - Ada.Numerics.Big_Numbers.Big_Integers_Ghost.Signed_Conversions - (Int => Int32); - - function Big (Arg : Int32) return Big_Integer is - (Signed_Conversion.To_Big_Integer (Arg)) - with Ghost; - - function In_Int32_Range (Arg : Big_Integer) return Boolean is - (Ada.Numerics.Big_Numbers.Big_Integers_Ghost.In_Range - (Arg, Big (Int32'First), Big (Int32'Last))) - with Ghost; - - function Same_Sign (X, Y : Big_Integer) return Boolean is - (X = Big (Int32'(0)) - or else Y = Big (Int32'(0)) - or else (X < Big (Int32'(0))) = (Y < Big (Int32'(0)))) - with Ghost; - - function Round_Quotient (X, Y, Q, R : Big_Integer) return Big_Integer is - (if abs R > (abs Y - Big (Int32'(1))) / Big (Int32'(2)) then - (if Same_Sign (X, Y) then Q + Big (Int32'(1)) - else Q - Big (Int32'(1))) - else - Q) - with - Ghost, - Pre => Y /= 0 and then Q = X / Y and then R = X rem Y; - procedure Scaled_Divide32 (X, Y, Z : Int32; Q, R : out Int32; - Round : Boolean) - with - Pre => Z /= 0 - and then In_Int32_Range - (if Round then Round_Quotient (Big (X) * Big (Y), Big (Z), - Big (X) * Big (Y) / Big (Z), - Big (X) * Big (Y) rem Big (Z)) - else Big (X) * Big (Y) / Big (Z)), - Post => Big (R) = Big (X) * Big (Y) rem Big (Z) - and then - (if Round then - Big (Q) = Round_Quotient (Big (X) * Big (Y), Big (Z), - Big (X) * Big (Y) / Big (Z), Big (R)) - else - Big (Q) = Big (X) * Big (Y) / Big (Z)); + Round : Boolean); -- Performs the division of (``X`` * ``Y``) / ``Z``, storing the quotient -- in ``Q`` and the remainder in ``R``. -- diff --git a/gcc/ada/libgnat/s-arit64.adb b/gcc/ada/libgnat/s-arit64.adb index 331f328..4e0336f 100644 --- a/gcc/ada/libgnat/s-arit64.adb +++ b/gcc/ada/libgnat/s-arit64.adb @@ -28,14 +28,12 @@ -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ -pragma Assertion_Policy (Ghost => Ignore); with System.Arith_Double; package body System.Arith_64 with SPARK_Mode is - subtype Uns64 is Interfaces.Unsigned_64; subtype Uns32 is Interfaces.Unsigned_32; @@ -52,9 +50,6 @@ is function Multiply_With_Ovflo_Check64 (X, Y : Int64) return Int64 renames Impl.Multiply_With_Ovflo_Check; - function Round_Quotient (X, Y, Q, R : Big_Integer) return Big_Integer - renames Impl.Round_Quotient; - procedure Scaled_Divide64 (X, Y, Z : Int64; Q, R : out Int64; diff --git a/gcc/ada/libgnat/s-arit64.ads b/gcc/ada/libgnat/s-arit64.ads index 2ddd15c..6e12789 100644 --- a/gcc/ada/libgnat/s-arit64.ads +++ b/gcc/ada/libgnat/s-arit64.ads @@ -36,49 +36,14 @@ pragma Restrictions (No_Elaboration_Code); -- Allow direct call from gigi generated code --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced --- by setting the corresponding assertion policy to Ignore. Postconditions --- and contract cases should not be executed at runtime as well, in order --- not to slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore); - -with Ada.Numerics.Big_Numbers.Big_Integers_Ghost; with Interfaces; package System.Arith_64 with Pure, SPARK_Mode is - use type Ada.Numerics.Big_Numbers.Big_Integers_Ghost.Big_Integer; - use type Interfaces.Integer_64; - subtype Int64 is Interfaces.Integer_64; - subtype Big_Integer is - Ada.Numerics.Big_Numbers.Big_Integers_Ghost.Big_Integer - with Ghost; - - package Signed_Conversion is new - Ada.Numerics.Big_Numbers.Big_Integers_Ghost.Signed_Conversions - (Int => Int64); - - function Big (Arg : Int64) return Big_Integer is - (Signed_Conversion.To_Big_Integer (Arg)) - with Ghost; - - function In_Int64_Range (Arg : Big_Integer) return Boolean is - (Ada.Numerics.Big_Numbers.Big_Integers_Ghost.In_Range - (Arg, Big (Int64'First), Big (Int64'Last))) - with Ghost; - - function Add_With_Ovflo_Check64 (X, Y : Int64) return Int64 - with - Pre => In_Int64_Range (Big (X) + Big (Y)), - Post => Add_With_Ovflo_Check64'Result = X + Y; + function Add_With_Ovflo_Check64 (X, Y : Int64) return Int64; -- Raises Constraint_Error if sum of operands overflows 64 bits, -- otherwise returns the 64-bit signed integer sum. -- @@ -93,10 +58,7 @@ is -- the exception *Constraint_Error* is raised; otherwise the result is -- correct. - function Subtract_With_Ovflo_Check64 (X, Y : Int64) return Int64 - with - Pre => In_Int64_Range (Big (X) - Big (Y)), - Post => Subtract_With_Ovflo_Check64'Result = X - Y; + function Subtract_With_Ovflo_Check64 (X, Y : Int64) return Int64; -- Raises Constraint_Error if difference of operands overflows 64 -- bits, otherwise returns the 64-bit signed integer difference. -- @@ -105,10 +67,7 @@ is -- a sign of the result is compared with the sign of ``X`` to check for -- overflow. - function Multiply_With_Ovflo_Check64 (X, Y : Int64) return Int64 - with - Pre => In_Int64_Range (Big (X) * Big (Y)), - Post => Multiply_With_Ovflo_Check64'Result = X * Y; + function Multiply_With_Ovflo_Check64 (X, Y : Int64) return Int64; pragma Export (C, Multiply_With_Ovflo_Check64, "__gnat_mulv64"); -- Raises Constraint_Error if product of operands overflows 64 -- bits, otherwise returns the 64-bit signed integer product. @@ -119,40 +78,10 @@ is -- signed value is returned. Overflow check is performed by looking at -- higher digits. - function Same_Sign (X, Y : Big_Integer) return Boolean is - (X = Big (Int64'(0)) - or else Y = Big (Int64'(0)) - or else (X < Big (Int64'(0))) = (Y < Big (Int64'(0)))) - with Ghost; - - function Round_Quotient (X, Y, Q, R : Big_Integer) return Big_Integer with - Ghost, - Pre => Y /= 0 and then Q = X / Y and then R = X rem Y, - Post => Round_Quotient'Result = - (if abs R > (abs Y - Big (Int64'(1))) / Big (Int64'(2)) then - (if Same_Sign (X, Y) then Q + Big (Int64'(1)) - else Q - Big (Int64'(1))) - else - Q); - procedure Scaled_Divide64 (X, Y, Z : Int64; Q, R : out Int64; - Round : Boolean) - with - Pre => Z /= 0 - and then In_Int64_Range - (if Round then Round_Quotient (Big (X) * Big (Y), Big (Z), - Big (X) * Big (Y) / Big (Z), - Big (X) * Big (Y) rem Big (Z)) - else Big (X) * Big (Y) / Big (Z)), - Post => Big (R) = Big (X) * Big (Y) rem Big (Z) - and then - (if Round then - Big (Q) = Round_Quotient (Big (X) * Big (Y), Big (Z), - Big (X) * Big (Y) / Big (Z), Big (R)) - else - Big (Q) = Big (X) * Big (Y) / Big (Z)); + Round : Boolean); -- Performs the division of (``X`` * ``Y``) / ``Z``, storing the quotient -- in ``Q`` and the remainder in ``R``. -- @@ -189,22 +118,7 @@ is procedure Double_Divide64 (X, Y, Z : Int64; Q, R : out Int64; - Round : Boolean) - with - Pre => Y /= 0 - and then Z /= 0 - and then In_Int64_Range - (if Round then Round_Quotient (Big (X), Big (Y) * Big (Z), - Big (X) / (Big (Y) * Big (Z)), - Big (X) rem (Big (Y) * Big (Z))) - else Big (X) / (Big (Y) * Big (Z))), - Post => Big (R) = Big (X) rem (Big (Y) * Big (Z)) - and then - (if Round then - Big (Q) = Round_Quotient (Big (X), Big (Y) * Big (Z), - Big (X) / (Big (Y) * Big (Z)), Big (R)) - else - Big (Q) = Big (X) / (Big (Y) * Big (Z))); + Round : Boolean); -- Performs the division ``X`` / (``Y`` * ``Z``), storing the quotient in -- ``Q`` and the remainder in ``R``. Constraint_Error is raised if ``Y`` or -- ``Z`` is zero, or if the quotient does not fit in 64-bits. diff --git a/gcc/ada/libgnat/s-casuti.adb b/gcc/ada/libgnat/s-casuti.adb index 58c358c..af98791 100644 --- a/gcc/ada/libgnat/s-casuti.adb +++ b/gcc/ada/libgnat/s-casuti.adb @@ -29,14 +29,6 @@ -- -- ------------------------------------------------------------------------------ --- Ghost code, loop invariants and assertions in this unit are meant for --- analysis only, not for run-time checking, as it would be too costly --- otherwise. This is enforced by setting the assertion policy to Ignore. - -pragma Assertion_Policy (Ghost => Ignore, - Loop_Invariant => Ignore, - Assert => Ignore); - package body System.Case_Util with SPARK_Mode is @@ -62,9 +54,6 @@ is begin for J in A'Range loop A (J) := To_Lower (A (J)); - - pragma Loop_Invariant - (for all K in A'First .. J => A (K) = To_Lower (A'Loop_Entry (K))); end loop; end To_Lower; @@ -90,15 +79,6 @@ is A (J) := To_Lower (A (J)); end if; - pragma Loop_Invariant - (for all K in A'First .. J => - (if K = A'First - or else A'Loop_Entry (K - 1) = '_' - then - A (K) = To_Upper (A'Loop_Entry (K)) - else - A (K) = To_Lower (A'Loop_Entry (K)))); - Ucase := A (J) = '_'; end loop; end To_Mixed; @@ -132,9 +112,6 @@ is begin for J in A'Range loop A (J) := To_Upper (A (J)); - - pragma Loop_Invariant - (for all K in A'First .. J => A (K) = To_Upper (A'Loop_Entry (K))); end loop; end To_Upper; diff --git a/gcc/ada/libgnat/s-exnint.ads b/gcc/ada/libgnat/s-exnint.ads index 3a11f2c..fa46217 100644 --- a/gcc/ada/libgnat/s-exnint.ads +++ b/gcc/ada/libgnat/s-exnint.ads @@ -31,17 +31,6 @@ -- This package implements Integer exponentiation (checks off) --- Preconditions, postconditions, ghost code, loop invariants and assertions --- in this unit are meant for analysis only, not for run-time checking, as it --- would be too costly otherwise. This is enforced by setting the assertion --- policy to Ignore. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Ghost => Ignore, - Loop_Invariant => Ignore, - Assert => Ignore); - with System.Exponn; package System.Exn_Int diff --git a/gcc/ada/libgnat/s-exnlli.ads b/gcc/ada/libgnat/s-exnlli.ads index ba67b76..63c4b88 100644 --- a/gcc/ada/libgnat/s-exnlli.ads +++ b/gcc/ada/libgnat/s-exnlli.ads @@ -31,17 +31,6 @@ -- This package implements Long_Long_Integer exponentiation (checks off) --- Preconditions, postconditions, ghost code, loop invariants and assertions --- in this unit are meant for analysis only, not for run-time checking, as it --- would be too costly otherwise. This is enforced by setting the assertion --- policy to Ignore. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Ghost => Ignore, - Loop_Invariant => Ignore, - Assert => Ignore); - with System.Exponn; package System.Exn_LLI diff --git a/gcc/ada/libgnat/s-exnllli.ads b/gcc/ada/libgnat/s-exnllli.ads index 5ff963c..e94efe0 100644 --- a/gcc/ada/libgnat/s-exnllli.ads +++ b/gcc/ada/libgnat/s-exnllli.ads @@ -31,23 +31,11 @@ -- Long_Long_Long_Integer exponentiation (checks off) --- Preconditions, postconditions, ghost code, loop invariants and assertions --- in this unit are meant for analysis only, not for run-time checking, as it --- would be too costly otherwise. This is enforced by setting the assertion --- policy to Ignore. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Ghost => Ignore, - Loop_Invariant => Ignore, - Assert => Ignore); - with System.Exponn; package System.Exn_LLLI with SPARK_Mode is - package Exponn_Integer is new Exponn (Long_Long_Long_Integer); function Exn_Long_Long_Long_Integer diff --git a/gcc/ada/libgnat/s-expint.ads b/gcc/ada/libgnat/s-expint.ads index a69c8d6..d349330 100644 --- a/gcc/ada/libgnat/s-expint.ads +++ b/gcc/ada/libgnat/s-expint.ads @@ -31,23 +31,11 @@ -- This package implements Integer exponentiation (checks on) --- Preconditions, postconditions, ghost code, loop invariants and assertions --- in this unit are meant for analysis only, not for run-time checking, as it --- would be too costly otherwise. This is enforced by setting the assertion --- policy to Ignore. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Ghost => Ignore, - Loop_Invariant => Ignore, - Assert => Ignore); - with System.Expont; package System.Exp_Int with SPARK_Mode is - package Expont_Integer is new Expont (Integer); function Exp_Integer (Left : Integer; Right : Natural) return Integer diff --git a/gcc/ada/libgnat/s-explli.ads b/gcc/ada/libgnat/s-explli.ads index 9ea38de..af3da9c 100644 --- a/gcc/ada/libgnat/s-explli.ads +++ b/gcc/ada/libgnat/s-explli.ads @@ -31,23 +31,11 @@ -- This package implements Long_Long_Integer exponentiation --- Preconditions, postconditions, ghost code, loop invariants and assertions --- in this unit are meant for analysis only, not for run-time checking, as it --- would be too costly otherwise. This is enforced by setting the assertion --- policy to Ignore. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Ghost => Ignore, - Loop_Invariant => Ignore, - Assert => Ignore); - with System.Expont; package System.Exp_LLI with SPARK_Mode is - package Expont_Integer is new Expont (Long_Long_Integer); function Exp_Long_Long_Integer diff --git a/gcc/ada/libgnat/s-expllli.ads b/gcc/ada/libgnat/s-expllli.ads index 273c33c..ed100b9 100644 --- a/gcc/ada/libgnat/s-expllli.ads +++ b/gcc/ada/libgnat/s-expllli.ads @@ -31,23 +31,11 @@ -- Long_Long_Long_Integer exponentiation (checks on) --- Preconditions, postconditions, ghost code, loop invariants and assertions --- in this unit are meant for analysis only, not for run-time checking, as it --- would be too costly otherwise. This is enforced by setting the assertion --- policy to Ignore. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Ghost => Ignore, - Loop_Invariant => Ignore, - Assert => Ignore); - with System.Expont; package System.Exp_LLLI with SPARK_Mode is - package Expont_Integer is new Expont (Long_Long_Long_Integer); function Exp_Long_Long_Long_Integer diff --git a/gcc/ada/libgnat/s-explllu.ads b/gcc/ada/libgnat/s-explllu.ads index a0b5d47..88aa9af 100644 --- a/gcc/ada/libgnat/s-explllu.ads +++ b/gcc/ada/libgnat/s-explllu.ads @@ -34,24 +34,12 @@ -- The result is always full width, the caller must do a masking operation if -- the modulus is less than 2 ** Long_Long_Long_Unsigned'Size. --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced --- by setting the corresponding assertion policy to Ignore. Postconditions --- and contract cases should not be executed at runtime as well, in order --- not to slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore); - with System.Exponu; with System.Unsigned_Types; package System.Exp_LLLU with SPARK_Mode is - subtype Long_Long_Long_Unsigned is Unsigned_Types.Long_Long_Long_Unsigned; function Exp_Long_Long_Long_Unsigned is diff --git a/gcc/ada/libgnat/s-expllu.ads b/gcc/ada/libgnat/s-expllu.ads index 98fc851..3e2b2a7 100644 --- a/gcc/ada/libgnat/s-expllu.ads +++ b/gcc/ada/libgnat/s-expllu.ads @@ -34,24 +34,12 @@ -- is always full width, the caller must do a masking operation if the -- modulus is less than 2 ** (Long_Long_Unsigned'Size). --- Note: preconditions in this unit are meant for analysis only, not for --- run-time checking, so that the expected exceptions are raised. This is --- enforced by setting the corresponding assertion policy to Ignore. --- Postconditions and contract cases should not be executed at run-time as --- well, in order not to slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore); - with System.Exponu; with System.Unsigned_Types; package System.Exp_LLU with SPARK_Mode is - subtype Long_Long_Unsigned is Unsigned_Types.Long_Long_Unsigned; function Exp_Long_Long_Unsigned is new Exponu (Long_Long_Unsigned); diff --git a/gcc/ada/libgnat/s-expmod.adb b/gcc/ada/libgnat/s-expmod.adb index 28c07a1..16d6b5f 100644 --- a/gcc/ada/libgnat/s-expmod.adb +++ b/gcc/ada/libgnat/s-expmod.adb @@ -29,203 +29,11 @@ -- -- ------------------------------------------------------------------------------ --- Preconditions, postconditions, ghost code, loop invariants and assertions --- in this unit are meant for analysis only, not for run-time checking, as it --- would be too costly otherwise. This is enforced by setting the assertion --- policy to Ignore. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Ghost => Ignore, - Loop_Invariant => Ignore, - Assert => Ignore); - -with Ada.Numerics.Big_Numbers.Big_Integers_Ghost; -use Ada.Numerics.Big_Numbers.Big_Integers_Ghost; - package body System.Exp_Mod with SPARK_Mode is use System.Unsigned_Types; - -- Local lemmas - - procedure Lemma_Add_Mod (X, Y : Big_Natural; B : Big_Positive) - with - Ghost, - Post => (X + Y) mod B = ((X mod B) + (Y mod B)) mod B; - - procedure Lemma_Exp_Expand (A : Big_Integer; Exp : Natural) - with - Ghost, - Post => - (if Exp rem 2 = 0 then - A ** Exp = A ** (Exp / 2) * A ** (Exp / 2) - else - A ** Exp = A ** (Exp / 2) * A ** (Exp / 2) * A); - - procedure Lemma_Exp_Mod (A : Big_Natural; Exp : Natural; B : Big_Positive) - with - Ghost, - Subprogram_Variant => (Decreases => Exp), - Post => ((A mod B) ** Exp) mod B = (A ** Exp) mod B; - - procedure Lemma_Mod_Ident (A : Big_Natural; B : Big_Positive) - with - Ghost, - Pre => A < B, - Post => A mod B = A; - - procedure Lemma_Mod_Mod (A : Big_Integer; B : Big_Positive) - with - Ghost, - Post => A mod B mod B = A mod B; - - procedure Lemma_Mult_Div (X : Big_Natural; Y : Big_Positive) - with - Ghost, - Post => X * Y / Y = X; - - procedure Lemma_Mult_Mod (X, Y : Big_Natural; B : Big_Positive) - with - Ghost, - -- The following subprogram variant can be added as soon as supported - -- Subprogram_Variant => (Decreases => Y), - Post => (X * Y) mod B = ((X mod B) * (Y mod B)) mod B; - - ----------------------------- - -- Local lemma null bodies -- - ----------------------------- - - procedure Lemma_Mod_Ident (A : Big_Natural; B : Big_Positive) is null; - procedure Lemma_Mod_Mod (A : Big_Integer; B : Big_Positive) is null; - procedure Lemma_Mult_Div (X : Big_Natural; Y : Big_Positive) is null; - - ------------------- - -- Lemma_Add_Mod -- - ------------------- - - procedure Lemma_Add_Mod (X, Y : Big_Natural; B : Big_Positive) is - - procedure Lemma_Euclidean_Mod (Q, F, R : Big_Natural) with - Pre => F /= 0, - Post => (Q * F + R) mod F = R mod F, - Subprogram_Variant => (Decreases => Q); - - ------------------------- - -- Lemma_Euclidean_Mod -- - ------------------------- - - procedure Lemma_Euclidean_Mod (Q, F, R : Big_Natural) is - begin - if Q > 0 then - Lemma_Euclidean_Mod (Q - 1, F, R); - end if; - end Lemma_Euclidean_Mod; - - -- Local variables - - Left : constant Big_Natural := (X + Y) mod B; - Right : constant Big_Natural := ((X mod B) + (Y mod B)) mod B; - XQuot : constant Big_Natural := X / B; - YQuot : constant Big_Natural := Y / B; - AQuot : constant Big_Natural := (X mod B + Y mod B) / B; - begin - if Y /= 0 and B > 1 then - pragma Assert (X = XQuot * B + X mod B); - pragma Assert (Y = YQuot * B + Y mod B); - pragma Assert - (Left = ((XQuot + YQuot) * B + X mod B + Y mod B) mod B); - pragma Assert (X mod B + Y mod B = AQuot * B + Right); - pragma Assert (Left = ((XQuot + YQuot + AQuot) * B + Right) mod B); - Lemma_Euclidean_Mod (XQuot + YQuot + AQuot, B, Right); - pragma Assert (Left = (Right mod B)); - pragma Assert (Left = Right); - end if; - end Lemma_Add_Mod; - - ---------------------- - -- Lemma_Exp_Expand -- - ---------------------- - - procedure Lemma_Exp_Expand (A : Big_Integer; Exp : Natural) is - - procedure Lemma_Exp_Distribution (Exp_1, Exp_2 : Natural) with - Pre => Natural'Last - Exp_2 >= Exp_1, - Post => A ** (Exp_1 + Exp_2) = A ** (Exp_1) * A ** (Exp_2); - - ---------------------------- - -- Lemma_Exp_Distribution -- - ---------------------------- - - procedure Lemma_Exp_Distribution (Exp_1, Exp_2 : Natural) is null; - - begin - if Exp rem 2 = 0 then - pragma Assert (Exp = Exp / 2 + Exp / 2); - else - pragma Assert (Exp = Exp / 2 + Exp / 2 + 1); - Lemma_Exp_Distribution (Exp / 2, Exp / 2 + 1); - Lemma_Exp_Distribution (Exp / 2, 1); - end if; - end Lemma_Exp_Expand; - - ------------------- - -- Lemma_Exp_Mod -- - ------------------- - - procedure Lemma_Exp_Mod (A : Big_Natural; Exp : Natural; B : Big_Positive) - is - begin - if Exp /= 0 then - declare - Left : constant Big_Integer := ((A mod B) ** Exp) mod B; - Right : constant Big_Integer := (A ** Exp) mod B; - begin - Lemma_Mult_Mod (A mod B, (A mod B) ** (Exp - 1), B); - Lemma_Mod_Mod (A, B); - Lemma_Exp_Mod (A, Exp - 1, B); - Lemma_Mult_Mod (A, A ** (Exp - 1), B); - pragma Assert - ((A mod B) * (A mod B) ** (Exp - 1) = (A mod B) ** Exp); - pragma Assert (A * A ** (Exp - 1) = A ** Exp); - pragma Assert (Left = Right); - end; - end if; - end Lemma_Exp_Mod; - - -------------------- - -- Lemma_Mult_Mod -- - -------------------- - - procedure Lemma_Mult_Mod (X, Y : Big_Natural; B : Big_Positive) is - Left : constant Big_Natural := (X * Y) mod B; - Right : constant Big_Natural := ((X mod B) * (Y mod B)) mod B; - begin - if Y /= 0 and B > 1 then - Lemma_Add_Mod (X * (Y - 1), X, B); - Lemma_Mult_Mod (X, Y - 1, B); - Lemma_Mod_Mod (X, B); - Lemma_Add_Mod ((X mod B) * ((Y - 1) mod B), X mod B, B); - Lemma_Add_Mod (Y - 1, 1, B); - pragma Assert (((Y - 1) mod B + 1) mod B = Y mod B); - if (Y - 1) mod B + 1 < B then - Lemma_Mod_Ident ((Y - 1) mod B + 1, B); - Lemma_Mod_Mod ((X mod B) * (Y mod B), B); - pragma Assert (Left = Right); - else - pragma Assert (Y mod B = 0); - pragma Assert (Y / B * B = Y); - pragma Assert ((X * Y) mod B = (X * Y) - (X * Y) / B * B); - pragma Assert - ((X * Y) mod B = (X * Y) - (X * (Y / B) * B) / B * B); - Lemma_Mult_Div (X * (Y / B), B); - pragma Assert (Left = 0); - pragma Assert (Left = Right); - end if; - end if; - end Lemma_Mult_Mod; - ----------------- -- Exp_Modular -- ----------------- @@ -241,35 +49,7 @@ is function Mult (X, Y : Unsigned) return Unsigned is (Unsigned (Long_Long_Unsigned (X) * Long_Long_Unsigned (Y) - mod Long_Long_Unsigned (Modulus))) - with - Pre => Modulus /= 0; - -- Modular multiplication. Note that we can't take advantage of the - -- compiler's circuit, because the modulus is not known statically. - - -- Local ghost variables, functions and lemmas - - M : constant Big_Positive := Big (Modulus) with Ghost; - - function Equal_Modulo (X, Y : Big_Integer) return Boolean is - (X mod M = Y mod M) - with - Ghost, - Pre => Modulus /= 0; - - procedure Lemma_Mult (X, Y : Unsigned) - with - Ghost, - Post => Big (Mult (X, Y)) = (Big (X) * Big (Y)) mod M - and then Big (Mult (X, Y)) < M; - - procedure Lemma_Mult (X, Y : Unsigned) is - begin - pragma Assert (Big (Mult (X, Y)) = (Big (X) * Big (Y)) mod M); - end Lemma_Mult; - - Rest : Big_Integer with Ghost; - -- Ghost variable to hold Factor**Exp between Exp and Factor updates + mod Long_Long_Unsigned (Modulus))); begin pragma Assert (Modulus /= 1); @@ -284,72 +64,18 @@ is if Exp /= 0 then loop - pragma Loop_Invariant (Exp > 0); - pragma Loop_Invariant (Result < Modulus); - pragma Loop_Invariant (Equal_Modulo - (Big (Result) * Big (Factor) ** Exp, Big (Left) ** Right)); - pragma Loop_Variant (Decreases => Exp); - if Exp rem 2 /= 0 then - pragma Assert - (Big (Factor) ** Exp - = Big (Factor) * Big (Factor) ** (Exp - 1)); - pragma Assert (Equal_Modulo - ((Big (Result) * Big (Factor)) * Big (Factor) ** (Exp - 1), - Big (Left) ** Right)); - pragma Assert (Big (Factor) >= 0); - Lemma_Mult_Mod (Big (Result) * Big (Factor), - Big (Factor) ** (Exp - 1), - Big (Modulus)); - Lemma_Mult (Result, Factor); - Result := Mult (Result, Factor); - - Lemma_Mod_Ident (Big (Result), Big (Modulus)); - Lemma_Mod_Mod (Big (Factor) ** (Exp - 1), Big (Modulus)); - Lemma_Mult_Mod (Big (Result), - Big (Factor) ** (Exp - 1), - Big (Modulus)); - pragma Assert (Equal_Modulo - (Big (Result) * Big (Factor) ** (Exp - 1), - Big (Left) ** Right)); - Lemma_Exp_Expand (Big (Factor), Exp - 1); - pragma Assert (Exp / 2 = (Exp - 1) / 2); end if; - Lemma_Exp_Expand (Big (Factor), Exp); - Exp := Exp / 2; exit when Exp = 0; - Rest := Big (Factor) ** Exp; - pragma Assert (Equal_Modulo - (Big (Result) * (Rest * Rest), Big (Left) ** Right)); - Lemma_Exp_Mod (Big (Factor) * Big (Factor), Exp, Big (Modulus)); - pragma Assert - ((Big (Factor) * Big (Factor)) ** Exp = Rest * Rest); - pragma Assert (Equal_Modulo - ((Big (Factor) * Big (Factor)) ** Exp, - Rest * Rest)); - Lemma_Mult (Factor, Factor); - Factor := Mult (Factor, Factor); - - Lemma_Mod_Mod (Rest * Rest, Big (Modulus)); - Lemma_Mod_Ident (Big (Result), Big (Modulus)); - Lemma_Mult_Mod (Big (Result), Rest * Rest, Big (Modulus)); - pragma Assert (Big (Factor) >= 0); - Lemma_Mult_Mod (Big (Result), Big (Factor) ** Exp, - Big (Modulus)); - pragma Assert (Equal_Modulo - (Big (Result) * Big (Factor) ** Exp, Big (Left) ** Right)); end loop; - - pragma Assert (Big (Result) = Big (Left) ** Right mod Big (Modulus)); end if; return Result; - end Exp_Modular; end System.Exp_Mod; diff --git a/gcc/ada/libgnat/s-expmod.ads b/gcc/ada/libgnat/s-expmod.ads index 47ba39e..509ffa4 100644 --- a/gcc/ada/libgnat/s-expmod.ads +++ b/gcc/ada/libgnat/s-expmod.ads @@ -36,19 +36,6 @@ -- Note that 1 is a binary modulus (2**0), so the compiler should not (and -- will not) call this function with Modulus equal to 1. --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore); - -with Ada.Numerics.Big_Numbers.Big_Integers_Ghost; - with System.Unsigned_Types; package System.Exp_Mod @@ -57,30 +44,10 @@ is use type System.Unsigned_Types.Unsigned; subtype Unsigned is System.Unsigned_Types.Unsigned; - use type Ada.Numerics.Big_Numbers.Big_Integers_Ghost.Big_Integer; - subtype Big_Integer is - Ada.Numerics.Big_Numbers.Big_Integers_Ghost.Big_Integer - with Ghost; - - package Unsigned_Conversion is - new Ada.Numerics.Big_Numbers.Big_Integers_Ghost.Unsigned_Conversions - (Int => Unsigned); - - function Big (Arg : Unsigned) return Big_Integer is - (Unsigned_Conversion.To_Big_Integer (Arg)) - with Ghost; - - subtype Power_Of_2 is Unsigned with - Dynamic_Predicate => - Power_Of_2 /= 0 and then (Power_Of_2 and (Power_Of_2 - 1)) = 0; - function Exp_Modular (Left : Unsigned; Modulus : Unsigned; - Right : Natural) return Unsigned - with - Pre => Modulus /= 0 and then Modulus not in Power_Of_2, - Post => Big (Exp_Modular'Result) = Big (Left) ** Right mod Big (Modulus); + Right : Natural) return Unsigned; -- Return the power of ``Left`` by ``Right` modulo ``Modulus``. -- -- This function is implemented using the standard logarithmic approach: diff --git a/gcc/ada/libgnat/s-exponn.adb b/gcc/ada/libgnat/s-exponn.adb index ff79f5a..2aeb199 100644 --- a/gcc/ada/libgnat/s-exponn.adb +++ b/gcc/ada/libgnat/s-exponn.adb @@ -32,65 +32,6 @@ package body System.Exponn with SPARK_Mode is - - -- Preconditions, postconditions, ghost code, loop invariants and - -- assertions in this unit are meant for analysis only, not for run-time - -- checking, as it would be too costly otherwise. This is enforced by - -- setting the assertion policy to Ignore. - - pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Ghost => Ignore, - Loop_Invariant => Ignore, - Assert => Ignore); - - -- Local lemmas - - procedure Lemma_Exp_Expand (A : Big_Integer; Exp : Natural) - with - Ghost, - Pre => A /= 0, - Post => - (if Exp rem 2 = 0 then - A ** Exp = A ** (Exp / 2) * A ** (Exp / 2) - else - A ** Exp = A ** (Exp / 2) * A ** (Exp / 2) * A); - - procedure Lemma_Exp_In_Range (A : Big_Integer; Exp : Positive) - with - Ghost, - Pre => In_Int_Range (A ** Exp * A ** Exp), - Post => In_Int_Range (A * A); - - procedure Lemma_Exp_Not_Zero (A : Big_Integer; Exp : Natural) - with - Ghost, - Pre => A /= 0, - Post => A ** Exp /= 0; - - procedure Lemma_Exp_Positive (A : Big_Integer; Exp : Natural) - with - Ghost, - Pre => A /= 0 - and then Exp rem 2 = 0, - Post => A ** Exp > 0; - - procedure Lemma_Mult_In_Range (X, Y, Z : Big_Integer) - with - Ghost, - Pre => Y /= 0 - and then not (X = -Big (Int'First) and Y = -1) - and then X * Y = Z - and then In_Int_Range (Z), - Post => In_Int_Range (X); - - ----------------------------- - -- Local lemma null bodies -- - ----------------------------- - - procedure Lemma_Exp_Not_Zero (A : Big_Integer; Exp : Natural) is null; - procedure Lemma_Mult_In_Range (X, Y, Z : Big_Integer) is null; - ----------- -- Expon -- ----------- @@ -104,13 +45,7 @@ is Factor : Int := Left; Exp : Natural := Right; - Rest : Big_Integer with Ghost; - -- Ghost variable to hold Factor**Exp between Exp and Factor updates - begin - pragma Annotate (Gnatcheck, Exempt_On, "Improper_Returns", - "early returns for performance"); - -- We use the standard logarithmic approach, Exp gets shifted right -- testing successive low order bits and Factor is the value of the -- base raised to the next power of 2. @@ -122,117 +57,31 @@ is -- simpler, so we do it. if Right = 0 then - return 1; + Result := 1; elsif Left = 0 then - return 0; - end if; - - loop - pragma Loop_Invariant (Exp > 0); - pragma Loop_Invariant (Factor /= 0); - pragma Loop_Invariant - (Big (Result) * Big (Factor) ** Exp = Big (Left) ** Right); - pragma Loop_Variant (Decreases => Exp); + Result := 0; + else + loop + if Exp rem 2 /= 0 then + declare + pragma Suppress (Overflow_Check); + begin + Result := Result * Factor; + end; + end if; + + Exp := Exp / 2; + exit when Exp = 0; - if Exp rem 2 /= 0 then declare pragma Suppress (Overflow_Check); begin - pragma Assert - (Big (Factor) ** Exp - = Big (Factor) * Big (Factor) ** (Exp - 1)); - Lemma_Exp_Positive (Big (Factor), Exp - 1); - Lemma_Mult_In_Range (Big (Result) * Big (Factor), - Big (Factor) ** (Exp - 1), - Big (Left) ** Right); - - Result := Result * Factor; + Factor := Factor * Factor; end; - end if; - - Lemma_Exp_Expand (Big (Factor), Exp); - - Exp := Exp / 2; - exit when Exp = 0; - - Rest := Big (Factor) ** Exp; - pragma Assert - (Big (Result) * (Rest * Rest) = Big (Left) ** Right); - - declare - pragma Suppress (Overflow_Check); - begin - Lemma_Mult_In_Range (Rest * Rest, - Big (Result), - Big (Left) ** Right); - Lemma_Exp_In_Range (Big (Factor), Exp); - - Factor := Factor * Factor; - end; - - pragma Assert (Big (Factor) ** Exp = Rest * Rest); - end loop; - - pragma Assert (Big (Result) = Big (Left) ** Right); + end loop; + end if; return Result; - - pragma Annotate (Gnatcheck, Exempt_Off, "Improper_Returns"); end Expon; - ---------------------- - -- Lemma_Exp_Expand -- - ---------------------- - - procedure Lemma_Exp_Expand (A : Big_Integer; Exp : Natural) is - - procedure Lemma_Exp_Distribution (Exp_1, Exp_2 : Natural) with - Pre => A /= 0 and then Natural'Last - Exp_2 >= Exp_1, - Post => A ** (Exp_1 + Exp_2) = A ** (Exp_1) * A ** (Exp_2); - - ---------------------------- - -- Lemma_Exp_Distribution -- - ---------------------------- - - procedure Lemma_Exp_Distribution (Exp_1, Exp_2 : Natural) is null; - - begin - if Exp rem 2 = 0 then - pragma Assert (Exp = Exp / 2 + Exp / 2); - else - pragma Assert (Exp = Exp / 2 + Exp / 2 + 1); - Lemma_Exp_Distribution (Exp / 2, Exp / 2 + 1); - Lemma_Exp_Distribution (Exp / 2, 1); - end if; - end Lemma_Exp_Expand; - - ------------------------ - -- Lemma_Exp_In_Range -- - ------------------------ - - procedure Lemma_Exp_In_Range (A : Big_Integer; Exp : Positive) is - begin - if A /= 0 and Exp /= 1 then - pragma Assert (A ** Exp = A * A ** (Exp - 1)); - Lemma_Mult_In_Range - (A * A, A ** (Exp - 1) * A ** (Exp - 1), A ** Exp * A ** Exp); - end if; - end Lemma_Exp_In_Range; - - ------------------------ - -- Lemma_Exp_Positive -- - ------------------------ - - procedure Lemma_Exp_Positive (A : Big_Integer; Exp : Natural) is - begin - if Exp = 0 then - pragma Assert (A ** Exp = 1); - else - pragma Assert (Exp = 2 * (Exp / 2)); - pragma Assert (A ** Exp = A ** (Exp / 2) * A ** (Exp / 2)); - pragma Assert (A ** Exp = (A ** (Exp / 2)) ** 2); - Lemma_Exp_Not_Zero (A, Exp / 2); - end if; - end Lemma_Exp_Positive; - end System.Exponn; diff --git a/gcc/ada/libgnat/s-exponn.ads b/gcc/ada/libgnat/s-exponn.ads index 16bd393..94da5d2 100644 --- a/gcc/ada/libgnat/s-exponn.ads +++ b/gcc/ada/libgnat/s-exponn.ads @@ -32,44 +32,13 @@ -- This package provides functions for signed integer exponentiation. This -- is the version of the package with checks disabled. -with Ada.Numerics.Big_Numbers.Big_Integers_Ghost; - generic - type Int is range <>; package System.Exponn with Pure, SPARK_Mode is - -- Preconditions in this unit are meant for analysis only, not for run-time - -- checking, so that the expected exceptions are raised. This is enforced - -- by setting the corresponding assertion policy to Ignore. Postconditions - -- and contract cases should not be executed at runtime as well, in order - -- not to slow down the execution of these functions. - - pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore); - - package BI_Ghost renames Ada.Numerics.Big_Numbers.Big_Integers_Ghost; - subtype Big_Integer is BI_Ghost.Big_Integer with Ghost; - use type BI_Ghost.Big_Integer; - - package Signed_Conversion is new BI_Ghost.Signed_Conversions (Int => Int); - - function Big (Arg : Int) return Big_Integer is - (Signed_Conversion.To_Big_Integer (Arg)) - with Ghost; - - function In_Int_Range (Arg : Big_Integer) return Boolean is - (BI_Ghost.In_Range (Arg, Big (Int'First), Big (Int'Last))) - with Ghost; - - function Expon (Left : Int; Right : Natural) return Int - with - Pre => In_Int_Range (Big (Left) ** Right), - Post => Expon'Result = Left ** Right; + function Expon (Left : Int; Right : Natural) return Int; -- Calculate ``Left`` ** ``Right``. If ``Left`` is 0 then 0 is returned -- and if ``Right`` is 0 then 1 is returned. In all other cases the result -- is set to 1 and then computed in a loop as follows: diff --git a/gcc/ada/libgnat/s-expont.adb b/gcc/ada/libgnat/s-expont.adb index 39476a9..368dd0b 100644 --- a/gcc/ada/libgnat/s-expont.adb +++ b/gcc/ada/libgnat/s-expont.adb @@ -32,65 +32,6 @@ package body System.Expont with SPARK_Mode is - - -- Preconditions, postconditions, ghost code, loop invariants and - -- assertions in this unit are meant for analysis only, not for run-time - -- checking, as it would be too costly otherwise. This is enforced by - -- setting the assertion policy to Ignore. - - pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Ghost => Ignore, - Loop_Invariant => Ignore, - Assert => Ignore); - - -- Local lemmas - - procedure Lemma_Exp_Expand (A : Big_Integer; Exp : Natural) - with - Ghost, - Pre => A /= 0, - Post => - (if Exp rem 2 = 0 then - A ** Exp = A ** (Exp / 2) * A ** (Exp / 2) - else - A ** Exp = A ** (Exp / 2) * A ** (Exp / 2) * A); - - procedure Lemma_Exp_In_Range (A : Big_Integer; Exp : Positive) - with - Ghost, - Pre => In_Int_Range (A ** Exp * A ** Exp), - Post => In_Int_Range (A * A); - - procedure Lemma_Exp_Not_Zero (A : Big_Integer; Exp : Natural) - with - Ghost, - Pre => A /= 0, - Post => A ** Exp /= 0; - - procedure Lemma_Exp_Positive (A : Big_Integer; Exp : Natural) - with - Ghost, - Pre => A /= 0 - and then Exp rem 2 = 0, - Post => A ** Exp > 0; - - procedure Lemma_Mult_In_Range (X, Y, Z : Big_Integer) - with - Ghost, - Pre => Y /= 0 - and then not (X = -Big (Int'First) and Y = -1) - and then X * Y = Z - and then In_Int_Range (Z), - Post => In_Int_Range (X); - - ----------------------------- - -- Local lemma null bodies -- - ----------------------------- - - procedure Lemma_Exp_Not_Zero (A : Big_Integer; Exp : Natural) is null; - procedure Lemma_Mult_In_Range (X, Y, Z : Big_Integer) is null; - ----------- -- Expon -- ----------- @@ -104,13 +45,7 @@ is Factor : Int := Left; Exp : Natural := Right; - Rest : Big_Integer with Ghost; - -- Ghost variable to hold Factor**Exp between Exp and Factor updates - begin - pragma Annotate (Gnatcheck, Exempt_On, "Improper_Returns", - "early returns for performance"); - -- We use the standard logarithmic approach, Exp gets shifted right -- testing successive low order bits and Factor is the value of the -- base raised to the next power of 2. @@ -122,117 +57,31 @@ is -- simpler, so we do it. if Right = 0 then - return 1; + Result := 1; elsif Left = 0 then - return 0; - end if; - - loop - pragma Loop_Invariant (Exp > 0); - pragma Loop_Invariant (Factor /= 0); - pragma Loop_Invariant - (Big (Result) * Big (Factor) ** Exp = Big (Left) ** Right); - pragma Loop_Variant (Decreases => Exp); + Result := 0; + else + loop + if Exp rem 2 /= 0 then + declare + pragma Unsuppress (Overflow_Check); + begin + Result := Result * Factor; + end; + end if; + + Exp := Exp / 2; + exit when Exp = 0; - if Exp rem 2 /= 0 then declare pragma Unsuppress (Overflow_Check); begin - pragma Assert - (Big (Factor) ** Exp - = Big (Factor) * Big (Factor) ** (Exp - 1)); - Lemma_Exp_Positive (Big (Factor), Exp - 1); - Lemma_Mult_In_Range (Big (Result) * Big (Factor), - Big (Factor) ** (Exp - 1), - Big (Left) ** Right); - - Result := Result * Factor; + Factor := Factor * Factor; end; - end if; - - Lemma_Exp_Expand (Big (Factor), Exp); - - Exp := Exp / 2; - exit when Exp = 0; - - Rest := Big (Factor) ** Exp; - pragma Assert - (Big (Result) * (Rest * Rest) = Big (Left) ** Right); - - declare - pragma Unsuppress (Overflow_Check); - begin - Lemma_Mult_In_Range (Rest * Rest, - Big (Result), - Big (Left) ** Right); - Lemma_Exp_In_Range (Big (Factor), Exp); - - Factor := Factor * Factor; - end; - - pragma Assert (Big (Factor) ** Exp = Rest * Rest); - end loop; - - pragma Assert (Big (Result) = Big (Left) ** Right); + end loop; + end if; return Result; - - pragma Annotate (Gnatcheck, Exempt_Off, "Improper_Returns"); end Expon; - ---------------------- - -- Lemma_Exp_Expand -- - ---------------------- - - procedure Lemma_Exp_Expand (A : Big_Integer; Exp : Natural) is - - procedure Lemma_Exp_Distribution (Exp_1, Exp_2 : Natural) with - Pre => A /= 0 and then Natural'Last - Exp_2 >= Exp_1, - Post => A ** (Exp_1 + Exp_2) = A ** (Exp_1) * A ** (Exp_2); - - ---------------------------- - -- Lemma_Exp_Distribution -- - ---------------------------- - - procedure Lemma_Exp_Distribution (Exp_1, Exp_2 : Natural) is null; - - begin - if Exp rem 2 = 0 then - pragma Assert (Exp = Exp / 2 + Exp / 2); - else - pragma Assert (Exp = Exp / 2 + Exp / 2 + 1); - Lemma_Exp_Distribution (Exp / 2, Exp / 2 + 1); - Lemma_Exp_Distribution (Exp / 2, 1); - end if; - end Lemma_Exp_Expand; - - ------------------------ - -- Lemma_Exp_In_Range -- - ------------------------ - - procedure Lemma_Exp_In_Range (A : Big_Integer; Exp : Positive) is - begin - if A /= 0 and Exp /= 1 then - pragma Assert (A ** Exp = A * A ** (Exp - 1)); - Lemma_Mult_In_Range - (A * A, A ** (Exp - 1) * A ** (Exp - 1), A ** Exp * A ** Exp); - end if; - end Lemma_Exp_In_Range; - - ------------------------ - -- Lemma_Exp_Positive -- - ------------------------ - - procedure Lemma_Exp_Positive (A : Big_Integer; Exp : Natural) is - begin - if Exp = 0 then - pragma Assert (A ** Exp = 1); - else - pragma Assert (Exp = 2 * (Exp / 2)); - pragma Assert (A ** Exp = A ** (Exp / 2) * A ** (Exp / 2)); - pragma Assert (A ** Exp = (A ** (Exp / 2)) ** 2); - Lemma_Exp_Not_Zero (A, Exp / 2); - end if; - end Lemma_Exp_Positive; - end System.Expont; diff --git a/gcc/ada/libgnat/s-expont.ads b/gcc/ada/libgnat/s-expont.ads index 880e054..2cf6dc0 100644 --- a/gcc/ada/libgnat/s-expont.ads +++ b/gcc/ada/libgnat/s-expont.ads @@ -32,44 +32,13 @@ -- This package provides functions for signed integer exponentiation. This -- is the version of the package with checks enabled. -with Ada.Numerics.Big_Numbers.Big_Integers_Ghost; - generic - type Int is range <>; package System.Expont with Pure, SPARK_Mode is - -- Preconditions in this unit are meant for analysis only, not for run-time - -- checking, so that the expected exceptions are raised. This is enforced - -- by setting the corresponding assertion policy to Ignore. Postconditions - -- and contract cases should not be executed at runtime as well, in order - -- not to slow down the execution of these functions. - - pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore); - - package BI_Ghost renames Ada.Numerics.Big_Numbers.Big_Integers_Ghost; - subtype Big_Integer is BI_Ghost.Big_Integer with Ghost; - use type BI_Ghost.Big_Integer; - - package Signed_Conversion is new BI_Ghost.Signed_Conversions (Int => Int); - - function Big (Arg : Int) return Big_Integer is - (Signed_Conversion.To_Big_Integer (Arg)) - with Ghost; - - function In_Int_Range (Arg : Big_Integer) return Boolean is - (BI_Ghost.In_Range (Arg, Big (Int'First), Big (Int'Last))) - with Ghost; - - function Expon (Left : Int; Right : Natural) return Int - with - Pre => In_Int_Range (Big (Left) ** Right), - Post => Expon'Result = Left ** Right; + function Expon (Left : Int; Right : Natural) return Int; -- Calculate ``Left`` ** ``Right``. If ``Left`` is 0 then 0 is returned -- and if ``Right`` is 0 then 1 is returned. In all other cases the result -- is set to 1 and then computed in a loop as follows: diff --git a/gcc/ada/libgnat/s-exponu.adb b/gcc/ada/libgnat/s-exponu.adb index abb1930..0c52833 100644 --- a/gcc/ada/libgnat/s-exponu.adb +++ b/gcc/ada/libgnat/s-exponu.adb @@ -29,20 +29,7 @@ -- -- ------------------------------------------------------------------------------ -function System.Exponu (Left : Int; Right : Natural) return Int - with SPARK_Mode -is - -- Preconditions, postconditions, ghost code, loop invariants and - -- assertions in this unit are meant for analysis only, not for run-time - -- checking, as it would be too costly otherwise. This is enforced by - -- setting the assertion policy to Ignore. - - pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Ghost => Ignore, - Loop_Invariant => Ignore, - Assert => Ignore); - +function System.Exponu (Left : Int; Right : Natural) return Int is -- Note that negative exponents get a constraint error because the -- subtype of the Right argument (the exponent) is Natural. @@ -61,16 +48,7 @@ begin if Exp /= 0 then loop - pragma Loop_Invariant (Exp > 0); - pragma Loop_Invariant (Result * Factor ** Exp = Left ** Right); - pragma Loop_Variant (Decreases => Exp); - if Exp rem 2 /= 0 then - pragma Assert - (Result * (Factor * Factor ** (Exp - 1)) = Left ** Right); - pragma Assert - ((Result * Factor) * Factor ** (Exp - 1) = Left ** Right); - Result := Result * Factor; end if; diff --git a/gcc/ada/libgnat/s-exponu.ads b/gcc/ada/libgnat/s-exponu.ads index cfa6d78..7cc2f9c 100644 --- a/gcc/ada/libgnat/s-exponu.ads +++ b/gcc/ada/libgnat/s-exponu.ads @@ -31,25 +31,10 @@ -- This function implements unsigned integer exponentiation --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced --- by setting the corresponding assertion policy to Ignore. Postconditions --- and contract cases should not be executed at runtime as well, in order --- not to slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore); - generic - type Int is mod <>; -function System.Exponu (Left : Int; Right : Natural) return Int -with - SPARK_Mode, - Post => System.Exponu'Result = Left ** Right; +function System.Exponu (Left : Int; Right : Natural) return Int; -- Calculate ``Left`` ** ``Right``. If ``Left`` is 0 then 0 is returned -- and if ``Right`` is 0 then 1 is returned. In all other cases the result -- is set to 1 and then computed in a loop as follows: diff --git a/gcc/ada/libgnat/s-expuns.ads b/gcc/ada/libgnat/s-expuns.ads index 98ad607..d1dcc25 100644 --- a/gcc/ada/libgnat/s-expuns.ads +++ b/gcc/ada/libgnat/s-expuns.ads @@ -35,24 +35,12 @@ -- The result is always full width, the caller must do a masking operation -- the modulus is less than 2 ** (Unsigned'Size). --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced --- by setting the corresponding assertion policy to Ignore. Postconditions --- and contract cases should not be executed at runtime as well, in order --- not to slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore); - with System.Exponu; with System.Unsigned_Types; package System.Exp_Uns with SPARK_Mode is - subtype Unsigned is Unsigned_Types.Unsigned; function Exp_Unsigned is new Exponu (Unsigned); diff --git a/gcc/ada/libgnat/s-imaged.adb b/gcc/ada/libgnat/s-imaged.adb index 34c15b0..638e37b 100644 --- a/gcc/ada/libgnat/s-imaged.adb +++ b/gcc/ada/libgnat/s-imaged.adb @@ -31,33 +31,10 @@ with System.Image_I; with System.Img_Util; use System.Img_Util; -with System.Value_I_Spec; -with System.Value_U_Spec; package body System.Image_D is - -- Contracts, ghost code, loop invariants and assertions in this unit are - -- meant for analysis only, not for run-time checking, as it would be too - -- costly otherwise. This is enforced by setting the assertion policy to - -- Ignore. - - pragma Assertion_Policy (Assert => Ignore, - Assert_And_Cut => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore, - Loop_Invariant => Ignore, - Pre => Ignore, - Post => Ignore, - Subprogram_Variant => Ignore); - - package Uns_Spec is new System.Value_U_Spec (Uns); - package Int_Spec is new System.Value_I_Spec (Int, Uns, Uns_Spec); - - package Image_I is new System.Image_I - (Int => Int, - Uns => Uns, - U_Spec => Uns_Spec, - I_Spec => Int_Spec); + package Image_I is new System.Image_I (Int); procedure Set_Image_Integer (V : Int; @@ -76,7 +53,6 @@ package body System.Image_D is Scale : Integer) is pragma Assert (S'First = 1); - begin -- Add space at start for non-negative numbers diff --git a/gcc/ada/libgnat/s-imaged.ads b/gcc/ada/libgnat/s-imaged.ads index 1b83a67..48d4b00 100644 --- a/gcc/ada/libgnat/s-imaged.ads +++ b/gcc/ada/libgnat/s-imaged.ads @@ -34,10 +34,7 @@ -- types. generic - type Int is range <>; - type Uns is mod <>; - package System.Image_D is procedure Image_Decimal diff --git a/gcc/ada/libgnat/s-imagef.adb b/gcc/ada/libgnat/s-imagef.adb index 00b4ac5..c84f424 100644 --- a/gcc/ada/libgnat/s-imagef.adb +++ b/gcc/ada/libgnat/s-imagef.adb @@ -31,25 +31,9 @@ with System.Image_I; with System.Img_Util; use System.Img_Util; -with System.Value_I_Spec; -with System.Value_U_Spec; package body System.Image_F is - -- Contracts, ghost code, loop invariants and assertions in this unit are - -- meant for analysis only, not for run-time checking, as it would be too - -- costly otherwise. This is enforced by setting the assertion policy to - -- Ignore. - - pragma Assertion_Policy (Assert => Ignore, - Assert_And_Cut => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore, - Loop_Invariant => Ignore, - Pre => Ignore, - Post => Ignore, - Subprogram_Variant => Ignore); - Maxdigs : constant Natural := Int'Width - 2; -- Maximum number of decimal digits that can be represented in an Int. -- The "-2" accounts for the sign and one extra digit, since we need the @@ -70,14 +54,7 @@ package body System.Image_F is -- if the small is larger than 1, and smaller than 2**(Int'Size - 1) / 10 -- if the small is smaller than 1. - package Uns_Spec is new System.Value_U_Spec (Uns); - package Int_Spec is new System.Value_I_Spec (Int, Uns, Uns_Spec); - - package Image_I is new System.Image_I - (Int => Int, - Uns => Uns, - U_Spec => Uns_Spec, - I_Spec => Int_Spec); + package Image_I is new System.Image_I (Int); procedure Set_Image_Integer (V : Int; @@ -233,7 +210,6 @@ package body System.Image_F is Aft0 : Natural) is pragma Assert (S'First = 1); - begin -- Add space at start for non-negative numbers diff --git a/gcc/ada/libgnat/s-imagef.ads b/gcc/ada/libgnat/s-imagef.ads index fea63c6..f73eed8 100644 --- a/gcc/ada/libgnat/s-imagef.ads +++ b/gcc/ada/libgnat/s-imagef.ads @@ -34,9 +34,7 @@ -- point types whose Small is the ratio of two Int values. generic - type Int is range <>; - type Uns is mod <>; with procedure Scaled_Divide (X, Y, Z : Int; diff --git a/gcc/ada/libgnat/s-imagei.adb b/gcc/ada/libgnat/s-imagei.adb index e6aaf83..0f2211b 100644 --- a/gcc/ada/libgnat/s-imagei.adb +++ b/gcc/ada/libgnat/s-imagei.adb @@ -29,106 +29,18 @@ -- -- ------------------------------------------------------------------------------ -with Ada.Numerics.Big_Numbers.Big_Integers_Ghost; -use Ada.Numerics.Big_Numbers.Big_Integers_Ghost; - -with System.Val_Spec; - package body System.Image_I is - -- Ghost code, loop invariants and assertions in this unit are meant for - -- analysis only, not for run-time checking, as it would be too costly - -- otherwise. This is enforced by setting the assertion policy to Ignore. - - pragma Assertion_Policy (Ghost => Ignore, - Loop_Invariant => Ignore, - Assert => Ignore, - Assert_And_Cut => Ignore, - Pre => Ignore, - Post => Ignore, - Subprogram_Variant => Ignore); - subtype Non_Positive is Int range Int'First .. 0; - function Uns_Of_Non_Positive (T : Non_Positive) return Uns is - (if T = Int'First then Uns (Int'Last) + 1 else Uns (-T)); - procedure Set_Digits (T : Non_Positive; S : in out String; - P : in out Natural) - with - Pre => P < Integer'Last - and then S'Last < Integer'Last - and then S'First <= P + 1 - and then S'First <= S'Last - and then P <= S'Last - Unsigned_Width_Ghost + 1, - Post => S (S'First .. P'Old) = S'Old (S'First .. P'Old) - and then P in P'Old + 1 .. S'Last - and then UP.Only_Decimal_Ghost (S, From => P'Old + 1, To => P) - and then UP.Scan_Based_Number_Ghost (S, From => P'Old + 1, To => P) - = UP.Wrap_Option (Uns_Of_Non_Positive (T)); + P : in out Natural); -- Set digits of absolute value of T, which is zero or negative. We work -- with the negative of the value so that the largest negative number is -- not a special case. - package Unsigned_Conversion is new Unsigned_Conversions (Int => Uns); - - function Big (Arg : Uns) return Big_Integer renames - Unsigned_Conversion.To_Big_Integer; - - function From_Big (Arg : Big_Integer) return Uns renames - Unsigned_Conversion.From_Big_Integer; - - Big_10 : constant Big_Integer := Big (10) with Ghost; - - ------------------ - -- Local Lemmas -- - ------------------ - - procedure Lemma_Non_Zero (X : Uns) - with - Ghost, - Pre => X /= 0, - Post => Big (X) /= 0; - - procedure Lemma_Div_Commutation (X, Y : Uns) - with - Ghost, - Pre => Y /= 0, - Post => Big (X) / Big (Y) = Big (X / Y); - - procedure Lemma_Div_Twice (X : Big_Natural; Y, Z : Big_Positive) - with - Ghost, - Post => X / Y / Z = X / (Y * Z); - - --------------------------- - -- Lemma_Div_Commutation -- - --------------------------- - - procedure Lemma_Non_Zero (X : Uns) is null; - procedure Lemma_Div_Commutation (X, Y : Uns) is null; - - --------------------- - -- Lemma_Div_Twice -- - --------------------- - - procedure Lemma_Div_Twice (X : Big_Natural; Y, Z : Big_Positive) is - XY : constant Big_Natural := X / Y; - YZ : constant Big_Natural := Y * Z; - XYZ : constant Big_Natural := X / Y / Z; - R : constant Big_Natural := (XY rem Z) * Y + (X rem Y); - begin - pragma Assert (X = XY * Y + (X rem Y)); - pragma Assert (XY = XY / Z * Z + (XY rem Z)); - pragma Assert (X = XYZ * YZ + R); - pragma Assert ((XY rem Z) * Y <= (Z - 1) * Y); - pragma Assert (R <= YZ - 1); - pragma Assert (X / YZ = (XYZ * YZ + R) / YZ); - pragma Assert (X / YZ = XYZ + R / YZ); - end Lemma_Div_Twice; - ------------------- -- Image_Integer -- ------------------- @@ -139,44 +51,6 @@ package body System.Image_I is P : out Natural) is pragma Assert (S'First = 1); - - procedure Prove_Value_Integer - with - Ghost, - Pre => S'First = 1 - and then S'Last < Integer'Last - and then P in 2 .. S'Last - and then S (1) in ' ' | '-' - and then (S (1) = '-') = (V < 0) - and then UP.Only_Decimal_Ghost (S, From => 2, To => P) - and then UP.Scan_Based_Number_Ghost (S, From => 2, To => P) - = UP.Wrap_Option (IP.Abs_Uns_Of_Int (V)), - Post => not System.Val_Spec.Only_Space_Ghost (S, 1, P) - and then IP.Is_Integer_Ghost (S (1 .. P)) - and then IP.Is_Value_Integer_Ghost (S (1 .. P), V); - -- Ghost lemma to prove the value of Value_Integer from the value of - -- Scan_Based_Number_Ghost and the sign on a decimal string. - - ------------------------- - -- Prove_Value_Integer -- - ------------------------- - - procedure Prove_Value_Integer is - Str : constant String := S (1 .. P); - begin - pragma Assert (Str'First = 1); - pragma Assert (Str (2) /= ' '); - pragma Assert - (UP.Only_Decimal_Ghost (Str, From => 2, To => P)); - UP.Prove_Scan_Based_Number_Ghost_Eq (S, Str, From => 2, To => P); - pragma Assert - (UP.Scan_Based_Number_Ghost (Str, From => 2, To => P) - = UP.Wrap_Option (IP.Abs_Uns_Of_Int (V))); - IP.Prove_Scan_Only_Decimal_Ghost (Str, V); - end Prove_Value_Integer; - - -- Start of processing for Image_Integer - begin if V >= 0 then pragma Annotate (CodePeer, False_Positive, "test always false", @@ -190,18 +64,7 @@ package body System.Image_I is pragma Assert (P < S'Last - 1); end if; - declare - P_Prev : constant Integer := P with Ghost; - Offset : constant Positive := (if V >= 0 then 1 else 2) with Ghost; - begin - Set_Image_Integer (V, S, P); - - pragma Assert (P_Prev + Offset = 2); - end; - pragma Assert (if V >= 0 then S (1) = ' '); - pragma Assert (S (1) in ' ' | '-'); - - Prove_Value_Integer; + Set_Image_Integer (V, S, P); end Image_Integer; ---------------- @@ -215,136 +78,6 @@ package body System.Image_I is is Nb_Digits : Natural := 0; Value : Non_Positive := T; - - -- Local ghost variables - - Pow : Big_Positive := 1 with Ghost; - S_Init : constant String := S with Ghost; - Uns_T : constant Uns := Uns_Of_Non_Positive (T) with Ghost; - Uns_Value : Uns := Uns_Of_Non_Positive (Value) with Ghost; - Prev_Value : Uns with Ghost; - Prev_S : String := S with Ghost; - - -- Local ghost lemmas - - procedure Prove_Character_Val (RU : Uns; RI : Non_Positive) - with - Ghost, - Post => RU rem 10 in 0 .. 9 - and then -(RI rem 10) in 0 .. 9 - and then Character'Val (48 + RU rem 10) in '0' .. '9' - and then Character'Val (48 - RI rem 10) in '0' .. '9'; - -- Ghost lemma to prove the value of a character corresponding to the - -- next figure. - - procedure Prove_Euclidian (Val, Quot, Rest : Uns) - with - Ghost, - Pre => Quot = Val / 10 - and then Rest = Val rem 10, - Post => Uns'Last - Rest >= 10 * Quot and then Val = 10 * Quot + Rest; - -- Ghost lemma to prove the relation between the quotient/remainder of - -- division by 10 and the initial value. - - procedure Prove_Hexa_To_Unsigned_Ghost (RU : Uns; RI : Int) - with - Ghost, - Pre => RU in 0 .. 9 - and then RI in 0 .. 9, - Post => UP.Hexa_To_Unsigned_Ghost - (Character'Val (48 + RU)) = RU - and then UP.Hexa_To_Unsigned_Ghost - (Character'Val (48 + RI)) = Uns (RI); - -- Ghost lemma to prove that Hexa_To_Unsigned_Ghost returns the source - -- figure when applied to the corresponding character. - - procedure Prove_Scan_Iter - (S, Prev_S : String; - V, Prev_V, Res : Uns; - P, Max : Natural) - with - Ghost, - Pre => - S'First = Prev_S'First and then S'Last = Prev_S'Last - and then S'Last < Natural'Last and then - Max in S'Range and then P in S'First .. Max and then - (for all I in P + 1 .. Max => Prev_S (I) in '0' .. '9') - and then (for all I in P + 1 .. Max => Prev_S (I) = S (I)) - and then S (P) in '0' .. '9' - and then V <= Uns'Last / 10 - and then Uns'Last - UP.Hexa_To_Unsigned_Ghost (S (P)) - >= 10 * V - and then Prev_V = - V * 10 + UP.Hexa_To_Unsigned_Ghost (S (P)) - and then - (if P = Max then Prev_V = Res - else UP.Scan_Based_Number_Ghost - (Str => Prev_S, - From => P + 1, - To => Max, - Base => 10, - Acc => Prev_V) = UP.Wrap_Option (Res)), - Post => - (for all I in P .. Max => S (I) in '0' .. '9') - and then UP.Scan_Based_Number_Ghost - (Str => S, - From => P, - To => Max, - Base => 10, - Acc => V) = UP.Wrap_Option (Res); - -- Ghost lemma to prove that Scan_Based_Number_Ghost is preserved - -- through an iteration of the loop. - - procedure Prove_Uns_Of_Non_Positive_Value - with - Ghost, - Pre => Uns_Value = Uns_Of_Non_Positive (Value), - Post => Uns_Value / 10 = Uns_Of_Non_Positive (Value / 10) - and then Uns_Value rem 10 = Uns_Of_Non_Positive (Value rem 10); - -- Ghost lemma to prove that the relation between Value and its unsigned - -- version is preserved. - - ----------------------------- - -- Local lemma null bodies -- - ----------------------------- - - procedure Prove_Character_Val (RU : Uns; RI : Non_Positive) is null; - procedure Prove_Euclidian (Val, Quot, Rest : Uns) is null; - procedure Prove_Hexa_To_Unsigned_Ghost (RU : Uns; RI : Int) is null; - procedure Prove_Uns_Of_Non_Positive_Value is null; - - --------------------- - -- Prove_Scan_Iter -- - --------------------- - - procedure Prove_Scan_Iter - (S, Prev_S : String; - V, Prev_V, Res : Uns; - P, Max : Natural) - is - pragma Unreferenced (Res); - begin - UP.Lemma_Scan_Based_Number_Ghost_Step - (Str => S, - From => P, - To => Max, - Base => 10, - Acc => V); - if P < Max then - UP.Prove_Scan_Based_Number_Ghost_Eq - (Prev_S, S, P + 1, Max, 10, Prev_V); - else - UP.Lemma_Scan_Based_Number_Ghost_Base - (Str => S, - From => P + 1, - To => Max, - Base => 10, - Acc => Prev_V); - end if; - end Prove_Scan_Iter; - - -- Start of processing for Set_Digits - begin pragma Assert (P >= S'First - 1 and P < S'Last); -- No check is done since, as documented in the Set_Image_Integer @@ -354,90 +87,20 @@ package body System.Image_I is -- First we compute the number of characters needed for representing -- the number. loop - Lemma_Div_Commutation (Uns_Of_Non_Positive (Value), 10); - Lemma_Div_Twice (Big (Uns_Of_Non_Positive (T)), - Big_10 ** Nb_Digits, Big_10); - Prove_Uns_Of_Non_Positive_Value; - Value := Value / 10; Nb_Digits := Nb_Digits + 1; - Uns_Value := Uns_Value / 10; - Pow := Pow * 10; - - pragma Loop_Invariant (Uns_Value = Uns_Of_Non_Positive (Value)); - pragma Loop_Invariant (Nb_Digits in 1 .. Unsigned_Width_Ghost - 1); - pragma Loop_Invariant (Pow = Big_10 ** Nb_Digits); - pragma Loop_Invariant (Big (Uns_Value) = Big (Uns_T) / Pow); - pragma Loop_Variant (Increases => Value); - exit when Value = 0; - - Lemma_Non_Zero (Uns_Value); - pragma Assert (Pow <= Big (Uns'Last)); end loop; Value := T; - Uns_Value := Uns_Of_Non_Positive (T); - Pow := 1; - - pragma Assert (Uns_Value = From_Big (Big (Uns_T) / Big_10 ** 0)); -- We now populate digits from the end of the string to the beginning for J in reverse 1 .. Nb_Digits loop - Lemma_Div_Commutation (Uns_Value, 10); - Lemma_Div_Twice (Big (Uns_T), Big_10 ** (Nb_Digits - J), Big_10); - Prove_Character_Val (Uns_Value, Value); - Prove_Hexa_To_Unsigned_Ghost (Uns_Value rem 10, -(Value rem 10)); - Prove_Uns_Of_Non_Positive_Value; - - Prev_Value := Uns_Value; - Prev_S := S; - Pow := Pow * 10; - Uns_Value := Uns_Value / 10; - S (P + J) := Character'Val (48 - (Value rem 10)); Value := Value / 10; - - Prove_Euclidian - (Val => Prev_Value, - Quot => Uns_Value, - Rest => UP.Hexa_To_Unsigned_Ghost (S (P + J))); - - Prove_Scan_Iter - (S, Prev_S, Uns_Value, Prev_Value, Uns_T, P + J, P + Nb_Digits); - - pragma Loop_Invariant (Uns_Value = Uns_Of_Non_Positive (Value)); - pragma Loop_Invariant (Uns_Value <= Uns'Last / 10); - pragma Loop_Invariant - (for all K in S'First .. P => S (K) = S_Init (K)); - pragma Loop_Invariant - (UP.Only_Decimal_Ghost (S, P + J, P + Nb_Digits)); - pragma Loop_Invariant - (for all K in P + J .. P + Nb_Digits => S (K) in '0' .. '9'); - pragma Loop_Invariant (Pow = Big_10 ** (Nb_Digits - J + 1)); - pragma Loop_Invariant (Big (Uns_Value) = Big (Uns_T) / Pow); - pragma Loop_Invariant - (UP.Scan_Based_Number_Ghost - (Str => S, - From => P + J, - To => P + Nb_Digits, - Base => 10, - Acc => Uns_Value) - = UP.Wrap_Option (Uns_T)); end loop; - pragma Assert (Big (Uns_Value) = Big (Uns_T) / Big_10 ** (Nb_Digits)); - pragma Assert (Uns_Value = 0); - pragma Assert - (UP.Scan_Based_Number_Ghost - (Str => S, - From => P + 1, - To => P + Nb_Digits, - Base => 10, - Acc => Uns_Value) - = UP.Wrap_Option (Uns_T)); - P := P + Nb_Digits; end Set_Digits; @@ -448,12 +111,10 @@ package body System.Image_I is procedure Set_Image_Integer (V : Int; S : in out String; - P : in out Natural) - is + P : in out Natural) is begin if V >= 0 then Set_Digits (-V, S, P); - else pragma Assert (P >= S'First - 1 and P < S'Last); -- No check is done since, as documented in the specification, diff --git a/gcc/ada/libgnat/s-imagei.ads b/gcc/ada/libgnat/s-imagei.ads index e500f74..8d3b939 100644 --- a/gcc/ada/libgnat/s-imagei.ads +++ b/gcc/ada/libgnat/s-imagei.ads @@ -33,48 +33,14 @@ -- and ``Ada.Text_IO.Integer_IO`` conversions routines for signed integer -- types. --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore, - Subprogram_Variant => Ignore); - -with System.Value_I_Spec; -with System.Value_U_Spec; - generic type Int is range <>; - type Uns is mod <>; - - -- Additional parameters for ghost subprograms used inside contracts - - with package U_Spec is new System.Value_U_Spec (Uns => Uns) with Ghost; - with package I_Spec is new System.Value_I_Spec - (Int => Int, Uns => Uns, U_Spec => U_Spec) with Ghost; - package System.Image_I is - package IP renames I_Spec; - package UP renames U_Spec; - use type UP.Uns_Option; - - Unsigned_Width_Ghost : constant Natural := U_Spec.Max_Log10 + 2 with Ghost; procedure Image_Integer (V : Int; S : in out String; - P : out Natural) - with - Pre => S'First = 1 - and then S'Last < Integer'Last - and then S'Last >= Unsigned_Width_Ghost, - Post => P in S'Range - and then IP.Is_Value_Integer_Ghost (S (1 .. P), V); + P : out Natural); -- Computes Int'Image (V) and stores the result in S (1 .. P) -- setting the resulting value of P. The caller guarantees that S -- is long enough to hold the result, and that S'First is 1. @@ -82,31 +48,7 @@ package System.Image_I is procedure Set_Image_Integer (V : Int; S : in out String; - P : in out Natural) - with - Pre => P < Integer'Last - and then S'Last < Integer'Last - and then S'First <= P + 1 - and then S'First <= S'Last - and then - (if V >= 0 then - P <= S'Last - Unsigned_Width_Ghost + 1 - else - P <= S'Last - Unsigned_Width_Ghost), - Post => S (S'First .. P'Old) = S'Old (S'First .. P'Old) - and then - (declare - Minus : constant Boolean := S (P'Old + 1) = '-'; - Offset : constant Positive := (if V >= 0 then 1 else 2); - Abs_V : constant Uns := IP.Abs_Uns_Of_Int (V); - begin - Minus = (V < 0) - and then P in P'Old + Offset .. S'Last - and then UP.Only_Decimal_Ghost - (S, From => P'Old + Offset, To => P) - and then UP.Scan_Based_Number_Ghost - (S, From => P'Old + Offset, To => P) - = UP.Wrap_Option (Abs_V)); + P : in out Natural); -- Stores the image of V in S starting at S (P + 1), P is updated to point -- to the last character stored. The value stored is identical to the value -- of Int'Image (V) except that no leading space is stored when V is diff --git a/gcc/ada/libgnat/s-imageu.adb b/gcc/ada/libgnat/s-imageu.adb index 820156b..a6cdfed 100644 --- a/gcc/ada/libgnat/s-imageu.adb +++ b/gcc/ada/libgnat/s-imageu.adb @@ -29,79 +29,8 @@ -- -- ------------------------------------------------------------------------------ -with Ada.Numerics.Big_Numbers.Big_Integers_Ghost; -use Ada.Numerics.Big_Numbers.Big_Integers_Ghost; -with System.Val_Spec; - package body System.Image_U is - -- Ghost code, loop invariants and assertions in this unit are meant for - -- analysis only, not for run-time checking, as it would be too costly - -- otherwise. This is enforced by setting the assertion policy to Ignore. - - pragma Assertion_Policy (Ghost => Ignore, - Loop_Invariant => Ignore, - Assert => Ignore, - Assert_And_Cut => Ignore, - Subprogram_Variant => Ignore); - - package Unsigned_Conversion is new Unsigned_Conversions (Int => Uns); - - function Big (Arg : Uns) return Big_Integer renames - Unsigned_Conversion.To_Big_Integer; - - function From_Big (Arg : Big_Integer) return Uns renames - Unsigned_Conversion.From_Big_Integer; - - Big_10 : constant Big_Integer := Big (10) with Ghost; - - ------------------ - -- Local Lemmas -- - ------------------ - - procedure Lemma_Non_Zero (X : Uns) - with - Ghost, - Pre => X /= 0, - Post => Big (X) /= 0; - - procedure Lemma_Div_Commutation (X, Y : Uns) - with - Ghost, - Pre => Y /= 0, - Post => Big (X) / Big (Y) = Big (X / Y); - - procedure Lemma_Div_Twice (X : Big_Natural; Y, Z : Big_Positive) - with - Ghost, - Post => X / Y / Z = X / (Y * Z); - - --------------------------- - -- Lemma_Div_Commutation -- - --------------------------- - - procedure Lemma_Non_Zero (X : Uns) is null; - procedure Lemma_Div_Commutation (X, Y : Uns) is null; - - --------------------- - -- Lemma_Div_Twice -- - --------------------- - - procedure Lemma_Div_Twice (X : Big_Natural; Y, Z : Big_Positive) is - XY : constant Big_Natural := X / Y; - YZ : constant Big_Natural := Y * Z; - XYZ : constant Big_Natural := X / Y / Z; - R : constant Big_Natural := (XY rem Z) * Y + (X rem Y); - begin - pragma Assert (X = XY * Y + (X rem Y)); - pragma Assert (XY = XY / Z * Z + (XY rem Z)); - pragma Assert (X = XYZ * YZ + R); - pragma Assert ((XY rem Z) * Y <= (Z - 1) * Y); - pragma Assert (R <= YZ - 1); - pragma Assert (X / YZ = (XYZ * YZ + R) / YZ); - pragma Assert (X / YZ = XYZ + R / YZ); - end Lemma_Div_Twice; - -------------------- -- Image_Unsigned -- -------------------- @@ -112,50 +41,10 @@ package body System.Image_U is P : out Natural) is pragma Assert (S'First = 1); - - procedure Prove_Value_Unsigned - with - Ghost, - Pre => S'First = 1 - and then S'Last < Integer'Last - and then P in 2 .. S'Last - and then S (1) = ' ' - and then U_Spec.Only_Decimal_Ghost (S, From => 2, To => P) - and then U_Spec.Scan_Based_Number_Ghost (S, From => 2, To => P) - = U_Spec.Wrap_Option (V), - Post => not System.Val_Spec.Only_Space_Ghost (S, 1, P) - and then U_Spec.Is_Unsigned_Ghost (S (1 .. P)) - and then U_Spec.Is_Value_Unsigned_Ghost (S (1 .. P), V); - -- Ghost lemma to prove the value of Value_Unsigned from the value of - -- Scan_Based_Number_Ghost on a decimal string. - - -------------------------- - -- Prove_Value_Unsigned -- - -------------------------- - - procedure Prove_Value_Unsigned is - Str : constant String := S (1 .. P); - begin - pragma Assert (Str'First = 1); - pragma Assert (S (2) /= ' '); - pragma Assert - (U_Spec.Only_Decimal_Ghost (Str, From => 2, To => P)); - U_Spec.Prove_Scan_Based_Number_Ghost_Eq - (S, Str, From => 2, To => P); - pragma Assert - (U_Spec.Scan_Based_Number_Ghost (Str, From => 2, To => P) - = U_Spec.Wrap_Option (V)); - U_Spec.Prove_Scan_Only_Decimal_Ghost (Str, V); - end Prove_Value_Unsigned; - - -- Start of processing for Image_Unsigned - begin S (1) := ' '; P := 1; Set_Image_Unsigned (V, S, P); - - Prove_Value_Unsigned; end Image_Unsigned; ------------------------ @@ -169,118 +58,6 @@ package body System.Image_U is is Nb_Digits : Natural := 0; Value : Uns := V; - - -- Local ghost variables - - Pow : Big_Positive := 1 with Ghost; - S_Init : constant String := S with Ghost; - Prev_Value : Uns with Ghost; - Prev_S : String := S with Ghost; - - -- Local ghost lemmas - - procedure Prove_Character_Val (R : Uns) - with - Ghost, - Post => R rem 10 in 0 .. 9 - and then Character'Val (48 + R rem 10) in '0' .. '9'; - -- Ghost lemma to prove the value of a character corresponding to the - -- next figure. - - procedure Prove_Euclidian (Val, Quot, Rest : Uns) - with - Ghost, - Pre => Quot = Val / 10 - and then Rest = Val rem 10, - Post => Uns'Last - Rest >= 10 * Quot and then Val = 10 * Quot + Rest; - -- Ghost lemma to prove the relation between the quotient/remainder of - -- division by 10 and the initial value. - - procedure Prove_Hexa_To_Unsigned_Ghost (R : Uns) - with - Ghost, - Pre => R in 0 .. 9, - Post => U_Spec.Hexa_To_Unsigned_Ghost (Character'Val (48 + R)) = R; - -- Ghost lemma to prove that Hexa_To_Unsigned_Ghost returns the source - -- figure when applied to the corresponding character. - - procedure Prove_Scan_Iter - (S, Prev_S : String; - V, Prev_V, Res : Uns; - P, Max : Natural) - with - Ghost, - Pre => - S'First = Prev_S'First and then S'Last = Prev_S'Last - and then S'Last < Natural'Last and then - Max in S'Range and then P in S'First .. Max and then - (for all I in P + 1 .. Max => Prev_S (I) in '0' .. '9') - and then (for all I in P + 1 .. Max => Prev_S (I) = S (I)) - and then S (P) in '0' .. '9' - and then V <= Uns'Last / 10 - and then Uns'Last - U_Spec.Hexa_To_Unsigned_Ghost (S (P)) - >= 10 * V - and then Prev_V = - V * 10 + U_Spec.Hexa_To_Unsigned_Ghost (S (P)) - and then - (if P = Max then Prev_V = Res - else U_Spec.Scan_Based_Number_Ghost - (Str => Prev_S, - From => P + 1, - To => Max, - Base => 10, - Acc => Prev_V) = U_Spec.Wrap_Option (Res)), - Post => - (for all I in P .. Max => S (I) in '0' .. '9') - and then U_Spec.Scan_Based_Number_Ghost - (Str => S, - From => P, - To => Max, - Base => 10, - Acc => V) = U_Spec.Wrap_Option (Res); - -- Ghost lemma to prove that Scan_Based_Number_Ghost is preserved - -- through an iteration of the loop. - - ----------------------------- - -- Local lemma null bodies -- - ----------------------------- - - procedure Prove_Character_Val (R : Uns) is null; - procedure Prove_Euclidian (Val, Quot, Rest : Uns) is null; - procedure Prove_Hexa_To_Unsigned_Ghost (R : Uns) is null; - - --------------------- - -- Prove_Scan_Iter -- - --------------------- - - procedure Prove_Scan_Iter - (S, Prev_S : String; - V, Prev_V, Res : Uns; - P, Max : Natural) - is - pragma Unreferenced (Res); - begin - U_Spec.Lemma_Scan_Based_Number_Ghost_Step - (Str => S, - From => P, - To => Max, - Base => 10, - Acc => V); - if P < Max then - U_Spec.Prove_Scan_Based_Number_Ghost_Eq - (Prev_S, S, P + 1, Max, 10, Prev_V); - else - U_Spec.Lemma_Scan_Based_Number_Ghost_Base - (Str => S, - From => P + 1, - To => Max, - Base => 10, - Acc => Prev_V); - end if; - end Prove_Scan_Iter; - - -- Start of processing for Set_Image_Unsigned - begin pragma Assert (P >= S'First - 1 and then P < S'Last and then P < Natural'Last); @@ -290,70 +67,19 @@ package body System.Image_U is -- First we compute the number of characters needed for representing -- the number. loop - Lemma_Div_Commutation (Value, 10); - Lemma_Div_Twice (Big (V), Big_10 ** Nb_Digits, Big_10); - Value := Value / 10; Nb_Digits := Nb_Digits + 1; - Pow := Pow * 10; - - pragma Loop_Invariant (Nb_Digits in 1 .. Unsigned_Width_Ghost - 1); - pragma Loop_Invariant (Pow = Big_10 ** Nb_Digits); - pragma Loop_Invariant (Big (Value) = Big (V) / Pow); - pragma Loop_Variant (Decreases => Value); exit when Value = 0; - - Lemma_Non_Zero (Value); - pragma Assert (Pow <= Big (Uns'Last)); end loop; - pragma Assert (Big (V) / (Big_10 ** Nb_Digits) = 0); Value := V; - Pow := 1; - - pragma Assert (Value = From_Big (Big (V) / Big_10 ** 0)); -- We now populate digits from the end of the string to the beginning for J in reverse 1 .. Nb_Digits loop - Lemma_Div_Commutation (Value, 10); - Lemma_Div_Twice (Big (V), Big_10 ** (Nb_Digits - J), Big_10); - Prove_Character_Val (Value); - Prove_Hexa_To_Unsigned_Ghost (Value rem 10); - - Prev_Value := Value; - Prev_S := S; - Pow := Pow * 10; S (P + J) := Character'Val (48 + (Value rem 10)); Value := Value / 10; - - Prove_Euclidian - (Val => Prev_Value, - Quot => Value, - Rest => U_Spec.Hexa_To_Unsigned_Ghost (S (P + J))); - - Prove_Scan_Iter - (S, Prev_S, Value, Prev_Value, V, P + J, P + Nb_Digits); - - pragma Loop_Invariant (Value <= Uns'Last / 10); - pragma Loop_Invariant - (for all K in S'First .. P => S (K) = S_Init (K)); - pragma Loop_Invariant - (U_Spec.Only_Decimal_Ghost - (S, From => P + J, To => P + Nb_Digits)); - pragma Loop_Invariant (Pow = Big_10 ** (Nb_Digits - J + 1)); - pragma Loop_Invariant (Big (Value) = Big (V) / Pow); - pragma Loop_Invariant - (U_Spec.Scan_Based_Number_Ghost - (Str => S, - From => P + J, - To => P + Nb_Digits, - Base => 10, - Acc => Value) - = U_Spec.Wrap_Option (V)); end loop; - pragma Assert (Big (Value) = Big (V) / (Big_10 ** Nb_Digits)); - pragma Assert (Value = 0); P := P + Nb_Digits; end Set_Image_Unsigned; diff --git a/gcc/ada/libgnat/s-imageu.ads b/gcc/ada/libgnat/s-imageu.ads index 720de40..8640a5b 100644 --- a/gcc/ada/libgnat/s-imageu.ads +++ b/gcc/ada/libgnat/s-imageu.ads @@ -33,44 +33,15 @@ -- and ``Ada.Text_IO.Modular_IO`` conversions routines for modular integer -- types. --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore, - Subprogram_Variant => Ignore); - -with System.Value_U_Spec; - generic - type Uns is mod <>; - -- Additional parameters for ghost subprograms used inside contracts - - with package U_Spec is new System.Value_U_Spec (Uns => Uns) with Ghost; - package System.Image_U is - use all type U_Spec.Uns_Option; - - Unsigned_Width_Ghost : constant Natural := U_Spec.Max_Log10 + 2 with Ghost; procedure Image_Unsigned (V : Uns; S : in out String; - P : out Natural) - with - Pre => S'First = 1 - and then S'Last < Integer'Last - and then S'Last >= Unsigned_Width_Ghost, - Post => P in S'Range - and then U_Spec.Is_Value_Unsigned_Ghost (S (1 .. P), V); - pragma Inline (Image_Unsigned); + P : out Natural) with Inline; -- Computes Uns'Image (V) and stores the result in S (1 .. P) setting -- the resulting value of P. The caller guarantees that S is long enough to -- hold the result, and that S'First is 1. @@ -78,19 +49,7 @@ package System.Image_U is procedure Set_Image_Unsigned (V : Uns; S : in out String; - P : in out Natural) - with - Pre => P < Integer'Last - and then S'Last < Integer'Last - and then S'First <= P + 1 - and then S'First <= S'Last - and then P <= S'Last - Unsigned_Width_Ghost + 1, - Post => S (S'First .. P'Old) = S'Old (S'First .. P'Old) - and then P in P'Old + 1 .. S'Last - and then U_Spec.Only_Decimal_Ghost (S, From => P'Old + 1, To => P) - and then U_Spec.Scan_Based_Number_Ghost - (S, From => P'Old + 1, To => P) - = U_Spec.Wrap_Option (V); + P : in out Natural); -- Stores the image of V in S starting at S (P + 1), P is updated to point -- to the last character stored. The value stored is identical to the value -- of Uns'Image (V) except that no leading space is stored. The caller diff --git a/gcc/ada/libgnat/s-imde128.ads b/gcc/ada/libgnat/s-imde128.ads index f353f57..03485b9 100644 --- a/gcc/ada/libgnat/s-imde128.ads +++ b/gcc/ada/libgnat/s-imde128.ads @@ -39,9 +39,8 @@ with System.Image_D; package System.Img_Decimal_128 is subtype Int128 is Interfaces.Integer_128; - subtype Uns128 is Interfaces.Unsigned_128; - package Impl is new Image_D (Int128, Uns128); + package Impl is new Image_D (Int128); procedure Image_Decimal128 (V : Int128; diff --git a/gcc/ada/libgnat/s-imde32.ads b/gcc/ada/libgnat/s-imde32.ads index 442f343..40fd5e9 100644 --- a/gcc/ada/libgnat/s-imde32.ads +++ b/gcc/ada/libgnat/s-imde32.ads @@ -39,9 +39,8 @@ with System.Image_D; package System.Img_Decimal_32 is subtype Int32 is Interfaces.Integer_32; - subtype Uns32 is Interfaces.Unsigned_32; - package Impl is new Image_D (Int32, Uns32); + package Impl is new Image_D (Int32); procedure Image_Decimal32 (V : Int32; diff --git a/gcc/ada/libgnat/s-imde64.ads b/gcc/ada/libgnat/s-imde64.ads index a69e02f..5264c43 100644 --- a/gcc/ada/libgnat/s-imde64.ads +++ b/gcc/ada/libgnat/s-imde64.ads @@ -39,9 +39,8 @@ with System.Image_D; package System.Img_Decimal_64 is subtype Int64 is Interfaces.Integer_64; - subtype Uns64 is Interfaces.Unsigned_64; - package Impl is new Image_D (Int64, Uns64); + package Impl is new Image_D (Int64); procedure Image_Decimal64 (V : Int64; diff --git a/gcc/ada/libgnat/s-imfi128.ads b/gcc/ada/libgnat/s-imfi128.ads index 9bb383a..23cd059 100644 --- a/gcc/ada/libgnat/s-imfi128.ads +++ b/gcc/ada/libgnat/s-imfi128.ads @@ -39,9 +39,8 @@ with System.Image_F; package System.Img_Fixed_128 is subtype Int128 is Interfaces.Integer_128; - subtype Uns128 is Interfaces.Unsigned_128; - package Impl is new Image_F (Int128, Uns128, Arith_128.Scaled_Divide128); + package Impl is new Image_F (Int128, Arith_128.Scaled_Divide128); procedure Image_Fixed128 (V : Int128; diff --git a/gcc/ada/libgnat/s-imfi32.ads b/gcc/ada/libgnat/s-imfi32.ads index f66b0fa..ba46e8d 100644 --- a/gcc/ada/libgnat/s-imfi32.ads +++ b/gcc/ada/libgnat/s-imfi32.ads @@ -39,9 +39,8 @@ with System.Image_F; package System.Img_Fixed_32 is subtype Int32 is Interfaces.Integer_32; - subtype Uns32 is Interfaces.Unsigned_32; - package Impl is new Image_F (Int32, Uns32, Arith_32.Scaled_Divide32); + package Impl is new Image_F (Int32, Arith_32.Scaled_Divide32); procedure Image_Fixed32 (V : Int32; diff --git a/gcc/ada/libgnat/s-imfi64.ads b/gcc/ada/libgnat/s-imfi64.ads index ecb70ad..c7f7aa1 100644 --- a/gcc/ada/libgnat/s-imfi64.ads +++ b/gcc/ada/libgnat/s-imfi64.ads @@ -39,9 +39,8 @@ with System.Image_F; package System.Img_Fixed_64 is subtype Int64 is Interfaces.Integer_64; - subtype Uns64 is Interfaces.Unsigned_64; - package Impl is new Image_F (Int64, Uns64, Arith_64.Scaled_Divide64); + package Impl is new Image_F (Int64, Arith_64.Scaled_Divide64); procedure Image_Fixed64 (V : Int64; diff --git a/gcc/ada/libgnat/s-imgboo.adb b/gcc/ada/libgnat/s-imgboo.adb index 436818c..c4d85bf 100644 --- a/gcc/ada/libgnat/s-imgboo.adb +++ b/gcc/ada/libgnat/s-imgboo.adb @@ -29,32 +29,9 @@ -- -- ------------------------------------------------------------------------------ --- Ghost code, loop invariants and assertions in this unit are meant for --- analysis only, not for run-time checking, as it would be too costly --- otherwise. This is enforced by setting the assertion policy to Ignore. - -pragma Assertion_Policy (Ghost => Ignore, - Loop_Invariant => Ignore, - Assert => Ignore); - package body System.Img_Bool with SPARK_Mode is - - -- Local lemmas - - procedure Lemma_Is_First_Non_Space_Ghost (S : String; R : Positive) with - Ghost, - Pre => R in S'Range and then S (R) /= ' ' - and then System.Val_Spec.Only_Space_Ghost (S, S'First, R - 1), - Post => System.Val_Spec.First_Non_Space_Ghost (S, S'First, S'Last) = R; - - ------------------------------------ - -- Lemma_Is_First_Non_Space_Ghost -- - ------------------------------------ - - procedure Lemma_Is_First_Non_Space_Ghost (S : String; R : Positive) is null; - ------------------- -- Image_Boolean -- ------------------- @@ -69,11 +46,9 @@ is if V then S (1 .. 4) := "TRUE"; P := 4; - Lemma_Is_First_Non_Space_Ghost (S, 1); else S (1 .. 5) := "FALSE"; P := 5; - Lemma_Is_First_Non_Space_Ghost (S, 1); end if; end Image_Boolean; diff --git a/gcc/ada/libgnat/s-imgboo.ads b/gcc/ada/libgnat/s-imgboo.ads index 9d8b1f7..af19c2e 100644 --- a/gcc/ada/libgnat/s-imgboo.ads +++ b/gcc/ada/libgnat/s-imgboo.ads @@ -34,32 +34,13 @@ -- This package provides support for ``Image`` attribute on ``Boolean``. The -- compiler performs direct calls to this unit to implement the attribute. --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore); - -with System.Val_Spec; - package System.Img_Bool with SPARK_Mode, Preelaborate is - procedure Image_Boolean (V : Boolean; S : in out String; - P : out Natural) - with - Pre => S'First = 1 - and then (if V then S'Length >= 4 else S'Length >= 5), - Post => (if V then P = 4 else P = 5) - and then System.Val_Spec.Is_Boolean_Image_Ghost (S (1 .. P), V); + P : out Natural); -- Computes Boolean'Image (``V``) and stores the result in -- ``S`` (1 .. ``P``) setting the resulting value of ``P``. The caller -- guarantees that ``S`` is long enough to hold the result, and that diff --git a/gcc/ada/libgnat/s-imgint.ads b/gcc/ada/libgnat/s-imgint.ads index 1ccf173..55df149 100644 --- a/gcc/ada/libgnat/s-imgint.ads +++ b/gcc/ada/libgnat/s-imgint.ads @@ -33,33 +33,12 @@ -- and ``Ada.Text_IO.Integer_IO`` conversions routines for signed integer -- types up to Size ``Integer'Size``. --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore, - Subprogram_Variant => Ignore); - with System.Image_I; -with System.Unsigned_Types; -with System.Vs_Int; -with System.Vs_Uns; package System.Img_Int with SPARK_Mode is - subtype Unsigned is Unsigned_Types.Unsigned; - - package Impl is new Image_I - (Int => Integer, - Uns => Unsigned, - U_Spec => System.Vs_Uns.Spec, - I_Spec => System.Vs_Int.Spec); + package Impl is new Image_I (Integer); procedure Image_Integer (V : Integer; diff --git a/gcc/ada/libgnat/s-imglli.ads b/gcc/ada/libgnat/s-imglli.ads index 32be4dc..28fd563 100644 --- a/gcc/ada/libgnat/s-imglli.ads +++ b/gcc/ada/libgnat/s-imglli.ads @@ -33,33 +33,12 @@ -- and ``Ada.Text_IO.Integer_IO`` conversions routines for signed integer -- types larger than Size ``Integer'Size``. --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore, - Subprogram_Variant => Ignore); - with System.Image_I; -with System.Unsigned_Types; -with System.Vs_LLI; -with System.Vs_LLU; package System.Img_LLI with SPARK_Mode is - subtype Long_Long_Unsigned is Unsigned_Types.Long_Long_Unsigned; - - package Impl is new Image_I - (Int => Long_Long_Integer, - Uns => Long_Long_Unsigned, - U_Spec => System.Vs_LLU.Spec, - I_Spec => System.Vs_LLI.Spec); + package Impl is new Image_I (Long_Long_Integer); procedure Image_Long_Long_Integer (V : Long_Long_Integer; diff --git a/gcc/ada/libgnat/s-imgllli.ads b/gcc/ada/libgnat/s-imgllli.ads index 47c75b0..cecbdff 100644 --- a/gcc/ada/libgnat/s-imgllli.ads +++ b/gcc/ada/libgnat/s-imgllli.ads @@ -33,33 +33,12 @@ -- signed integer types larger than Long_Long_Integer, and also for conversion -- operations required in Text_IO.Integer_IO for such types. --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore, - Subprogram_Variant => Ignore); - with System.Image_I; -with System.Unsigned_Types; -with System.Vs_LLLI; -with System.Vs_LLLU; package System.Img_LLLI with SPARK_Mode is - subtype Long_Long_Long_Unsigned is Unsigned_Types.Long_Long_Long_Unsigned; - - package Impl is new Image_I - (Int => Long_Long_Long_Integer, - Uns => Long_Long_Long_Unsigned, - U_Spec => System.Vs_LLLU.Spec, - I_Spec => System.Vs_LLLI.Spec); + package Impl is new Image_I (Long_Long_Long_Integer); procedure Image_Long_Long_Long_Integer (V : Long_Long_Long_Integer; diff --git a/gcc/ada/libgnat/s-imglllu.ads b/gcc/ada/libgnat/s-imglllu.ads index 0dbe1f21c..e581d37 100644 --- a/gcc/ada/libgnat/s-imglllu.ads +++ b/gcc/ada/libgnat/s-imglllu.ads @@ -33,30 +33,15 @@ -- modular integer types larger than Long_Long_Unsigned, and also for -- conversion operations required in Text_IO.Modular_IO for such types. --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore, - Subprogram_Variant => Ignore); - with System.Image_U; with System.Unsigned_Types; -with System.Vs_LLLU; package System.Img_LLLU with SPARK_Mode is subtype Long_Long_Long_Unsigned is Unsigned_Types.Long_Long_Long_Unsigned; - package Impl is new Image_U - (Uns => Long_Long_Long_Unsigned, - U_Spec => System.Vs_LLLU.Spec); + package Impl is new Image_U (Uns => Long_Long_Long_Unsigned); procedure Image_Long_Long_Long_Unsigned (V : Long_Long_Long_Unsigned; diff --git a/gcc/ada/libgnat/s-imgllu.ads b/gcc/ada/libgnat/s-imgllu.ads index 82d372d..729e6e8 100644 --- a/gcc/ada/libgnat/s-imgllu.ads +++ b/gcc/ada/libgnat/s-imgllu.ads @@ -33,30 +33,15 @@ -- and ``Ada.Text_IO.Modular_IO`` conversions routines for unsigned (modular) -- integer types larger than Size ``Unsigned'Size``. --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore, - Subprogram_Variant => Ignore); - with System.Image_U; with System.Unsigned_Types; -with System.Vs_LLU; package System.Img_LLU with SPARK_Mode is subtype Long_Long_Unsigned is Unsigned_Types.Long_Long_Unsigned; - package Impl is new Image_U - (Uns => Long_Long_Unsigned, - U_Spec => System.Vs_LLU.Spec); + package Impl is new Image_U (Uns => Long_Long_Unsigned); procedure Image_Long_Long_Unsigned (V : Long_Long_Unsigned; diff --git a/gcc/ada/libgnat/s-imguns.ads b/gcc/ada/libgnat/s-imguns.ads index 142591a..dbab67e 100644 --- a/gcc/ada/libgnat/s-imguns.ads +++ b/gcc/ada/libgnat/s-imguns.ads @@ -33,30 +33,15 @@ -- and ``Ada.Text_IO.Modular_IO`` conversions routines for modular integer -- types up to size ``Unsigned'Size``. --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore, - Subprogram_Variant => Ignore); - with System.Image_U; with System.Unsigned_Types; -with System.Vs_Uns; package System.Img_Uns with SPARK_Mode is subtype Unsigned is Unsigned_Types.Unsigned; - package Impl is new Image_U - (Uns => Unsigned, - U_Spec => System.Vs_Uns.Spec); + package Impl is new Image_U (Uns => Unsigned); procedure Image_Unsigned (V : Unsigned; diff --git a/gcc/ada/libgnat/s-spark.ads b/gcc/ada/libgnat/s-spark.ads deleted file mode 100644 index c46409f..0000000 --- a/gcc/ada/libgnat/s-spark.ads +++ /dev/null @@ -1,39 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . S P A R K -- --- -- --- S p e c -- --- -- --- Copyright (C) 2022-2025, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the top level unit of the SPARK package. Its children --- contain helper functions to aid proofs. - -package System.SPARK with - SPARK_Mode, - Pure -is -end System.SPARK; diff --git a/gcc/ada/libgnat/s-spcuop.adb b/gcc/ada/libgnat/s-spcuop.adb deleted file mode 100644 index 74422ea..0000000 --- a/gcc/ada/libgnat/s-spcuop.adb +++ /dev/null @@ -1,42 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . S P A R K . C U T _ O P E R A T I O N S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2022-2025, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package body System.SPARK.Cut_Operations with - SPARK_Mode => Off -is - - function By (Consequence, Premise : Boolean) return Boolean is - (Premise and then Consequence); - - function So (Premise, Consequence : Boolean) return Boolean is - (Premise and then Consequence); - -end System.SPARK.Cut_Operations; diff --git a/gcc/ada/libgnat/s-spcuop.ads b/gcc/ada/libgnat/s-spcuop.ads deleted file mode 100644 index 04a94a5..0000000 --- a/gcc/ada/libgnat/s-spcuop.ads +++ /dev/null @@ -1,57 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . S P A R K . C U T _ O P E R A T I O N S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2022-2025, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides connectors used to manually help the proof of --- assertions by introducing intermediate steps. They can only be used inside --- pragmas Assert or Assert_And_Cut. - -package System.SPARK.Cut_Operations with - SPARK_Mode, - Pure, - Always_Terminates -is - - function By (Consequence, Premise : Boolean) return Boolean with - Ghost, - Global => null; - -- If A and B are two boolean expressions, proving By (A, B) requires - -- proving B, the premise, and then A assuming B, the side-condition. When - -- By (A, B) is assumed on the other hand, we only assume A. B is used - -- for the proof, but is not visible afterward. - - function So (Premise, Consequence : Boolean) return Boolean with - Ghost, - Global => null; - -- If A and B are two boolean expressions, proving So (A, B) requires - -- proving A, the premise, and then B assuming A, the side-condition. When - -- So (A, B) is assumed both A and B are assumed to be true. - -end System.SPARK.Cut_Operations; diff --git a/gcc/ada/libgnat/s-trasym__dwarf.adb b/gcc/ada/libgnat/s-trasym__dwarf.adb index 45af884..1b4b807 100644 --- a/gcc/ada/libgnat/s-trasym__dwarf.adb +++ b/gcc/ada/libgnat/s-trasym__dwarf.adb @@ -41,6 +41,7 @@ with System.Soft_Links; with System.CRTL; with System.Dwarf_Lines; with System.Exception_Traces; +with System.OS_Lib; with System.Standard_Library; with System.Traceback_Entries; with System.Strings; @@ -413,6 +414,23 @@ package body System.Traceback.Symbolic is return; end if; + -- On some platforms, we use dladdr and the dli_fname field to get the + -- pathname, but that pathname might be relative and not point to the + -- right thing in our context. That happens when the executable is + -- dynamically linked and was started through execvp; dli_fname only + -- contains the executable name passed to execvp in that case. + -- + -- Because of this, we might be about to open a file that's in fact not + -- a shared object but something completely unrelated. It's hard to + -- detect this in general, but we perform a sanity check that + -- Module_Name does not designate a directory; if it does, it's + -- definitely not a shared object. + + if System.OS_Lib.Is_Directory (Module_Name) then + Success := False; + return; + end if; + Open (Module_Name, Module.C, Success); -- If a module can't be opened just return now, we just cannot give more diff --git a/gcc/ada/libgnat/s-vaispe.adb b/gcc/ada/libgnat/s-vaispe.adb deleted file mode 100644 index 0b09f75..0000000 --- a/gcc/ada/libgnat/s-vaispe.adb +++ /dev/null @@ -1,87 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . V A L U E _ I _ S P E C -- --- -- --- B o d y -- --- -- --- Copyright (C) 2022-2025, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore, - Subprogram_Variant => Ignore); - -package body System.Value_I_Spec is - - ----------------------------------- - -- Prove_Scan_Only_Decimal_Ghost -- - ----------------------------------- - - procedure Prove_Scan_Only_Decimal_Ghost (Str : String; Val : Int) is - Non_Blank : constant Positive := First_Non_Space_Ghost - (Str, Str'First, Str'Last); - pragma Assert (Str (Str'First + 1) /= ' '); - pragma Assert - (if Val < 0 then Non_Blank = Str'First - else - Str (Str'First) = ' ' - and then Non_Blank = Str'First + 1); - Minus : constant Boolean := Str (Non_Blank) = '-'; - Fst_Num : constant Positive := - (if Minus then Non_Blank + 1 else Non_Blank); - pragma Assert (Fst_Num = Str'First + 1); - Uval : constant Uns := Abs_Uns_Of_Int (Val); - - procedure Prove_Conversion_Is_Identity (Val : Int; Uval : Uns) - with - Pre => Minus = (Val < 0) - and then Uval = Abs_Uns_Of_Int (Val), - Post => Uns_Is_Valid_Int (Minus, Uval) - and then Is_Int_Of_Uns (Minus, Uval, Val); - -- Local proof of the unicity of the signed representation - - procedure Prove_Conversion_Is_Identity (Val : Int; Uval : Uns) is null; - - -- Start of processing for Prove_Scan_Only_Decimal_Ghost - - begin - Prove_Conversion_Is_Identity (Val, Uval); - pragma Assert - (U_Spec.Is_Raw_Unsigned_Format_Ghost (Str (Fst_Num .. Str'Last))); - pragma Assert - (U_Spec.Scan_Split_No_Overflow_Ghost (Str, Fst_Num, Str'Last)); - U_Spec.Lemma_Exponent_Unsigned_Ghost_Base (Uval, 0, 10); - pragma Assert - (U_Spec.Raw_Unsigned_No_Overflow_Ghost (Str, Fst_Num, Str'Last)); - pragma Assert (Only_Space_Ghost - (Str, U_Spec.Raw_Unsigned_Last_Ghost - (Str, Fst_Num, Str'Last), Str'Last)); - pragma Assert (Is_Integer_Ghost (Str)); - pragma Assert (Is_Value_Integer_Ghost (Str, Val)); - end Prove_Scan_Only_Decimal_Ghost; - -end System.Value_I_Spec; diff --git a/gcc/ada/libgnat/s-vaispe.ads b/gcc/ada/libgnat/s-vaispe.ads deleted file mode 100644 index 2e729aa..0000000 --- a/gcc/ada/libgnat/s-vaispe.ads +++ /dev/null @@ -1,185 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . V A L U E _ I _ S P E C -- --- -- --- S p e c -- --- -- --- Copyright (C) 2022-2025, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package is part of a set of Ghost code packages used to proof the --- implementations of the Image and Value attributes. It provides the --- specification entities using for the formal verification of the routines --- for scanning signed integer values. - --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore, - Subprogram_Variant => Ignore); - -with System.Value_U_Spec; -with System.Val_Spec; use System.Val_Spec; - -generic - - type Int is range <>; - - type Uns is mod <>; - - -- Additional parameters for ghost subprograms used inside contracts - - with package U_Spec is new System.Value_U_Spec (Uns => Uns) with Ghost; - -package System.Value_I_Spec with - Ghost, - SPARK_Mode, - Always_Terminates -is - pragma Preelaborate; - use all type U_Spec.Uns_Option; - - function Uns_Is_Valid_Int (Minus : Boolean; Uval : Uns) return Boolean is - (if Minus then Uval <= Uns (Int'Last) + 1 - else Uval <= Uns (Int'Last)) - with Post => True; - -- Return True if Uval (or -Uval when Minus is True) is a valid number of - -- type Int. - - function Is_Int_Of_Uns - (Minus : Boolean; - Uval : Uns; - Val : Int) - return Boolean - is - (if Minus and then Uval = Uns (Int'Last) + 1 then Val = Int'First - elsif Minus then Val = -(Int (Uval)) - else Val = Int (Uval)) - with - Pre => Uns_Is_Valid_Int (Minus, Uval), - Post => True; - -- Return True if Uval (or -Uval when Minus is True) is equal to Val - - function Abs_Uns_Of_Int (Val : Int) return Uns is - (if Val = Int'First then Uns (Int'Last) + 1 - elsif Val < 0 then Uns (-Val) - else Uns (Val)); - -- Return the unsigned absolute value of Val - - function Slide_To_1 (Str : String) return String - with - Post => - Only_Space_Ghost (Str, Str'First, Str'Last) = - (for all J in Str'First .. Str'Last => - Slide_To_1'Result (J - Str'First + 1) = ' '); - -- Slides Str so that it starts at 1 - - function Slide_If_Necessary (Str : String) return String is - (if Str'Last = Positive'Last then Slide_To_1 (Str) else Str); - -- If Str'Last = Positive'Last then slides Str so that it starts at 1 - - function Is_Integer_Ghost (Str : String) return Boolean is - (declare - Non_Blank : constant Positive := First_Non_Space_Ghost - (Str, Str'First, Str'Last); - Fst_Num : constant Positive := - (if Str (Non_Blank) in '+' | '-' then Non_Blank + 1 else Non_Blank); - begin - U_Spec.Is_Raw_Unsigned_Format_Ghost (Str (Fst_Num .. Str'Last)) - and then U_Spec.Raw_Unsigned_No_Overflow_Ghost - (Str, Fst_Num, Str'Last) - and then - Uns_Is_Valid_Int - (Minus => Str (Non_Blank) = '-', - Uval => U_Spec.Scan_Raw_Unsigned_Ghost - (Str, Fst_Num, Str'Last)) - and then Only_Space_Ghost - (Str, U_Spec.Raw_Unsigned_Last_Ghost - (Str, Fst_Num, Str'Last), Str'Last)) - with - Pre => not Only_Space_Ghost (Str, Str'First, Str'Last) - and then Str'Last /= Positive'Last, - Post => True; - -- Ghost function that determines if Str has the correct format for a - -- signed number, consisting in some blank characters, an optional - -- sign, a raw unsigned number which does not overflow and then some - -- more blank characters. - - function Is_Value_Integer_Ghost (Str : String; Val : Int) return Boolean is - (declare - Non_Blank : constant Positive := First_Non_Space_Ghost - (Str, Str'First, Str'Last); - Fst_Num : constant Positive := - (if Str (Non_Blank) in '+' | '-' then Non_Blank + 1 else Non_Blank); - Uval : constant Uns := - U_Spec.Scan_Raw_Unsigned_Ghost (Str, Fst_Num, Str'Last); - begin - Is_Int_Of_Uns (Minus => Str (Non_Blank) = '-', - Uval => Uval, - Val => Val)) - with - Pre => not Only_Space_Ghost (Str, Str'First, Str'Last) - and then Str'Last /= Positive'Last - and then Is_Integer_Ghost (Str), - Post => True; - -- Ghost function that returns True if Val is the value corresponding to - -- the signed number represented by Str. - - procedure Prove_Scan_Only_Decimal_Ghost (Str : String; Val : Int) - with - Ghost, - Pre => Str'Last /= Positive'Last - and then Str'Length >= 2 - and then Str (Str'First) in ' ' | '-' - and then (Str (Str'First) = '-') = (Val < 0) - and then U_Spec.Only_Decimal_Ghost (Str, Str'First + 1, Str'Last) - and then U_Spec.Scan_Based_Number_Ghost - (Str, Str'First + 1, Str'Last) - = U_Spec.Wrap_Option (Abs_Uns_Of_Int (Val)), - Post => Is_Integer_Ghost (Slide_If_Necessary (Str)) - and then Is_Value_Integer_Ghost (Str, Val); - -- Ghost lemma used in the proof of 'Image implementation, to prove that - -- the result of Value_Integer on a decimal string is the same as the - -- signing the result of Scan_Based_Number_Ghost. - -private - - ---------------- - -- Slide_To_1 -- - ---------------- - - function Slide_To_1 (Str : String) return String is - (declare - Res : constant String (1 .. Str'Length) := Str; - begin - Res); - -end System.Value_I_Spec; diff --git a/gcc/ada/libgnat/s-valboo.adb b/gcc/ada/libgnat/s-valboo.adb index 8db3316..93d6fb2 100644 --- a/gcc/ada/libgnat/s-valboo.adb +++ b/gcc/ada/libgnat/s-valboo.adb @@ -29,14 +29,6 @@ -- -- ------------------------------------------------------------------------------ --- Ghost code, loop invariants and assertions in this unit are meant for --- analysis only, not for run-time checking, as it would be too costly --- otherwise. This is enforced by setting the assertion policy to Ignore. - -pragma Assertion_Policy (Ghost => Ignore, - Loop_Invariant => Ignore, - Assert => Ignore); - with System.Val_Util; use System.Val_Util; package body System.Val_Bool @@ -55,9 +47,6 @@ is begin Normalize_String (S, F, L, To_Upper_Case => True); - pragma Assert (F = System.Val_Spec.First_Non_Space_Ghost - (S, Str'First, Str'Last)); - if S (F .. L) = "TRUE" then return True; diff --git a/gcc/ada/libgnat/s-valboo.ads b/gcc/ada/libgnat/s-valboo.ads index fdd8a3f..b2fd558 100644 --- a/gcc/ada/libgnat/s-valboo.ads +++ b/gcc/ada/libgnat/s-valboo.ads @@ -29,32 +29,12 @@ -- -- ------------------------------------------------------------------------------ --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore); - -with System.Val_Spec; - package System.Val_Bool with SPARK_Mode is pragma Preelaborate; - function Value_Boolean (Str : String) return Boolean - with - Pre => System.Val_Spec.Is_Boolean_Image_Ghost (Str, True) - or else System.Val_Spec.Is_Boolean_Image_Ghost (Str, False), - Post => - Value_Boolean'Result = - (Str (System.Val_Spec.First_Non_Space_Ghost - (Str, Str'First, Str'Last)) in 't' | 'T'); + function Value_Boolean (Str : String) return Boolean; -- Computes Boolean'Value (Str) end System.Val_Bool; diff --git a/gcc/ada/libgnat/s-valint.ads b/gcc/ada/libgnat/s-valint.ads index 6045cd6..164bbfe 100644 --- a/gcc/ada/libgnat/s-valint.ads +++ b/gcc/ada/libgnat/s-valint.ads @@ -32,23 +32,9 @@ -- This package contains routines for scanning signed Integer values for use -- in Text_IO.Integer_IO, and the Value attribute. --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore, - Subprogram_Variant => Ignore); - with System.Unsigned_Types; with System.Val_Uns; with System.Value_I; -with System.Vs_Int; -with System.Vs_Uns; package System.Val_Int with SPARK_Mode is pragma Preelaborate; @@ -58,9 +44,7 @@ package System.Val_Int with SPARK_Mode is package Impl is new Value_I (Int => Integer, Uns => Unsigned, - Scan_Raw_Unsigned => Val_Uns.Scan_Raw_Unsigned, - U_Spec => System.Vs_Uns.Spec, - Spec => System.Vs_Int.Spec); + Scan_Raw_Unsigned => Val_Uns.Scan_Raw_Unsigned); procedure Scan_Integer (Str : String; diff --git a/gcc/ada/libgnat/s-vallli.ads b/gcc/ada/libgnat/s-vallli.ads index 7672cc5..a3b48e3 100644 --- a/gcc/ada/libgnat/s-vallli.ads +++ b/gcc/ada/libgnat/s-vallli.ads @@ -32,23 +32,9 @@ -- This package contains routines for scanning signed Long_Long_Integer -- values for use in Text_IO.Integer_IO, and the Value attribute. --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore, - Subprogram_Variant => Ignore); - with System.Unsigned_Types; with System.Val_LLU; with System.Value_I; -with System.Vs_LLI; -with System.Vs_LLU; package System.Val_LLI with SPARK_Mode is pragma Preelaborate; @@ -58,9 +44,7 @@ package System.Val_LLI with SPARK_Mode is package Impl is new Value_I (Int => Long_Long_Integer, Uns => Long_Long_Unsigned, - Scan_Raw_Unsigned => Val_LLU.Scan_Raw_Long_Long_Unsigned, - U_Spec => System.Vs_LLU.Spec, - Spec => System.Vs_LLI.Spec); + Scan_Raw_Unsigned => Val_LLU.Scan_Raw_Long_Long_Unsigned); procedure Scan_Long_Long_Integer (Str : String; diff --git a/gcc/ada/libgnat/s-valllli.ads b/gcc/ada/libgnat/s-valllli.ads index e2cae26..719d4f4 100644 --- a/gcc/ada/libgnat/s-valllli.ads +++ b/gcc/ada/libgnat/s-valllli.ads @@ -32,23 +32,9 @@ -- This package contains routines for scanning signed Long_Long_Long_Integer -- values for use in Text_IO.Integer_IO, and the Value attribute. --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore, - Subprogram_Variant => Ignore); - with System.Unsigned_Types; with System.Val_LLLU; with System.Value_I; -with System.Vs_LLLI; -with System.Vs_LLLU; package System.Val_LLLI with SPARK_Mode is pragma Preelaborate; @@ -58,9 +44,7 @@ package System.Val_LLLI with SPARK_Mode is package Impl is new Value_I (Int => Long_Long_Long_Integer, Uns => Long_Long_Long_Unsigned, - Scan_Raw_Unsigned => Val_LLLU.Scan_Raw_Long_Long_Long_Unsigned, - U_Spec => System.Vs_LLLU.Spec, - Spec => System.Vs_LLLI.Spec); + Scan_Raw_Unsigned => Val_LLLU.Scan_Raw_Long_Long_Long_Unsigned); procedure Scan_Long_Long_Long_Integer (Str : String; diff --git a/gcc/ada/libgnat/s-vallllu.ads b/gcc/ada/libgnat/s-vallllu.ads index 8e57e51..50a061b 100644 --- a/gcc/ada/libgnat/s-vallllu.ads +++ b/gcc/ada/libgnat/s-vallllu.ads @@ -32,28 +32,15 @@ -- This package contains routines for scanning modular Long_Long_Unsigned -- values for use in Text_IO.Modular_IO, and the Value attribute. --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore, - Subprogram_Variant => Ignore); - with System.Unsigned_Types; with System.Value_U; -with System.Vs_LLLU; package System.Val_LLLU with SPARK_Mode is pragma Preelaborate; subtype Long_Long_Long_Unsigned is Unsigned_Types.Long_Long_Long_Unsigned; - package Impl is new Value_U (Long_Long_Long_Unsigned, System.Vs_LLLU.Spec); + package Impl is new Value_U (Long_Long_Long_Unsigned); procedure Scan_Raw_Long_Long_Long_Unsigned (Str : String; diff --git a/gcc/ada/libgnat/s-valllu.ads b/gcc/ada/libgnat/s-valllu.ads index a7e37fc..eeb9a25 100644 --- a/gcc/ada/libgnat/s-valllu.ads +++ b/gcc/ada/libgnat/s-valllu.ads @@ -32,28 +32,15 @@ -- This package contains routines for scanning modular Long_Long_Unsigned -- values for use in Text_IO.Modular_IO, and the Value attribute. --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore, - Subprogram_Variant => Ignore); - with System.Unsigned_Types; with System.Value_U; -with System.Vs_LLU; package System.Val_LLU with SPARK_Mode is pragma Preelaborate; subtype Long_Long_Unsigned is Unsigned_Types.Long_Long_Unsigned; - package Impl is new Value_U (Long_Long_Unsigned, System.Vs_LLU.Spec); + package Impl is new Value_U (Long_Long_Unsigned); procedure Scan_Raw_Long_Long_Unsigned (Str : String; diff --git a/gcc/ada/libgnat/s-valspe.adb b/gcc/ada/libgnat/s-valspe.adb deleted file mode 100644 index b47e818..0000000 --- a/gcc/ada/libgnat/s-valspe.adb +++ /dev/null @@ -1,87 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . V A L _ S P E C -- --- -- --- B o d y -- --- -- --- Copyright (C) 2023-2025, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Ghost code, loop invariants and assertions in this unit are meant for --- analysis only, not for run-time checking, as it would be too costly --- otherwise. This is enforced by setting the assertion policy to Ignore. - -pragma Assertion_Policy (Ghost => Ignore, - Loop_Invariant => Ignore, - Assert => Ignore); - -package body System.Val_Spec - with SPARK_Mode -is - - --------------------------- - -- First_Non_Space_Ghost -- - --------------------------- - - function First_Non_Space_Ghost - (S : String; - From, To : Integer) return Positive - is - begin - for J in From .. To loop - if S (J) /= ' ' then - return J; - end if; - - pragma Loop_Invariant (for all K in From .. J => S (K) = ' '); - end loop; - - raise Program_Error; - end First_Non_Space_Ghost; - - ----------------------- - -- Last_Number_Ghost -- - ----------------------- - - function Last_Number_Ghost (Str : String) return Positive is - begin - pragma Annotate (Gnatcheck, Exempt_On, "Improper_Returns", - "occurs in ghost code, not executable"); - - for J in Str'Range loop - if Str (J) not in '0' .. '9' | '_' then - return J - 1; - end if; - - pragma Loop_Invariant - (for all K in Str'First .. J => Str (K) in '0' .. '9' | '_'); - end loop; - - return Str'Last; - - pragma Annotate (Gnatcheck, Exempt_Off, "Improper_Returns"); - end Last_Number_Ghost; - -end System.Val_Spec; diff --git a/gcc/ada/libgnat/s-valspe.ads b/gcc/ada/libgnat/s-valspe.ads deleted file mode 100644 index fbd3ba5..0000000 --- a/gcc/ada/libgnat/s-valspe.ads +++ /dev/null @@ -1,246 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . V A L _ S P E C -- --- -- --- S p e c -- --- -- --- Copyright (C) 2023-2025, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package is part of a set of Ghost code packages used to proof the --- implementations of the Image and Value attributes. It provides some common --- specification functions used by the s-valxxx files. - --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore); - -package System.Val_Spec with - SPARK_Mode, - Pure, - Ghost -is - function Only_Space_Ghost (S : String; From, To : Integer) return Boolean is - (for all J in From .. To => S (J) = ' ') - with - Pre => From > To or else (From >= S'First and then To <= S'Last), - Post => True; - -- Ghost function that returns True if S has only space characters from - -- index From to index To. - - function First_Non_Space_Ghost - (S : String; - From, To : Integer) return Positive - with - Pre => From in S'Range - and then To in S'Range - and then not Only_Space_Ghost (S, From, To), - Post => First_Non_Space_Ghost'Result in From .. To - and then S (First_Non_Space_Ghost'Result) /= ' ' - and then Only_Space_Ghost - (S, From, First_Non_Space_Ghost'Result - 1); - -- Ghost function that returns the index of the first non-space character - -- in S, which necessarily exists given the precondition on S. - - function Is_Boolean_Image_Ghost - (Str : String; - Val : Boolean) return Boolean - is - (not Only_Space_Ghost (Str, Str'First, Str'Last) - and then - (declare - F : constant Positive := First_Non_Space_Ghost - (Str, Str'First, Str'Last); - begin - (Val - and then F <= Str'Last - 3 - and then Str (F) in 't' | 'T' - and then Str (F + 1) in 'r' | 'R' - and then Str (F + 2) in 'u' | 'U' - and then Str (F + 3) in 'e' | 'E' - and then - (if F + 3 < Str'Last then - Only_Space_Ghost (Str, F + 4, Str'Last))) - or else - (not Val - and then F <= Str'Last - 4 - and then Str (F) in 'f' | 'F' - and then Str (F + 1) in 'a' | 'A' - and then Str (F + 2) in 'l' | 'L' - and then Str (F + 3) in 's' | 'S' - and then Str (F + 4) in 'e' | 'E' - and then - (if F + 4 < Str'Last then - Only_Space_Ghost (Str, F + 5, Str'Last))))) - with - Ghost; - -- Ghost function that returns True iff Str is the image of boolean Val, - -- that is "true" or "false" in any capitalization, possibly surounded by - -- space characters. - - function Only_Number_Ghost (Str : String; From, To : Integer) return Boolean - is - (for all J in From .. To => Str (J) in '0' .. '9' | '_') - with - Pre => From > To or else (From >= Str'First and then To <= Str'Last); - -- Ghost function that returns True if S has only number characters from - -- index From to index To. - - function Last_Number_Ghost (Str : String) return Positive - with - Pre => Str /= "" and then Str (Str'First) in '0' .. '9', - Post => Last_Number_Ghost'Result in Str'Range - and then (if Last_Number_Ghost'Result < Str'Last then - Str (Last_Number_Ghost'Result + 1) not in '0' .. '9' | '_') - and then Only_Number_Ghost (Str, Str'First, Last_Number_Ghost'Result); - -- Ghost function that returns the index of the last character in S that - -- is either a figure or underscore, which necessarily exists given the - -- precondition on Str. - - function Is_Natural_Format_Ghost (Str : String) return Boolean is - (Str /= "" - and then Str (Str'First) in '0' .. '9' - and then - (declare - L : constant Positive := Last_Number_Ghost (Str); - begin - Str (L) in '0' .. '9' - and then (for all J in Str'First .. L => - (if Str (J) = '_' then Str (J + 1) /= '_')))); - -- Ghost function that determines if Str has the correct format for a - -- natural number, consisting in a sequence of figures possibly separated - -- by single underscores. It may be followed by other characters. - - function Starts_As_Exponent_Format_Ghost - (Str : String; - Real : Boolean := False) return Boolean - is - (Str'Length > 1 - and then Str (Str'First) in 'E' | 'e' - and then - (declare - Plus_Sign : constant Boolean := Str (Str'First + 1) = '+'; - Minus_Sign : constant Boolean := Str (Str'First + 1) = '-'; - Sign : constant Boolean := Plus_Sign or Minus_Sign; - begin - (if Minus_Sign then Real) - and then (if Sign then Str'Length > 2) - and then - (declare - Start : constant Natural := - (if Sign then Str'First + 2 else Str'First + 1); - begin - Str (Start) in '0' .. '9'))); - -- Ghost function that determines if Str is recognized as something which - -- might be an exponent, ie. it starts with an 'e', capitalized or not, - -- followed by an optional sign which can only be '-' if we are working on - -- real numbers (Real is True), and then a digit in decimal notation. - - function Is_Opt_Exponent_Format_Ghost - (Str : String; - Real : Boolean := False) return Boolean - is - (not Starts_As_Exponent_Format_Ghost (Str, Real) - or else - (declare - Start : constant Natural := - (if Str (Str'First + 1) in '+' | '-' then Str'First + 2 - else Str'First + 1); - begin Is_Natural_Format_Ghost (Str (Start .. Str'Last)))); - -- Ghost function that determines if Str has the correct format for an - -- optional exponent, that is, either it does not start as an exponent, or - -- it is in a correct format for a natural number. - - function Scan_Natural_Ghost - (Str : String; - P : Natural; - Acc : Natural) - return Natural - with - Subprogram_Variant => (Increases => P), - Pre => Str /= "" and then Str (Str'First) in '0' .. '9' - and then Str'Last < Natural'Last - and then P in Str'First .. Last_Number_Ghost (Str) + 1; - -- Ghost function that recursively computes the natural number in Str, up - -- to the first number greater or equal to Natural'Last / 10, assuming Acc - -- has been scanned already and scanning continues at index P. - - function Scan_Exponent_Ghost - (Str : String; - Real : Boolean := False) - return Integer - is - (declare - Plus_Sign : constant Boolean := Str (Str'First + 1) = '+'; - Minus_Sign : constant Boolean := Str (Str'First + 1) = '-'; - Sign : constant Boolean := Plus_Sign or Minus_Sign; - Start : constant Natural := - (if Sign then Str'First + 2 else Str'First + 1); - Value : constant Natural := - Scan_Natural_Ghost (Str (Start .. Str'Last), Start, 0); - begin - (if Minus_Sign then -Value else Value)) - with - Pre => Str'Last < Natural'Last - and then Starts_As_Exponent_Format_Ghost (Str, Real), - Post => (if not Real then Scan_Exponent_Ghost'Result >= 0); - -- Ghost function that scans an exponent - -private - - ------------------------ - -- Scan_Natural_Ghost -- - ------------------------ - - function Scan_Natural_Ghost - (Str : String; - P : Natural; - Acc : Natural) - return Natural - is - (if P > Str'Last - or else Str (P) not in '0' .. '9' | '_' - or else Acc >= Integer'Last / 10 - then - Acc - elsif Str (P) = '_' then - Scan_Natural_Ghost (Str, P + 1, Acc) - else - (declare - Shift_Acc : constant Natural := - Acc * 10 + - (Integer'(Character'Pos (Str (P))) - - Integer'(Character'Pos ('0'))); - begin - Scan_Natural_Ghost (Str, P + 1, Shift_Acc))); - -end System.Val_Spec; diff --git a/gcc/ada/libgnat/s-valuei.adb b/gcc/ada/libgnat/s-valuei.adb index 2c4fe09..53790a0 100644 --- a/gcc/ada/libgnat/s-valuei.adb +++ b/gcc/ada/libgnat/s-valuei.adb @@ -33,16 +33,6 @@ with System.Val_Util; use System.Val_Util; package body System.Value_I is - -- Ghost code, loop invariants and assertions in this unit are meant for - -- analysis only, not for run-time checking, as it would be too costly - -- otherwise. This is enforced by setting the assertion policy to Ignore. - - pragma Assertion_Policy (Ghost => Ignore, - Loop_Invariant => Ignore, - Assert => Ignore, - Assert_And_Cut => Ignore, - Subprogram_Variant => Ignore); - ------------------ -- Scan_Integer -- ------------------ @@ -53,25 +43,6 @@ package body System.Value_I is Max : Integer; Res : out Int) is - procedure Prove_Is_Int_Of_Uns - (Minus : Boolean; - Uval : Uns; - Val : Int) - with Ghost, - Pre => Spec.Uns_Is_Valid_Int (Minus, Uval) - and then - (if Minus and then Uval = Uns (Int'Last) + 1 then Val = Int'First - elsif Minus then Val = -(Int (Uval)) - else Val = Int (Uval)), - Post => Spec.Is_Int_Of_Uns (Minus, Uval, Val); - -- Unfold the definition of Is_Int_Of_Uns - - procedure Prove_Is_Int_Of_Uns - (Minus : Boolean; - Uval : Uns; - Val : Int) - is null; - Uval : Uns; -- Unsigned result @@ -81,15 +52,6 @@ package body System.Value_I is Unused_Start : Positive; -- Saves location of first non-blank (not used in this case) - Non_Blank : constant Positive := - First_Non_Space_Ghost (Str, Ptr.all, Max) - with Ghost; - - Fst_Num : constant Positive := - (if Str (Non_Blank) in '+' | '-' then Non_Blank + 1 - else Non_Blank) - with Ghost; - begin Scan_Sign (Str, Ptr, Max, Minus, Unused_Start); @@ -99,8 +61,6 @@ package body System.Value_I is end if; Scan_Raw_Unsigned (Str, Ptr, Max, Uval); - pragma Assert - (Uval = U_Spec.Scan_Raw_Unsigned_Ghost (Str, Fst_Num, Max)); -- Deal with overflow cases, and also with largest negative number @@ -121,11 +81,6 @@ package body System.Value_I is else Res := Int (Uval); end if; - - Prove_Is_Int_Of_Uns - (Minus => Str (Non_Blank) = '-', - Uval => Uval, - Val => Res); end Scan_Integer; ------------------- @@ -141,15 +96,7 @@ package body System.Value_I is if Str'Last = Positive'Last then declare subtype NT is String (1 .. Str'Length); - procedure Prove_Is_Integer_Ghost with - Ghost, - Pre => Str'Length < Natural'Last - and then not Only_Space_Ghost (Str, Str'First, Str'Last) - and then Spec.Is_Integer_Ghost (Spec.Slide_To_1 (Str)), - Post => Spec.Is_Integer_Ghost (NT (Str)); - procedure Prove_Is_Integer_Ghost is null; begin - Prove_Is_Integer_Ghost; return Value_Integer (NT (Str)); end; @@ -159,31 +106,14 @@ package body System.Value_I is declare V : Int; P : aliased Integer := Str'First; - - Non_Blank : constant Positive := First_Non_Space_Ghost - (Str, Str'First, Str'Last) - with Ghost; - - Fst_Num : constant Positive := - (if Str (Non_Blank) in '+' | '-' then Non_Blank + 1 - else Non_Blank) - with Ghost; begin - declare P_Acc : constant not null access Integer := P'Access; begin Scan_Integer (Str, P_Acc, Str'Last, V); end; - pragma Assert - (P = U_Spec.Raw_Unsigned_Last_Ghost - (Str, Fst_Num, Str'Last)); - Scan_Trailing_Blanks (Str, P); - - pragma Assert - (Spec.Is_Value_Integer_Ghost (Spec.Slide_If_Necessary (Str), V)); return V; end; end if; diff --git a/gcc/ada/libgnat/s-valuei.ads b/gcc/ada/libgnat/s-valuei.ads index 531eae1..08619c8 100644 --- a/gcc/ada/libgnat/s-valuei.ads +++ b/gcc/ada/libgnat/s-valuei.ads @@ -32,16 +32,6 @@ -- This package contains routines for scanning signed integer values for use -- in Text_IO.Integer_IO, and the Value attribute. -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore, - Subprogram_Variant => Ignore); - -with System.Val_Spec; use System.Val_Spec; -with System.Value_I_Spec; -with System.Value_U_Spec; - generic type Int is range <>; @@ -54,13 +44,6 @@ generic Max : Integer; Res : out Uns); - -- Additional parameters for ghost subprograms used inside contracts - - with package U_Spec is new System.Value_U_Spec (Uns => Uns) with Ghost; - with package Spec is new System.Value_I_Spec - (Int => Int, Uns => Uns, U_Spec => U_Spec) - with Ghost; - package System.Value_I is pragma Preelaborate; @@ -68,43 +51,7 @@ package System.Value_I is (Str : String; Ptr : not null access Integer; Max : Integer; - Res : out Int) - with - Pre => Str'Last /= Positive'Last - -- Ptr.all .. Max is either an empty range, or a valid range in Str - and then (Ptr.all > Max - or else (Ptr.all >= Str'First and then Max <= Str'Last)) - and then not Only_Space_Ghost (Str, Ptr.all, Max) - and then - (declare - Non_Blank : constant Positive := First_Non_Space_Ghost - (Str, Ptr.all, Max); - Fst_Num : constant Positive := - (if Str (Non_Blank) in '+' | '-' then Non_Blank + 1 - else Non_Blank); - begin - U_Spec.Is_Raw_Unsigned_Format_Ghost (Str (Fst_Num .. Max)) - and then U_Spec.Raw_Unsigned_No_Overflow_Ghost - (Str, Fst_Num, Max) - and then Spec.Uns_Is_Valid_Int - (Minus => Str (Non_Blank) = '-', - Uval => U_Spec.Scan_Raw_Unsigned_Ghost - (Str, Fst_Num, Max))), - Post => - (declare - Non_Blank : constant Positive := First_Non_Space_Ghost - (Str, Ptr.all'Old, Max); - Fst_Num : constant Positive := - (if Str (Non_Blank) in '+' | '-' then Non_Blank + 1 - else Non_Blank); - Uval : constant Uns := - U_Spec.Scan_Raw_Unsigned_Ghost (Str, Fst_Num, Max); - begin - Spec.Is_Int_Of_Uns (Minus => Str (Non_Blank) = '-', - Uval => Uval, - Val => Res) - and then Ptr.all = U_Spec.Raw_Unsigned_Last_Ghost - (Str, Fst_Num, Max)); + Res : out Int); -- This procedure scans the string starting at Str (Ptr.all) for a valid -- integer according to the syntax described in (RM 3.5(43)). The substring -- scanned extends no further than Str (Max). There are three cases for the @@ -130,14 +77,7 @@ package System.Value_I is -- special case of an all-blank string, and Ptr is unchanged, and hence -- is greater than Max as required in this case. - function Value_Integer (Str : String) return Int - with - Pre => not Only_Space_Ghost (Str, Str'First, Str'Last) - and then Str'Length /= Positive'Last - and then Spec.Is_Integer_Ghost (Spec.Slide_If_Necessary (Str)), - Post => Spec.Is_Value_Integer_Ghost - (Spec.Slide_If_Necessary (Str), Value_Integer'Result), - Subprogram_Variant => (Decreases => Str'First); + function Value_Integer (Str : String) return Int; -- Used in computing X'Value (Str) where X is a signed integer type whose -- base range does not exceed the base range of Integer. Str is the string -- argument of the attribute. Constraint_Error is raised if the string is diff --git a/gcc/ada/libgnat/s-valueu.adb b/gcc/ada/libgnat/s-valueu.adb index e6f1d5e..72e73a8 100644 --- a/gcc/ada/libgnat/s-valueu.adb +++ b/gcc/ada/libgnat/s-valueu.adb @@ -29,78 +29,10 @@ -- -- ------------------------------------------------------------------------------ -with System.SPARK.Cut_Operations; use System.SPARK.Cut_Operations; with System.Val_Util; use System.Val_Util; package body System.Value_U is - -- Ghost code, loop invariants and assertions in this unit are meant for - -- analysis only, not for run-time checking, as it would be too costly - -- otherwise. This is enforced by setting the assertion policy to Ignore. - - pragma Assertion_Policy (Ghost => Ignore, - Loop_Invariant => Ignore, - Assert => Ignore, - Assert_And_Cut => Ignore, - Subprogram_Variant => Ignore); - - use type Spec.Uns_Option; - use type Spec.Split_Value_Ghost; - - -- Local lemmas - - procedure Lemma_Digit_Not_Last - (Str : String; - P : Integer; - From : Integer; - To : Integer) - with Ghost, - Pre => Str'Last /= Positive'Last - and then From in Str'Range - and then To in From .. Str'Last - and then Str (From) in '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' - and then P in From .. To - and then P <= Spec.Last_Hexa_Ghost (Str (From .. To)) + 1 - and then Spec.Is_Based_Format_Ghost (Str (From .. To)), - Post => - (if Str (P) in '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' - then P <= Spec.Last_Hexa_Ghost (Str (From .. To))); - - procedure Lemma_Underscore_Not_Last - (Str : String; - P : Integer; - From : Integer; - To : Integer) - with Ghost, - Pre => Str'Last /= Positive'Last - and then From in Str'Range - and then To in From .. Str'Last - and then Str (From) in '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' - and then P in From .. To - and then Str (P) = '_' - and then P <= Spec.Last_Hexa_Ghost (Str (From .. To)) + 1 - and then Spec.Is_Based_Format_Ghost (Str (From .. To)), - Post => P + 1 <= Spec.Last_Hexa_Ghost (Str (From .. To)) - and then Str (P + 1) in '0' .. '9' | 'a' .. 'f' | 'A' .. 'F'; - - ----------------------------- - -- Local lemma null bodies -- - ----------------------------- - - procedure Lemma_Digit_Not_Last - (Str : String; - P : Integer; - From : Integer; - To : Integer) - is null; - - procedure Lemma_Underscore_Not_Last - (Str : String; - P : Integer; - From : Integer; - To : Integer) - is null; - ----------------------- -- Scan_Raw_Unsigned -- ----------------------- @@ -132,36 +64,6 @@ package body System.Value_U is Digit : Uns; -- Digit value - Ptr_Old : constant Integer := Ptr.all - with Ghost; - Last_Num_Init : constant Integer := - Last_Number_Ghost (Str (Ptr.all .. Max)) - with Ghost; - Init_Val : constant Spec.Uns_Option := - Spec.Scan_Based_Number_Ghost (Str, Ptr.all, Last_Num_Init) - with Ghost; - Starts_As_Based : constant Boolean := - Spec.Raw_Unsigned_Starts_As_Based_Ghost (Str, Last_Num_Init, Max) - with Ghost; - Last_Num_Based : constant Integer := - (if Starts_As_Based - then Spec.Last_Hexa_Ghost (Str (Last_Num_Init + 2 .. Max)) - else Last_Num_Init) - with Ghost; - Is_Based : constant Boolean := - Spec.Raw_Unsigned_Is_Based_Ghost - (Str, Last_Num_Init, Last_Num_Based, Max) - with Ghost; - Based_Val : constant Spec.Uns_Option := - (if Starts_As_Based and then not Init_Val.Overflow - then Spec.Scan_Based_Number_Ghost - (Str, Last_Num_Init + 2, Last_Num_Based, Init_Val.Value) - else Init_Val) - with Ghost; - First_Exp : constant Integer := - (if Is_Based then Last_Num_Based + 2 else Last_Num_Init + 1) - with Ghost; - begin -- We do not tolerate strings with Str'Last = Positive'Last @@ -171,7 +73,6 @@ package body System.Value_U is end if; P := Ptr.all; - Spec.Lemma_Scan_Based_Number_Ghost_Step (Str, P, Last_Num_Init); Uval := Character'Pos (Str (P)) - Character'Pos ('0'); pragma Assert (Str (P) in '0' .. '9'); P := P + 1; @@ -189,14 +90,6 @@ package body System.Value_U is begin -- Loop through decimal digits loop - pragma Loop_Invariant (P in P'Loop_Entry .. Last_Num_Init + 1); - pragma Loop_Invariant - (if Overflow then Init_Val.Overflow); - pragma Loop_Invariant - (if not Overflow - then Init_Val = Spec.Scan_Based_Number_Ghost - (Str, P, Last_Num_Init, Acc => Uval)); - exit when P > Max; Digit := Character'Pos (Str (P)) - Character'Pos ('0'); @@ -205,8 +98,6 @@ package body System.Value_U is if Digit > 9 then if Str (P) = '_' then - Spec.Lemma_Scan_Based_Number_Ghost_Underscore - (Str, P, Last_Num_Init, Acc => Uval); Scan_Underscore (Str, P, Ptr, Max, False); else exit; @@ -215,55 +106,23 @@ package body System.Value_U is -- Accumulate result, checking for overflow else - pragma Assert - (By - (Str (P) in '0' .. '9', - By - (Character'Pos (Str (P)) >= Character'Pos ('0'), - Uns '(Character'Pos (Str (P))) >= - Character'Pos ('0')))); - Spec.Lemma_Scan_Based_Number_Ghost_Step - (Str, P, Last_Num_Init, Acc => Uval); - Spec.Lemma_Scan_Based_Number_Ghost_Overflow - (Str, P, Last_Num_Init, Acc => Uval); - if Uval <= Umax then Uval := 10 * Uval + Digit; - pragma Assert - (if not Overflow - then Init_Val = Spec.Scan_Based_Number_Ghost - (Str, P + 1, Last_Num_Init, Acc => Uval)); - elsif Uval > Umax10 then Overflow := True; - else Uval := 10 * Uval + Digit; if Uval < Umax10 then Overflow := True; end if; - pragma Assert - (if not Overflow - then Init_Val = Spec.Scan_Based_Number_Ghost - (Str, P + 1, Last_Num_Init, Acc => Uval)); - end if; P := P + 1; end if; end loop; - Spec.Lemma_Scan_Based_Number_Ghost_Base - (Str, P, Last_Num_Init, Acc => Uval); end; - pragma Assert_And_Cut - (By - (P = Last_Num_Init + 1, - P > Max or else Str (P) not in '_' | '0' .. '9') - and then Overflow = Init_Val.Overflow - and then (if not Overflow then Init_Val.Value = Uval)); - Ptr.all := P; -- Deal with based case. We recognize either the standard '#' or the @@ -295,10 +154,6 @@ package body System.Value_U is -- Numbers bigger than UmaxB overflow if multiplied by base begin - pragma Assert - (if Str (P) in '0' .. '9' | 'A' .. 'F' | 'a' .. 'f' - then Spec.Is_Based_Format_Ghost (Str (P .. Max))); - -- Loop to scan out based integer value loop @@ -321,49 +176,11 @@ package body System.Value_U is -- already stored in Ptr.all. else - pragma Assert - (By - (Spec.Only_Hexa_Ghost (Str, P, Last_Num_Based), - P > Last_Num_Init + 1 - and Spec.Only_Hexa_Ghost - (Str, Last_Num_Init + 2, Last_Num_Based))); - Spec.Lemma_Scan_Based_Number_Ghost_Base - (Str, P, Last_Num_Based, Base, Uval); Uval := Base; Base := 10; - pragma Assert (Ptr.all = Last_Num_Init + 1); - pragma Assert - (if Starts_As_Based - then By - (P = Last_Num_Based + 1, - P <= Last_Num_Based + 1 - and Str (P) not in - '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' | '_')); - pragma Assert (not Is_Based); - pragma Assert (if not Overflow then Uval = Init_Val.Value); exit; end if; - pragma Loop_Invariant (P in P'Loop_Entry .. Last_Num_Based); - pragma Loop_Invariant - (Str (P) in '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' - and then Digit = Spec.Hexa_To_Unsigned_Ghost (Str (P))); - pragma Loop_Invariant - (if Overflow'Loop_Entry then Overflow); - pragma Loop_Invariant - (if Overflow then - (Overflow'Loop_Entry or else Based_Val.Overflow)); - pragma Loop_Invariant - (if not Overflow - then Based_Val = Spec.Scan_Based_Number_Ghost - (Str, P, Last_Num_Based, Base, Uval)); - pragma Loop_Invariant (Ptr.all = Last_Num_Init + 1); - - Spec.Lemma_Scan_Based_Number_Ghost_Step - (Str, P, Last_Num_Based, Base, Uval); - Spec.Lemma_Scan_Based_Number_Ghost_Overflow - (Str, P, Last_Num_Based, Base, Uval); - -- If digit is too large, just signal overflow and continue. -- The idea here is to keep scanning as long as the input is -- syntactically valid, even if we have detected overflow @@ -375,24 +192,14 @@ package body System.Value_U is elsif Uval <= Umax then Uval := Base * Uval + Digit; - pragma Assert - (if not Overflow - then Based_Val = Spec.Scan_Based_Number_Ghost - (Str, P + 1, Last_Num_Based, Base, Uval)); - elsif Uval > UmaxB then Overflow := True; - else Uval := Base * Uval + Digit; if Uval < UmaxB then Overflow := True; end if; - pragma Assert - (if not Overflow - then Based_Val = Spec.Scan_Based_Number_Ghost - (Str, P + 1, Last_Num_Based, Base, Uval)); end if; -- If at end of string with no base char, not a based number @@ -411,86 +218,22 @@ package body System.Value_U is if Str (P) = Base_Char then Ptr.all := P + 1; - pragma Assert (P = Last_Num_Based + 1); - pragma Assert (Ptr.all = Last_Num_Based + 2); - pragma Assert - (By - (Is_Based, - So - (Starts_As_Based, - So - (Last_Num_Based < Max, - Str (Last_Num_Based + 1) = Base_Char - and Base_Char = Str (Last_Num_Init + 1))))); - Spec.Lemma_Scan_Based_Number_Ghost_Base - (Str, P, Last_Num_Based, Base, Uval); exit; -- Deal with underscore elsif Str (P) = '_' then - Lemma_Underscore_Not_Last (Str, P, Last_Num_Init + 2, Max); - Spec.Lemma_Scan_Based_Number_Ghost_Underscore - (Str, P, Last_Num_Based, Base, Uval); Scan_Underscore (Str, P, Ptr, Max, True); - pragma Assert - (if not Overflow - then Based_Val = Spec.Scan_Based_Number_Ghost - (Str, P, Last_Num_Based, Base, Uval)); - pragma Assert (Str (P) not in '_' | Base_Char); end if; - - Lemma_Digit_Not_Last (Str, P, Last_Num_Init + 2, Max); - pragma Assert (Str (P) not in '_' | Base_Char); end loop; end; - pragma Assert - (if Starts_As_Based then P = Last_Num_Based + 1 - else P = Last_Num_Init + 2); - pragma Assert - (By - (Overflow /= Spec.Scan_Split_No_Overflow_Ghost - (Str, Ptr_Old, Max), - So - (Last_Num_Init < Max - 1 - and then Str (Last_Num_Init + 1) in '#' | ':', - Overflow = - (Init_Val.Overflow - or else Init_Val.Value not in 2 .. 16 - or else (Starts_As_Based and Based_Val.Overflow))))); end if; - pragma Assert_And_Cut - (Overflow /= Spec.Scan_Split_No_Overflow_Ghost (Str, Ptr_Old, Max) - and then Ptr.all = First_Exp - and then Base in 2 .. 16 - and then - (if not Overflow then - (if Is_Based then Base = Init_Val.Value else Base = 10)) - and then - (if not Overflow then - (if Is_Based then Uval = Based_Val.Value - else Uval = Init_Val.Value))); - -- Come here with scanned unsigned value in Uval. The only remaining -- required step is to deal with exponent if one is present. Scan_Exponent (Str, Ptr, Max, Expon); - pragma Assert - (By - (Ptr.all = Spec.Raw_Unsigned_Last_Ghost (Str, Ptr_Old, Max), - Ptr.all = - (if not Starts_As_Exponent_Format_Ghost (Str (First_Exp .. Max)) - then First_Exp - elsif Str (First_Exp + 1) in '-' | '+' then - Last_Number_Ghost (Str (First_Exp + 2 .. Max)) + 1 - else Last_Number_Ghost (Str (First_Exp + 1 .. Max)) + 1))); - pragma Assert - (if not Overflow - then Spec.Scan_Split_Value_Ghost (Str, Ptr_Old, Max) = - (Uval, Base, Expon)); - if Expon /= 0 and then Uval /= 0 then -- For non-zero value, scale by exponent value. No need to do this @@ -500,66 +243,22 @@ package body System.Value_U is declare UmaxB : constant Uns := Uns'Last / Base; -- Numbers bigger than UmaxB overflow if multiplied by base - - Res_Val : constant Spec.Uns_Option := - Spec.Exponent_Unsigned_Ghost (Uval, Expon, Base) - with Ghost; begin for J in 1 .. Expon loop - pragma Loop_Invariant - (if Overflow'Loop_Entry then Overflow); - pragma Loop_Invariant - (if Overflow - then Overflow'Loop_Entry or else Res_Val.Overflow); - pragma Loop_Invariant (Uval /= 0); - pragma Loop_Invariant - (if not Overflow - then Res_Val = Spec.Exponent_Unsigned_Ghost - (Uval, Expon - J + 1, Base)); - - pragma Assert - ((Uval > UmaxB) = Spec.Scan_Overflows_Ghost (0, Base, Uval)); - if Uval > UmaxB then - Spec.Lemma_Exponent_Unsigned_Ghost_Overflow - (Uval, Expon - J + 1, Base); Overflow := True; exit; end if; - Spec.Lemma_Exponent_Unsigned_Ghost_Step - (Uval, Expon - J + 1, Base); - Uval := Uval * Base; end loop; - Spec.Lemma_Exponent_Unsigned_Ghost_Base (Uval, 0, Base); - - pragma Assert - (Overflow /= - Spec.Raw_Unsigned_No_Overflow_Ghost (Str, Ptr_Old, Max)); - pragma Assert (if not Overflow then Res_Val = (False, Uval)); end; end if; - Spec.Lemma_Exponent_Unsigned_Ghost_Base (Uval, Expon, Base); - pragma Assert - (if Expon = 0 or else Uval = 0 then - Spec.Exponent_Unsigned_Ghost (Uval, Expon, Base) = (False, Uval)); - pragma Assert - (Overflow /= - Spec.Raw_Unsigned_No_Overflow_Ghost (Str, Ptr_Old, Max)); - pragma Assert - (if not Overflow then - Uval = Spec.Scan_Raw_Unsigned_Ghost (Str, Ptr_Old, Max)); -- Return result, dealing with overflow if Overflow then Bad_Value (Str); - pragma Annotate - (GNATprove, Intentional, - "call to nonreturning subprogram might be executed", - "it is expected that Constraint_Error is raised in case of" - & " overflow"); else Res := Uval; end if; @@ -608,15 +307,7 @@ package body System.Value_U is if Str'Last = Positive'Last then declare subtype NT is String (1 .. Str'Length); - procedure Prove_Is_Unsigned_Ghost with - Ghost, - Pre => Str'Length < Natural'Last - and then not Only_Space_Ghost (Str, Str'First, Str'Last) - and then Spec.Is_Unsigned_Ghost (Spec.Slide_To_1 (Str)), - Post => Spec.Is_Unsigned_Ghost (NT (Str)); - procedure Prove_Is_Unsigned_Ghost is null; begin - Prove_Is_Unsigned_Ghost; return Value_Unsigned (NT (Str)); end; @@ -626,12 +317,6 @@ package body System.Value_U is declare V : Uns; P : aliased Integer := Str'First; - Non_Blank : constant Positive := First_Non_Space_Ghost - (Str, Str'First, Str'Last) - with Ghost; - Fst_Num : constant Positive := - (if Str (Non_Blank) = '+' then Non_Blank + 1 else Non_Blank) - with Ghost; begin declare P_Acc : constant not null access Integer := P'Access; @@ -639,16 +324,7 @@ package body System.Value_U is Scan_Unsigned (Str, P_Acc, Str'Last, V); end; - pragma Assert - (P = Spec.Raw_Unsigned_Last_Ghost (Str, Fst_Num, Str'Last)); - pragma Assert - (V = Spec.Scan_Raw_Unsigned_Ghost (Str, Fst_Num, Str'Last)); - Scan_Trailing_Blanks (Str, P); - - pragma Assert - (Spec.Is_Value_Unsigned_Ghost - (Spec.Slide_If_Necessary (Str), V)); return V; end; end if; diff --git a/gcc/ada/libgnat/s-valueu.ads b/gcc/ada/libgnat/s-valueu.ads index 92e3ffe..0dc3399 100644 --- a/gcc/ada/libgnat/s-valueu.ads +++ b/gcc/ada/libgnat/s-valueu.ads @@ -32,29 +32,8 @@ -- This package contains routines for scanning modular Unsigned -- values for use in Text_IO.Modular_IO, and the Value attribute. --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore, - Subprogram_Variant => Ignore); - -with System.Value_U_Spec; -with System.Val_Spec; use System.Val_Spec; - generic - type Uns is mod <>; - - -- Additional parameters for ghost subprograms used inside contracts - - with package Spec is new System.Value_U_Spec (Uns => Uns) with Ghost; - package System.Value_U is pragma Preelaborate; @@ -62,15 +41,7 @@ package System.Value_U is (Str : String; Ptr : not null access Integer; Max : Integer; - Res : out Uns) - with Pre => Str'Last /= Positive'Last - and then Ptr.all in Str'Range - and then Max in Ptr.all .. Str'Last - and then Spec.Is_Raw_Unsigned_Format_Ghost (Str (Ptr.all .. Max)), - Post => Spec.Raw_Unsigned_No_Overflow_Ghost (Str, Ptr.all'Old, Max) - and Res = Spec.Scan_Raw_Unsigned_Ghost (Str, Ptr.all'Old, Max) - and Ptr.all = Spec.Raw_Unsigned_Last_Ghost (Str, Ptr.all'Old, Max); - + Res : out Uns); -- This function scans the string starting at Str (Ptr.all) for a valid -- integer according to the syntax described in (RM 3.5(43)). The substring -- scanned extends no further than Str (Max). Note: this does not scan @@ -145,45 +116,14 @@ package System.Value_U is (Str : String; Ptr : not null access Integer; Max : Integer; - Res : out Uns) - with Pre => Str'Last /= Positive'Last - and then Ptr.all in Str'Range - and then Max in Ptr.all .. Str'Last - and then not Only_Space_Ghost (Str, Ptr.all, Max) - and then - (declare - Non_Blank : constant Positive := - First_Non_Space_Ghost (Str, Ptr.all, Max); - Fst_Num : constant Positive := - (if Str (Non_Blank) = '+' then Non_Blank + 1 else Non_Blank); - begin - Spec.Is_Raw_Unsigned_Format_Ghost (Str (Fst_Num .. Max))), - Post => - (declare - Non_Blank : constant Positive := - First_Non_Space_Ghost (Str, Ptr.all'Old, Max); - Fst_Num : constant Positive := - (if Str (Non_Blank) = '+' then Non_Blank + 1 else Non_Blank); - begin - Spec.Raw_Unsigned_No_Overflow_Ghost (Str, Fst_Num, Max) - and then Res = Spec.Scan_Raw_Unsigned_Ghost (Str, Fst_Num, Max) - and then Ptr.all = Spec.Raw_Unsigned_Last_Ghost (Str, Fst_Num, Max)); - + Res : out Uns); -- Same as Scan_Raw_Unsigned, except scans optional leading -- blanks, and an optional leading plus sign. -- -- Note: if a minus sign is present, Constraint_Error will be raised. -- Note: trailing blanks are not scanned. - function Value_Unsigned - (Str : String) return Uns - with Pre => Str'Length /= Positive'Last - and then not Only_Space_Ghost (Str, Str'First, Str'Last) - and then Spec.Is_Unsigned_Ghost (Spec.Slide_If_Necessary (Str)), - Post => - Spec.Is_Value_Unsigned_Ghost - (Spec.Slide_If_Necessary (Str), Value_Unsigned'Result), - Subprogram_Variant => (Decreases => Str'First); + function Value_Unsigned (Str : String) return Uns; -- Used in computing X'Value (Str) where X is a modular integer type whose -- modulus does not exceed the range of System.Unsigned_Types.Unsigned. Str -- is the string argument of the attribute. Constraint_Error is raised if diff --git a/gcc/ada/libgnat/s-valuns.ads b/gcc/ada/libgnat/s-valuns.ads index 8bbb7fb..a015c12 100644 --- a/gcc/ada/libgnat/s-valuns.ads +++ b/gcc/ada/libgnat/s-valuns.ads @@ -32,28 +32,15 @@ -- This package contains routines for scanning modular Unsigned -- values for use in Text_IO.Modular_IO, and the Value attribute. --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore, - Subprogram_Variant => Ignore); - with System.Unsigned_Types; with System.Value_U; -with System.Vs_Uns; package System.Val_Uns with SPARK_Mode is pragma Preelaborate; subtype Unsigned is Unsigned_Types.Unsigned; - package Impl is new Value_U (Unsigned, System.Vs_Uns.Spec); + package Impl is new Value_U (Unsigned); procedure Scan_Raw_Unsigned (Str : String; diff --git a/gcc/ada/libgnat/s-valuti.adb b/gcc/ada/libgnat/s-valuti.adb index a2b79f1..6332137 100644 --- a/gcc/ada/libgnat/s-valuti.adb +++ b/gcc/ada/libgnat/s-valuti.adb @@ -29,14 +29,6 @@ -- -- ------------------------------------------------------------------------------ --- Ghost code, loop invariants and assertions in this unit are meant for --- analysis only, not for run-time checking, as it would be too costly --- otherwise. This is enforced by setting the assertion policy to Ignore. - -pragma Assertion_Policy (Ghost => Ignore, - Loop_Invariant => Ignore, - Assert => Ignore); - with System.Case_Util; use System.Case_Util; package body System.Val_Util @@ -48,12 +40,11 @@ is --------------- procedure Bad_Value (S : String) is - pragma Annotate (GNATprove, Intentional, "exception might be raised", - "Intentional exception from Bad_Value"); begin -- Bad_Value might be called with very long strings allocated on the -- heap. Limit the size of the message so that we avoid creating a -- Storage_Error during error handling. + if S'Length > 127 then raise Constraint_Error with "bad input for 'Value: """ & S (S'First .. S'First + 127) & "..."""; @@ -69,8 +60,7 @@ is procedure Normalize_String (S : in out String; F, L : out Integer; - To_Upper_Case : Boolean) - is + To_Upper_Case : Boolean) is begin F := S'First; L := S'Last; @@ -84,9 +74,6 @@ is -- Scan for leading spaces while F < L and then S (F) = ' ' loop - pragma Loop_Invariant (F in S'First .. L - 1); - pragma Loop_Invariant (for all J in S'First .. F => S (J) = ' '); - pragma Loop_Variant (Increases => F); F := F + 1; end loop; @@ -101,9 +88,6 @@ is -- Scan for trailing spaces while S (L) = ' ' loop - pragma Loop_Invariant (L in F + 1 .. S'Last); - pragma Loop_Invariant (for all J in L .. S'Last => S (J) = ' '); - pragma Loop_Variant (Decreases => L); L := L - 1; end loop; @@ -112,8 +96,6 @@ is if To_Upper_Case and then S (F) /= ''' then for J in F .. L loop S (J) := To_Upper (S (J)); - pragma Loop_Invariant - (for all K in F .. J => S (K) = To_Upper (S'Loop_Entry (K))); end loop; end if; end Normalize_String; @@ -185,40 +167,23 @@ is X := 0; - declare - Rest : constant String := Str (P .. Max) with Ghost; - Last : constant Natural := Sp.Last_Number_Ghost (Rest) with Ghost; - - begin - pragma Assert (Sp.Is_Natural_Format_Ghost (Rest)); - - loop - pragma Assert (Str (P) in '0' .. '9'); + loop + pragma Assert (Str (P) in '0' .. '9'); - if X < (Integer'Last / 10) then - X := X * 10 + (Character'Pos (Str (P)) - Character'Pos ('0')); - end if; - - pragma Loop_Invariant (X >= 0); - pragma Loop_Invariant (P in Rest'First .. Last); - pragma Loop_Invariant (Str (P) in '0' .. '9'); - pragma Loop_Invariant - (Sp.Scan_Natural_Ghost (Rest, Rest'First, 0) - = Sp.Scan_Natural_Ghost (Rest, P + 1, X)); - - P := P + 1; + if X < (Integer'Last / 10) then + X := X * 10 + (Character'Pos (Str (P)) - Character'Pos ('0')); + end if; - exit when P > Max; + P := P + 1; - if Str (P) = '_' then - Scan_Underscore (Str, P, Ptr, Max, False); - else - exit when Str (P) not in '0' .. '9'; - end if; - end loop; + exit when P > Max; - pragma Assert (P = Last + 1); - end; + if Str (P) = '_' then + Scan_Underscore (Str, P, Ptr, Max, False); + else + exit when Str (P) not in '0' .. '9'; + end if; + end loop; if M then X := -X; @@ -250,12 +215,6 @@ is while Str (P) = ' ' loop P := P + 1; - pragma Loop_Invariant (Ptr.all = Ptr.all'Loop_Entry); - pragma Loop_Invariant (P in Ptr.all .. Max); - pragma Loop_Invariant (for some J in P .. Max => Str (J) /= ' '); - pragma Loop_Invariant - (for all J in Ptr.all .. P - 1 => Str (J) = ' '); - if P > Max then Ptr.all := P; Bad_Value (Str); @@ -264,8 +223,6 @@ is Start := P; - pragma Assert (Start = Sp.First_Non_Space_Ghost (Str, Ptr.all, Max)); - -- Skip past an initial plus sign if Str (P) = '+' then @@ -292,7 +249,6 @@ is Start : out Positive) is P : Integer := Ptr.all; - begin -- Deal with case of null string (all blanks). As per spec, we raise -- constraint error, with Ptr unchanged, and thus > Max. @@ -306,12 +262,6 @@ is while Str (P) = ' ' loop P := P + 1; - pragma Loop_Invariant (Ptr.all = Ptr.all'Loop_Entry); - pragma Loop_Invariant (P in Ptr.all .. Max); - pragma Loop_Invariant (for some J in P .. Max => Str (J) /= ' '); - pragma Loop_Invariant - (for all J in Ptr.all .. P - 1 => Str (J) = ' '); - if P > Max then Ptr.all := P; Bad_Value (Str); @@ -320,8 +270,6 @@ is Start := P; - pragma Assert (Start = Sp.First_Non_Space_Ghost (Str, Ptr.all, Max)); - -- Remember an initial minus sign if Str (P) = '-' then @@ -361,8 +309,6 @@ is if Str (J) /= ' ' then Bad_Value (Str); end if; - - pragma Loop_Invariant (for all K in P .. J => Str (K) = ' '); end loop; end Scan_Trailing_Blanks; @@ -378,7 +324,6 @@ is Ext : Boolean) is C : Character; - begin P := P + 1; diff --git a/gcc/ada/libgnat/s-valuti.ads b/gcc/ada/libgnat/s-valuti.ads index 8720c41..4a299ca 100644 --- a/gcc/ada/libgnat/s-valuti.ads +++ b/gcc/ada/libgnat/s-valuti.ads @@ -31,59 +31,16 @@ -- This package provides some common utilities used by the s-valxxx files --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore); - -with System.Case_Util; -with System.Val_Spec; - package System.Val_Util with SPARK_Mode, Pure is - pragma Unevaluated_Use_Of_Old (Allow); - - package Sp renames System.Val_Spec; - - procedure Bad_Value (S : String) - with - Always_Terminates, - Depends => (null => S), - Exceptional_Cases => (others => Standard.False); - pragma No_Return (Bad_Value); + procedure Bad_Value (S : String) with No_Return; -- Raises constraint error with message: bad input for 'Value: "xxx" procedure Normalize_String (S : in out String; F, L : out Integer; - To_Upper_Case : Boolean) - with - Post => (if Sp.Only_Space_Ghost (S'Old, S'First, S'Last) then - F > L - else - F >= S'First - and then L <= S'Last - and then F <= L - and then Sp.Only_Space_Ghost (S'Old, S'First, F - 1) - and then S'Old (F) /= ' ' - and then S'Old (L) /= ' ' - and then - (if L < S'Last then - Sp.Only_Space_Ghost (S'Old, L + 1, S'Last)) - and then - (if To_Upper_Case and then S'Old (F) /= ''' then - (for all J in S'Range => - (if J in F .. L then - S (J) = System.Case_Util.To_Upper (S'Old (J)) - else - S (J) = S'Old (J))))); + To_Upper_Case : Boolean); -- This procedure scans the string S setting F to be the index of the first -- non-blank character of S and L to be the index of the last non-blank -- character of S. If To_Upper_Case is True and S does not represent a @@ -96,27 +53,7 @@ is Ptr : not null access Integer; Max : Integer; Minus : out Boolean; - Start : out Positive) - with - Pre => - -- Ptr.all .. Max is either an empty range, or a valid range in Str - (Ptr.all > Max or else (Ptr.all >= Str'First and then Max <= Str'Last)) - and then not Sp.Only_Space_Ghost (Str, Ptr.all, Max) - and then - (declare - F : constant Positive := - Sp.First_Non_Space_Ghost (Str, Ptr.all, Max); - begin - (if Str (F) in '+' | '-' then - F <= Max - 1 and then Str (F + 1) /= ' ')), - Post => - (declare - F : constant Positive := - Sp.First_Non_Space_Ghost (Str, Ptr.all'Old, Max); - begin - Minus = (Str (F) = '-') - and then Ptr.all = (if Str (F) in '+' | '-' then F + 1 else F) - and then Start = F); + Start : out Positive); -- The Str, Ptr, Max parameters are as for the scan routines (Str is the -- string to be scanned starting at Ptr.all, and Max is the index of the -- last character in the string). Scan_Sign first scans out any initial @@ -140,26 +77,7 @@ is (Str : String; Ptr : not null access Integer; Max : Integer; - Start : out Positive) - with - Pre => - -- Ptr.all .. Max is either an empty range, or a valid range in Str - (Ptr.all > Max or else (Ptr.all >= Str'First and then Max <= Str'Last)) - and then not Sp.Only_Space_Ghost (Str, Ptr.all, Max) - and then - (declare - F : constant Positive := - Sp.First_Non_Space_Ghost (Str, Ptr.all, Max); - begin - (if Str (F) = '+' then - F <= Max - 1 and then Str (F + 1) /= ' ')), - Post => - (declare - F : constant Positive := - Sp.First_Non_Space_Ghost (Str, Ptr.all'Old, Max); - begin - Ptr.all = (if Str (F) = '+' then F + 1 else F) - and then Start = F); + Start : out Positive); -- Same as Scan_Sign, but allows only plus, not minus. This is used for -- modular types. @@ -168,22 +86,7 @@ is Ptr : not null access Integer; Max : Integer; Exp : out Integer; - Real : Boolean := False) - with - Pre => - -- Ptr.all .. Max is either an empty range, or a valid range in Str - (Ptr.all > Max or else (Ptr.all >= Str'First and then Max <= Str'Last)) - and then Max < Natural'Last - and then Sp.Is_Opt_Exponent_Format_Ghost (Str (Ptr.all .. Max), Real), - Post => - (if Sp.Starts_As_Exponent_Format_Ghost (Str (Ptr.all'Old .. Max), Real) - then Exp = Sp.Scan_Exponent_Ghost (Str (Ptr.all'Old .. Max), Real) - and then - (if Str (Ptr.all'Old + 1) in '-' | '+' then - Ptr.all = Sp.Last_Number_Ghost (Str (Ptr.all'Old + 2 .. Max)) + 1 - else - Ptr.all = Sp.Last_Number_Ghost (Str (Ptr.all'Old + 1 .. Max)) + 1) - else Exp = 0 and Ptr.all = Ptr.all'Old); + Real : Boolean := False); -- Called to scan a possible exponent. Str, Ptr, Max are as described above -- for Scan_Sign. If Ptr.all < Max and Str (Ptr.all) = 'E' or 'e', then an -- exponent is scanned out, with the exponent value returned in Exp, and @@ -198,35 +101,16 @@ is -- This routine must not be called with Str'Last = Positive'Last. There is -- no check for this case, the caller must ensure this condition is met. - procedure Scan_Trailing_Blanks (Str : String; P : Positive) - with - Pre => P >= Str'First - and then Sp.Only_Space_Ghost (Str, P, Str'Last); + procedure Scan_Trailing_Blanks (Str : String; P : Positive); -- Checks that the remainder of the field Str (P .. Str'Last) is all -- blanks. Raises Constraint_Error if a non-blank character is found. - pragma Warnings - (GNATprove, Off, """Ptr"" is not modified", - Reason => "Ptr is actually modified when raising an exception"); procedure Scan_Underscore (Str : String; P : in out Natural; Ptr : not null access Integer; Max : Integer; - Ext : Boolean) - with - Pre => P in Str'Range - and then Str (P) = '_' - and then Max in Str'Range - and then P < Max - and then - (if Ext then - Str (P + 1) in '0' .. '9' | 'A' .. 'F' | 'a' .. 'f' - else - Str (P + 1) in '0' .. '9'), - Post => - P = P'Old + 1 - and then Ptr.all'Old = Ptr.all; + Ext : Boolean); -- Called if an underscore is encountered while scanning digits. Str (P) -- contains the underscore. Ptr is the pointer to be returned to the -- ultimate caller of the scan routine, Max is the maximum subscript in @@ -237,6 +121,5 @@ is -- -- This routine must not be called with Str'Last = Positive'Last. There is -- no check for this case, the caller must ensure this condition is met. - pragma Warnings (GNATprove, On, """Ptr"" is not modified"); end System.Val_Util; diff --git a/gcc/ada/libgnat/s-vauspe.adb b/gcc/ada/libgnat/s-vauspe.adb deleted file mode 100644 index a350a56..0000000 --- a/gcc/ada/libgnat/s-vauspe.adb +++ /dev/null @@ -1,203 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . V A L U E _ U _ S P E C -- --- -- --- B o d y -- --- -- --- Copyright (C) 2022-2025, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore, - Subprogram_Variant => Ignore); - -package body System.Value_U_Spec with SPARK_Mode is - - ----------------------------- - -- Exponent_Unsigned_Ghost -- - ----------------------------- - - function Exponent_Unsigned_Ghost - (Value : Uns; - Exp : Natural; - Base : Uns := 10) return Uns_Option - is - (if Exp = 0 or Value = 0 then (Overflow => False, Value => Value) - elsif Scan_Overflows_Ghost (0, Base, Value) then (Overflow => True) - else Exponent_Unsigned_Ghost (Value * Base, Exp - 1, Base)); - - --------------------- - -- Last_Hexa_Ghost -- - --------------------- - - function Last_Hexa_Ghost (Str : String) return Positive is - begin - pragma Annotate (Gnatcheck, Exempt_On, "Improper_Returns", - "occurs in ghost code, not executable"); - - for J in Str'Range loop - if Str (J) not in '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' | '_' then - return J - 1; - end if; - - pragma Loop_Invariant - (for all K in Str'First .. J => - Str (K) in '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' | '_'); - end loop; - - return Str'Last; - - pragma Annotate (Gnatcheck, Exempt_Off, "Improper_Returns"); - end Last_Hexa_Ghost; - - ----------------------------- - -- Lemmas with null bodies -- - ----------------------------- - - procedure Lemma_Scan_Based_Number_Ghost_Base - (Str : String; - From, To : Integer; - Base : Uns := 10; - Acc : Uns := 0) - is null; - - procedure Lemma_Scan_Based_Number_Ghost_Underscore - (Str : String; - From, To : Integer; - Base : Uns := 10; - Acc : Uns := 0) - is null; - - procedure Lemma_Scan_Based_Number_Ghost_Overflow - (Str : String; - From, To : Integer; - Base : Uns := 10; - Acc : Uns := 0) - is null; - - procedure Lemma_Scan_Based_Number_Ghost_Step - (Str : String; - From, To : Integer; - Base : Uns := 10; - Acc : Uns := 0) - is null; - - procedure Lemma_Exponent_Unsigned_Ghost_Base - (Value : Uns; - Exp : Natural; - Base : Uns := 10) - is null; - - procedure Lemma_Exponent_Unsigned_Ghost_Overflow - (Value : Uns; - Exp : Natural; - Base : Uns := 10) - is null; - - procedure Lemma_Exponent_Unsigned_Ghost_Step - (Value : Uns; - Exp : Natural; - Base : Uns := 10) - is null; - - -------------------------------------- - -- Prove_Scan_Based_Number_Ghost_Eq -- - -------------------------------------- - - procedure Prove_Scan_Based_Number_Ghost_Eq - (Str1, Str2 : String; - From, To : Integer; - Base : Uns := 10; - Acc : Uns := 0) - is - begin - if From > To then - null; - elsif Str1 (From) = '_' then - Prove_Scan_Based_Number_Ghost_Eq - (Str1, Str2, From + 1, To, Base, Acc); - elsif Scan_Overflows_Ghost - (Hexa_To_Unsigned_Ghost (Str1 (From)), Base, Acc) - then - null; - else - Prove_Scan_Based_Number_Ghost_Eq - (Str1, Str2, From + 1, To, Base, - Base * Acc + Hexa_To_Unsigned_Ghost (Str1 (From))); - end if; - end Prove_Scan_Based_Number_Ghost_Eq; - - ----------------------------------- - -- Prove_Scan_Only_Decimal_Ghost -- - ----------------------------------- - - procedure Prove_Scan_Only_Decimal_Ghost - (Str : String; - Val : Uns) - is - pragma Assert (Str (Str'First + 1) /= ' '); - Non_Blank : constant Positive := First_Non_Space_Ghost - (Str, Str'First, Str'Last); - pragma Assert (Non_Blank = Str'First + 1); - Fst_Num : constant Positive := - (if Str (Non_Blank) = '+' then Non_Blank + 1 else Non_Blank); - pragma Assert (Fst_Num = Str'First + 1); - begin - pragma Assert - (Is_Raw_Unsigned_Format_Ghost (Str (Fst_Num .. Str'Last))); - pragma Assert - (Scan_Split_No_Overflow_Ghost (Str, Str'First + 1, Str'Last)); - pragma Assert - ((Val, 10, 0) = Scan_Split_Value_Ghost (Str, Str'First + 1, Str'Last)); - pragma Assert - (Raw_Unsigned_No_Overflow_Ghost (Str, Fst_Num, Str'Last)); - pragma Assert (Val = Exponent_Unsigned_Ghost (Val, 0, 10).Value); - pragma Assert (Is_Unsigned_Ghost (Str)); - pragma Assert (Is_Value_Unsigned_Ghost (Str, Val)); - end Prove_Scan_Only_Decimal_Ghost; - - ----------------------------- - -- Scan_Based_Number_Ghost -- - ----------------------------- - - function Scan_Based_Number_Ghost - (Str : String; - From, To : Integer; - Base : Uns := 10; - Acc : Uns := 0) return Uns_Option - is - (if From > To then (Overflow => False, Value => Acc) - elsif Str (From) = '_' - then Scan_Based_Number_Ghost (Str, From + 1, To, Base, Acc) - elsif Scan_Overflows_Ghost - (Hexa_To_Unsigned_Ghost (Str (From)), Base, Acc) - then (Overflow => True) - else Scan_Based_Number_Ghost - (Str, From + 1, To, Base, - Base * Acc + Hexa_To_Unsigned_Ghost (Str (From)))); - -end System.Value_U_Spec; diff --git a/gcc/ada/libgnat/s-vauspe.ads b/gcc/ada/libgnat/s-vauspe.ads deleted file mode 100644 index 5dbb57d..0000000 --- a/gcc/ada/libgnat/s-vauspe.ads +++ /dev/null @@ -1,629 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . V A L U E _ U _ S P E C -- --- -- --- S p e c -- --- -- --- Copyright (C) 2022-2025, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package is part of a set of Ghost code packages used to proof the --- implementations of the Image and Value attributes. It provides the --- specification entities using for the formal verification of the routines --- for scanning modular unsigned integer values. - --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore, - Subprogram_Variant => Ignore); - -with System.Val_Spec; use System.Val_Spec; - -generic - - type Uns is mod <>; - -package System.Value_U_Spec with - Ghost, - SPARK_Mode, - Always_Terminates -is - pragma Preelaborate; - - -- Maximum value of exponent for 10 that fits in Uns'Base - function Max_Log10 return Natural is - (case Uns'Base'Size is - when 8 => 2, - when 16 => 4, - when 32 => 9, - when 64 => 19, - when 128 => 38, - when others => raise Program_Error) - with Ghost; - - pragma Annotate (Gnatcheck, Exempt_On, "Discriminated_Records", - "variant record only used in proof code"); - type Uns_Option (Overflow : Boolean := False) is record - case Overflow is - when True => - null; - when False => - Value : Uns := 0; - end case; - end record; - pragma Annotate (Gnatcheck, Exempt_Off, "Discriminated_Records"); - - function Wrap_Option (Value : Uns) return Uns_Option is - (Overflow => False, Value => Value); - - function Only_Decimal_Ghost - (Str : String; - From, To : Integer) - return Boolean - is - (for all J in From .. To => Str (J) in '0' .. '9') - with - Pre => From > To or else (From >= Str'First and then To <= Str'Last); - -- Ghost function that returns True if S has only decimal characters - -- from index From to index To. - - function Only_Hexa_Ghost (Str : String; From, To : Integer) return Boolean - is - (for all J in From .. To => - Str (J) in '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' | '_') - with - Pre => From > To or else (From >= Str'First and then To <= Str'Last); - -- Ghost function that returns True if S has only hexadecimal characters - -- from index From to index To. - - function Last_Hexa_Ghost (Str : String) return Positive - with - Pre => Str /= "" - and then Str (Str'First) in '0' .. '9' | 'a' .. 'f' | 'A' .. 'F', - Post => Last_Hexa_Ghost'Result in Str'Range - and then (if Last_Hexa_Ghost'Result < Str'Last then - Str (Last_Hexa_Ghost'Result + 1) not in - '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' | '_') - and then Only_Hexa_Ghost (Str, Str'First, Last_Hexa_Ghost'Result); - -- Ghost function that returns the index of the last character in S that - -- is either an hexadecimal digit or an underscore, which necessarily - -- exists given the precondition on Str. - - function Is_Based_Format_Ghost (Str : String) return Boolean - is - (Str /= "" - and then Str (Str'First) in '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' - and then - (declare - L : constant Positive := Last_Hexa_Ghost (Str); - begin - Str (L) /= '_' - and then (for all J in Str'First .. L => - (if Str (J) = '_' then Str (J + 1) /= '_')))); - -- Ghost function that determines if Str has the correct format for a - -- based number, consisting in a sequence of hexadecimal digits possibly - -- separated by single underscores. It may be followed by other characters. - - function Hexa_To_Unsigned_Ghost (X : Character) return Uns is - (case X is - when '0' .. '9' => Character'Pos (X) - Character'Pos ('0'), - when 'a' .. 'f' => Character'Pos (X) - Character'Pos ('a') + 10, - when 'A' .. 'F' => Character'Pos (X) - Character'Pos ('A') + 10, - when others => raise Program_Error) - with - Pre => X in '0' .. '9' | 'a' .. 'f' | 'A' .. 'F'; - -- Ghost function that computes the value corresponding to an hexadecimal - -- digit. - - function Scan_Overflows_Ghost - (Digit : Uns; - Base : Uns; - Acc : Uns) return Boolean - is - (Digit >= Base - or else Acc > Uns'Last / Base - or else Uns'Last - Digit < Base * Acc); - -- Ghost function which returns True if Digit + Base * Acc overflows or - -- Digit is greater than Base, as this is used by the algorithm for the - -- test of overflow. - - function Scan_Based_Number_Ghost - (Str : String; - From, To : Integer; - Base : Uns := 10; - Acc : Uns := 0) return Uns_Option - with - Subprogram_Variant => (Increases => From), - Pre => Str'Last /= Positive'Last - and then - (From > To or else (From >= Str'First and then To <= Str'Last)) - and then Only_Hexa_Ghost (Str, From, To); - -- Ghost function that recursively computes the based number in Str, - -- assuming Acc has been scanned already and scanning continues at index - -- From. - - -- Lemmas unfolding the recursive definition of Scan_Based_Number_Ghost - - procedure Lemma_Scan_Based_Number_Ghost_Base - (Str : String; - From, To : Integer; - Base : Uns := 10; - Acc : Uns := 0) - with - Global => null, - Pre => Str'Last /= Positive'Last - and then - (From > To or else (From >= Str'First and then To <= Str'Last)) - and then Only_Hexa_Ghost (Str, From, To), - Post => - (if From > To - then Scan_Based_Number_Ghost (Str, From, To, Base, Acc) = - (Overflow => False, Value => Acc)); - -- Base case: Scan_Based_Number_Ghost returns Acc if From is bigger than To - - procedure Lemma_Scan_Based_Number_Ghost_Underscore - (Str : String; - From, To : Integer; - Base : Uns := 10; - Acc : Uns := 0) - with - Global => null, - Pre => Str'Last /= Positive'Last - and then - (From > To or else (From >= Str'First and then To <= Str'Last)) - and then Only_Hexa_Ghost (Str, From, To), - Post => - (if From <= To and then Str (From) = '_' - then Scan_Based_Number_Ghost (Str, From, To, Base, Acc) = - Scan_Based_Number_Ghost (Str, From + 1, To, Base, Acc)); - -- Underscore case: underscores are ignored while scanning - - procedure Lemma_Scan_Based_Number_Ghost_Overflow - (Str : String; - From, To : Integer; - Base : Uns := 10; - Acc : Uns := 0) - with - Global => null, - Pre => Str'Last /= Positive'Last - and then - (From > To or else (From >= Str'First and then To <= Str'Last)) - and then Only_Hexa_Ghost (Str, From, To), - Post => - (if From <= To - and then Str (From) /= '_' - and then Scan_Overflows_Ghost - (Hexa_To_Unsigned_Ghost (Str (From)), Base, Acc) - then Scan_Based_Number_Ghost (Str, From, To, Base, Acc) = - (Overflow => True)); - -- Overflow case: scanning a digit which causes an overflow - - procedure Lemma_Scan_Based_Number_Ghost_Step - (Str : String; - From, To : Integer; - Base : Uns := 10; - Acc : Uns := 0) - with - Global => null, - Pre => Str'Last /= Positive'Last - and then - (From > To or else (From >= Str'First and then To <= Str'Last)) - and then Only_Hexa_Ghost (Str, From, To), - Post => - (if From <= To - and then Str (From) /= '_' - and then not Scan_Overflows_Ghost - (Hexa_To_Unsigned_Ghost (Str (From)), Base, Acc) - then Scan_Based_Number_Ghost (Str, From, To, Base, Acc) = - Scan_Based_Number_Ghost - (Str, From + 1, To, Base, - Base * Acc + Hexa_To_Unsigned_Ghost (Str (From)))); - -- Normal case: scanning a digit without overflows - - function Exponent_Unsigned_Ghost - (Value : Uns; - Exp : Natural; - Base : Uns := 10) return Uns_Option - with - Subprogram_Variant => (Decreases => Exp); - -- Ghost function that recursively computes Value * Base ** Exp - - -- Lemmas unfolding the recursive definition of Exponent_Unsigned_Ghost - - procedure Lemma_Exponent_Unsigned_Ghost_Base - (Value : Uns; - Exp : Natural; - Base : Uns := 10) - with - Post => - (if Exp = 0 or Value = 0 - then Exponent_Unsigned_Ghost (Value, Exp, Base) = - (Overflow => False, Value => Value)); - -- Base case: Exponent_Unsigned_Ghost returns 0 if Value or Exp is 0 - - procedure Lemma_Exponent_Unsigned_Ghost_Overflow - (Value : Uns; - Exp : Natural; - Base : Uns := 10) - with - Post => - (if Exp /= 0 - and then Value /= 0 - and then Scan_Overflows_Ghost (0, Base, Value) - then Exponent_Unsigned_Ghost (Value, Exp, Base) = (Overflow => True)); - -- Overflow case: the next multiplication overflows - - procedure Lemma_Exponent_Unsigned_Ghost_Step - (Value : Uns; - Exp : Natural; - Base : Uns := 10) - with - Post => - (if Exp /= 0 - and then Value /= 0 - and then not Scan_Overflows_Ghost (0, Base, Value) - then Exponent_Unsigned_Ghost (Value, Exp, Base) = - Exponent_Unsigned_Ghost (Value * Base, Exp - 1, Base)); - -- Normal case: exponentiation without overflows - - function Raw_Unsigned_Starts_As_Based_Ghost - (Str : String; - Last_Num_Init, To : Integer) - return Boolean - is - (Last_Num_Init < To - 1 - and then Str (Last_Num_Init + 1) in '#' | ':' - and then Str (Last_Num_Init + 2) in - '0' .. '9' | 'a' .. 'f' | 'A' .. 'F') - with Ghost, - Pre => Last_Num_Init in Str'Range - and then To in Str'Range; - -- Return True if Str starts as a based number - - function Raw_Unsigned_Is_Based_Ghost - (Str : String; - Last_Num_Init : Integer; - Last_Num_Based : Integer; - To : Integer) - return Boolean - is - (Raw_Unsigned_Starts_As_Based_Ghost (Str, Last_Num_Init, To) - and then Last_Num_Based < To - and then Str (Last_Num_Based + 1) = Str (Last_Num_Init + 1)) - with Ghost, - Pre => Last_Num_Init in Str'Range - and then Last_Num_Based in Last_Num_Init .. Str'Last - and then To in Str'Range; - -- Return True if Str is a based number - - function Is_Raw_Unsigned_Format_Ghost (Str : String) return Boolean is - (Is_Natural_Format_Ghost (Str) - and then - (declare - Last_Num_Init : constant Integer := Last_Number_Ghost (Str); - Starts_As_Based : constant Boolean := - Raw_Unsigned_Starts_As_Based_Ghost (Str, Last_Num_Init, Str'Last); - Last_Num_Based : constant Integer := - (if Starts_As_Based - then Last_Hexa_Ghost (Str (Last_Num_Init + 2 .. Str'Last)) - else Last_Num_Init); - Is_Based : constant Boolean := - Raw_Unsigned_Is_Based_Ghost - (Str, Last_Num_Init, Last_Num_Based, Str'Last); - First_Exp : constant Integer := - (if Is_Based then Last_Num_Based + 2 else Last_Num_Init + 1); - begin - (if Starts_As_Based then - Is_Based_Format_Ghost (Str (Last_Num_Init + 2 .. Str'Last)) - and then Last_Num_Based < Str'Last) - and then Is_Opt_Exponent_Format_Ghost - (Str (First_Exp .. Str'Last)))) - with - Pre => Str'Last /= Positive'Last; - -- Ghost function that determines if Str has the correct format for an - -- unsigned number without a sign character. - -- It is a natural number in base 10, optionally followed by a based - -- number surrounded by delimiters # or :, optionally followed by an - -- exponent part. - - type Split_Value_Ghost is record - Value : Uns; - Base : Uns; - Expon : Natural; - end record; - - function Scan_Split_No_Overflow_Ghost - (Str : String; - From, To : Integer) - return Boolean - is - (declare - Last_Num_Init : constant Integer := - Last_Number_Ghost (Str (From .. To)); - Init_Val : constant Uns_Option := - Scan_Based_Number_Ghost (Str, From, Last_Num_Init); - Starts_As_Based : constant Boolean := - Raw_Unsigned_Starts_As_Based_Ghost (Str, Last_Num_Init, To); - Last_Num_Based : constant Integer := - (if Starts_As_Based - then Last_Hexa_Ghost (Str (Last_Num_Init + 2 .. To)) - else Last_Num_Init); - Based_Val : constant Uns_Option := - (if Starts_As_Based and then not Init_Val.Overflow - then Scan_Based_Number_Ghost - (Str, Last_Num_Init + 2, Last_Num_Based, Init_Val.Value) - else Init_Val); - begin - not Init_Val.Overflow - and then - (Last_Num_Init >= To - 1 - or else Str (Last_Num_Init + 1) not in '#' | ':' - or else Init_Val.Value in 2 .. 16) - and then - (not Starts_As_Based - or else not Based_Val.Overflow)) - with - Pre => Str'Last /= Positive'Last - and then From in Str'Range - and then To in From .. Str'Last - and then Str (From) in '0' .. '9'; - -- Ghost function that determines if an overflow might occur while scanning - -- the representation of an unsigned number. The computation overflows if - -- either: - -- * The computation of the decimal part overflows, - -- * The decimal part is followed by a valid delimiter for a based - -- part, and the number corresponding to the base is not a valid base, - -- or - -- * The computation of the based part overflows. - - pragma Warnings (Off, "constant * is not referenced"); - function Scan_Split_Value_Ghost - (Str : String; - From, To : Integer) - return Split_Value_Ghost - is - (declare - Last_Num_Init : constant Integer := - Last_Number_Ghost (Str (From .. To)); - Init_Val : constant Uns_Option := - Scan_Based_Number_Ghost (Str, From, Last_Num_Init); - Starts_As_Based : constant Boolean := - Raw_Unsigned_Starts_As_Based_Ghost (Str, Last_Num_Init, To); - Last_Num_Based : constant Integer := - (if Starts_As_Based - then Last_Hexa_Ghost (Str (Last_Num_Init + 2 .. To)) - else Last_Num_Init); - Is_Based : constant Boolean := - Raw_Unsigned_Is_Based_Ghost (Str, Last_Num_Init, Last_Num_Based, To); - Based_Val : constant Uns_Option := - (if Starts_As_Based and then not Init_Val.Overflow - then Scan_Based_Number_Ghost - (Str, Last_Num_Init + 2, Last_Num_Based, Init_Val.Value) - else Init_Val); - First_Exp : constant Integer := - (if Is_Based then Last_Num_Based + 2 else Last_Num_Init + 1); - Expon : constant Natural := - (if Starts_As_Exponent_Format_Ghost (Str (First_Exp .. To)) - then Scan_Exponent_Ghost (Str (First_Exp .. To)) - else 0); - Base : constant Uns := - (if Is_Based then Init_Val.Value else 10); - Value : constant Uns := - (if Is_Based then Based_Val.Value else Init_Val.Value); - begin - (Value => Value, Base => Base, Expon => Expon)) - with - Pre => Str'Last /= Positive'Last - and then From in Str'Range - and then To in From .. Str'Last - and then Str (From) in '0' .. '9' - and then Scan_Split_No_Overflow_Ghost (Str, From, To); - -- Ghost function that scans an unsigned number without a sign character - -- and return a record containing the values scanned for its value, its - -- base, and its exponent. - pragma Warnings (On, "constant * is not referenced"); - - function Raw_Unsigned_No_Overflow_Ghost - (Str : String; - From, To : Integer) - return Boolean - is - (Scan_Split_No_Overflow_Ghost (Str, From, To) - and then - (declare - Val : constant Split_Value_Ghost := Scan_Split_Value_Ghost - (Str, From, To); - begin - not Exponent_Unsigned_Ghost - (Val.Value, Val.Expon, Val.Base).Overflow)) - with - Pre => Str'Last /= Positive'Last - and then From in Str'Range - and then To in From .. Str'Last - and then Str (From) in '0' .. '9'; - -- Ghost function that determines if the computation of the unsigned number - -- represented by Str will overflow. The computation overflows if either: - -- * The scan of the string overflows, or - -- * The computation of the exponentiation overflows. - - function Scan_Raw_Unsigned_Ghost - (Str : String; - From, To : Integer) - return Uns - is - (declare - Val : constant Split_Value_Ghost := Scan_Split_Value_Ghost - (Str, From, To); - begin - Exponent_Unsigned_Ghost (Val.Value, Val.Expon, Val.Base).Value) - with - Pre => Str'Last /= Positive'Last - and then From in Str'Range - and then To in From .. Str'Last - and then Str (From) in '0' .. '9' - and then Raw_Unsigned_No_Overflow_Ghost (Str, From, To); - -- Ghost function that scans an unsigned number without a sign character - - function Raw_Unsigned_Last_Ghost - (Str : String; - From, To : Integer) - return Positive - is - (declare - Last_Num_Init : constant Integer := - Last_Number_Ghost (Str (From .. To)); - Starts_As_Based : constant Boolean := - Raw_Unsigned_Starts_As_Based_Ghost (Str, Last_Num_Init, To); - Last_Num_Based : constant Integer := - (if Starts_As_Based - then Last_Hexa_Ghost (Str (Last_Num_Init + 2 .. To)) - else Last_Num_Init); - Is_Based : constant Boolean := - Raw_Unsigned_Is_Based_Ghost (Str, Last_Num_Init, Last_Num_Based, To); - First_Exp : constant Integer := - (if Is_Based then Last_Num_Based + 2 else Last_Num_Init + 1); - begin - (if not Starts_As_Exponent_Format_Ghost (Str (First_Exp .. To)) - then First_Exp - elsif Str (First_Exp + 1) in '-' | '+' then - Last_Number_Ghost (Str (First_Exp + 2 .. To)) + 1 - else Last_Number_Ghost (Str (First_Exp + 1 .. To)) + 1)) - with - Pre => Str'Last /= Positive'Last - and then From in Str'Range - and then To in From .. Str'Last - and then Str (From) in '0' .. '9', - Post => Raw_Unsigned_Last_Ghost'Result >= From; - -- Ghost function that returns the position of the cursor once an unsigned - -- number has been seen. - - function Slide_To_1 (Str : String) return String - with - Post => - Only_Space_Ghost (Str, Str'First, Str'Last) = - (for all J in Str'First .. Str'Last => - Slide_To_1'Result (J - Str'First + 1) = ' '); - -- Slides Str so that it starts at 1 - - function Slide_If_Necessary (Str : String) return String is - (if Str'Last = Positive'Last then Slide_To_1 (Str) else Str); - -- If Str'Last = Positive'Last then slides Str so that it starts at 1 - - function Is_Unsigned_Ghost (Str : String) return Boolean is - (declare - Non_Blank : constant Positive := First_Non_Space_Ghost - (Str, Str'First, Str'Last); - Fst_Num : constant Positive := - (if Str (Non_Blank) = '+' then Non_Blank + 1 else Non_Blank); - begin - Is_Raw_Unsigned_Format_Ghost (Str (Fst_Num .. Str'Last)) - and then Raw_Unsigned_No_Overflow_Ghost (Str, Fst_Num, Str'Last) - and then Only_Space_Ghost - (Str, Raw_Unsigned_Last_Ghost (Str, Fst_Num, Str'Last), Str'Last)) - with - Pre => not Only_Space_Ghost (Str, Str'First, Str'Last) - and then Str'Last /= Positive'Last; - -- Ghost function that determines if Str has the correct format for an - -- unsigned number, consisting in some blank characters, an optional - -- + sign, a raw unsigned number which does not overflow and then some - -- more blank characters. - - function Is_Value_Unsigned_Ghost (Str : String; Val : Uns) return Boolean is - (declare - Non_Blank : constant Positive := First_Non_Space_Ghost - (Str, Str'First, Str'Last); - Fst_Num : constant Positive := - (if Str (Non_Blank) = '+' then Non_Blank + 1 else Non_Blank); - begin - Val = Scan_Raw_Unsigned_Ghost (Str, Fst_Num, Str'Last)) - with - Pre => not Only_Space_Ghost (Str, Str'First, Str'Last) - and then Str'Last /= Positive'Last - and then Is_Unsigned_Ghost (Str); - -- Ghost function that returns True if Val is the value corresponding to - -- the unsigned number represented by Str. - - procedure Prove_Scan_Based_Number_Ghost_Eq - (Str1, Str2 : String; - From, To : Integer; - Base : Uns := 10; - Acc : Uns := 0) - with - Subprogram_Variant => (Increases => From), - Pre => Str1'Last /= Positive'Last - and then Str2'Last /= Positive'Last - and then - (From > To or else (From >= Str1'First and then To <= Str1'Last)) - and then - (From > To or else (From >= Str2'First and then To <= Str2'Last)) - and then Only_Hexa_Ghost (Str1, From, To) - and then (for all J in From .. To => Str1 (J) = Str2 (J)), - Post => - Scan_Based_Number_Ghost (Str1, From, To, Base, Acc) - = Scan_Based_Number_Ghost (Str2, From, To, Base, Acc); - -- Scan_Based_Number_Ghost returns the same value on two slices which are - -- equal. - - procedure Prove_Scan_Only_Decimal_Ghost - (Str : String; - Val : Uns) - with - Pre => Str'Last /= Positive'Last - and then Str'Length >= 2 - and then Str (Str'First) = ' ' - and then Only_Decimal_Ghost (Str, Str'First + 1, Str'Last) - and then Scan_Based_Number_Ghost (Str, Str'First + 1, Str'Last) - = Wrap_Option (Val), - Post => Is_Unsigned_Ghost (Slide_If_Necessary (Str)) - and then - Is_Value_Unsigned_Ghost (Slide_If_Necessary (Str), Val); - -- Ghost lemma used in the proof of 'Image implementation, to prove that - -- the result of Value_Unsigned on a decimal string is the same as the - -- result of Scan_Based_Number_Ghost. - - -- Bundle Uns type with other types, constants and subprograms used in - -- ghost code, so that this package can be instantiated once and used - -- multiple times as generic formal for a given Int type. - -private - - ---------------- - -- Slide_To_1 -- - ---------------- - - function Slide_To_1 (Str : String) return String is - (declare - Res : constant String (1 .. Str'Length) := Str; - begin - Res); - -end System.Value_U_Spec; diff --git a/gcc/ada/libgnat/s-veboop.adb b/gcc/ada/libgnat/s-veboop.adb index fb92f1c..edff485 100644 --- a/gcc/ada/libgnat/s-veboop.adb +++ b/gcc/ada/libgnat/s-veboop.adb @@ -29,14 +29,6 @@ -- -- ------------------------------------------------------------------------------ --- Ghost code, loop invariants and assertions in this unit are meant for --- analysis only, not for run-time checking, as it would be too costly --- otherwise. This is enforced by setting the assertion policy to Ignore. - -pragma Assertion_Policy (Ghost => Ignore, - Loop_Invariant => Ignore, - Assert => Ignore); - package body System.Vectors.Boolean_Operations with SPARK_Mode is @@ -86,26 +78,7 @@ is ----------- function "not" (Item : Vectors.Vector) return Vectors.Vector is - - procedure Prove_Not (Result : Vectors.Vector) - with - Ghost, - Pre => Valid (Item) - and then Result = (Item xor True_Val), - Post => Valid (Result) - and then (for all J in 1 .. Vector_Boolean_Size => - Model (Result) (J) = not Model (Item) (J)); - - procedure Prove_Not (Result : Vectors.Vector) is - begin - for J in 1 .. Vector_Boolean_Size loop - pragma Assert - (Element (Result, J) = 1 - Element (Item, J)); - end loop; - end Prove_Not; - begin - Prove_Not (Item xor True_Val); return Item xor True_Val; end "not"; @@ -119,32 +92,7 @@ is end Nand; function Nand (Left, Right : Vectors.Vector) return Vectors.Vector is - - procedure Prove_And (Result : Vectors.Vector) - with - Ghost, - Pre => Valid (Left) - and then Valid (Right) - and then Result = (Left and Right), - Post => Valid (Result) - and then (for all J in 1 .. Vector_Boolean_Size => - Model (Result) (J) = - (Model (Left) (J) and Model (Right) (J))); - - procedure Prove_And (Result : Vectors.Vector) is - begin - for J in 1 .. Vector_Boolean_Size loop - pragma Assert - (Element (Result, J) = - (if Element (Left, J) = 1 - and Element (Right, J) = 1 - then 1 - else 0)); - end loop; - end Prove_And; - begin - Prove_And (Left and Right); return not (Left and Right); end Nand; @@ -158,32 +106,7 @@ is end Nor; function Nor (Left, Right : Vectors.Vector) return Vectors.Vector is - - procedure Prove_Or (Result : Vectors.Vector) - with - Ghost, - Pre => Valid (Left) - and then Valid (Right) - and then Result = (Left or Right), - Post => Valid (Result) - and then (for all J in 1 .. Vector_Boolean_Size => - Model (Result) (J) = - (Model (Left) (J) or Model (Right) (J))); - - procedure Prove_Or (Result : Vectors.Vector) is - begin - for J in 1 .. Vector_Boolean_Size loop - pragma Assert - (Element (Result, J) = - (if Element (Left, J) = 1 - or Element (Right, J) = 1 - then 1 - else 0)); - end loop; - end Prove_Or; - begin - Prove_Or (Left or Right); return not (Left or Right); end Nor; @@ -197,32 +120,7 @@ is end Nxor; function Nxor (Left, Right : Vectors.Vector) return Vectors.Vector is - - procedure Prove_Xor (Result : Vectors.Vector) - with - Ghost, - Pre => Valid (Left) - and then Valid (Right) - and then Result = (Left xor Right), - Post => Valid (Result) - and then (for all J in 1 .. Vector_Boolean_Size => - Model (Result) (J) = - (Model (Left) (J) xor Model (Right) (J))); - - procedure Prove_Xor (Result : Vectors.Vector) is - begin - for J in 1 .. Vector_Boolean_Size loop - pragma Assert - (Element (Result, J) = - (if Element (Left, J) = 1 - xor Element (Right, J) = 1 - then 1 - else 0)); - end loop; - end Prove_Xor; - begin - Prove_Xor (Left xor Right); return not (Left xor Right); end Nxor; diff --git a/gcc/ada/libgnat/s-veboop.ads b/gcc/ada/libgnat/s-veboop.ads index 6283d19..0b4f894 100644 --- a/gcc/ada/libgnat/s-veboop.ads +++ b/gcc/ada/libgnat/s-veboop.ads @@ -31,116 +31,21 @@ -- This package contains functions for runtime operations on boolean vectors --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore); - package System.Vectors.Boolean_Operations with Pure, SPARK_Mode is - pragma Warnings (Off, "aspect ""Pre"" not enforced on inlined subprogram", - Reason => "Pre only used in proof"); - pragma Warnings (Off, "aspect ""Post"" not enforced on inlined subprogram", - Reason => "Post only used in proof"); - -- Type Vectors.Vector represents an array of Boolean, each of which - -- takes 8 bits of the representation, with the 7 msb set to zero. Express - -- in contracts the constraint on valid vectors and the model that they - -- represent, and the relationship between input models and output model. - - Vector_Boolean_Size : constant Positive := - System.Word_Size / System.Storage_Unit - with Ghost; - - type Vector_Element is mod 2 ** System.Storage_Unit with Ghost; - - type Vector_Boolean_Array is array (1 .. Vector_Boolean_Size) of Boolean - with Ghost; - - function Shift_Right (V : Vectors.Vector; N : Natural) return Vectors.Vector - with Ghost, Import, Convention => Intrinsic; - - function Element (V : Vectors.Vector; N : Positive) return Vector_Element is - (Vector_Element (Shift_Right (V, (N - 1) * System.Storage_Unit) - and (2 ** System.Storage_Unit - 1))) - with - Ghost, - Pre => N <= Vector_Boolean_Size; - -- Return the Nth element represented by the vector - - function Valid (V : Vectors.Vector) return Boolean is - (for all J in 1 .. Vector_Boolean_Size => - Element (V, J) in 0 .. 1) - with Ghost; - -- A valid vector is one for which all elements are 0 (representing False) - -- or 1 (representing True). - - function Model (V : Vectors.Vector) return Vector_Boolean_Array - with - Ghost, - Pre => Valid (V); - - function Model (V : Vectors.Vector) return Vector_Boolean_Array is - (for J in 1 .. Vector_Boolean_Size => Element (V, J) = 1); - -- The model of a valid vector is the corresponding array of Boolean values - - -- Although in general the boolean operations on arrays of booleans are - -- identical to operations on arrays of unsigned words of the same size, - -- for the "not" operator this is not the case as False is typically - -- represented by 0 and true by 1. - - function "not" (Item : Vectors.Vector) return Vectors.Vector - with - Pre => Valid (Item), - Post => Valid ("not"'Result) - and then (for all J in 1 .. Vector_Boolean_Size => - Model ("not"'Result) (J) = not Model (Item) (J)); - - function Nand (Left, Right : Boolean) return Boolean - with - Post => Nand'Result = not (Left and Right); - - function Nor (Left, Right : Boolean) return Boolean - with - Post => Nor'Result = not (Left or Right); - - function Nxor (Left, Right : Boolean) return Boolean - with - Post => Nxor'Result = not (Left xor Right); + -- takes 8 bits of the representation, with the 7 msb set to zero. - function Nand (Left, Right : Vectors.Vector) return Vectors.Vector - with - Pre => Valid (Left) - and then Valid (Right), - Post => Valid (Nand'Result) - and then (for all J in 1 .. Vector_Boolean_Size => - Model (Nand'Result) (J) = - Nand (Model (Left) (J), Model (Right) (J))); + function "not" (Item : Vectors.Vector) return Vectors.Vector; - function Nor (Left, Right : Vectors.Vector) return Vectors.Vector - with - Pre => Valid (Left) - and then Valid (Right), - Post => Valid (Nor'Result) - and then (for all J in 1 .. Vector_Boolean_Size => - Model (Nor'Result) (J) = - Nor (Model (Left) (J), Model (Right) (J))); + function Nand (Left, Right : Boolean) return Boolean; + function Nor (Left, Right : Boolean) return Boolean; + function Nxor (Left, Right : Boolean) return Boolean; - function Nxor (Left, Right : Vectors.Vector) return Vectors.Vector - with - Pre => Valid (Left) - and then Valid (Right), - Post => Valid (Nxor'Result) - and then (for all J in 1 .. Vector_Boolean_Size => - Model (Nxor'Result) (J) = - Nxor (Model (Left) (J), Model (Right) (J))); + function Nand (Left, Right : Vectors.Vector) return Vectors.Vector; + function Nor (Left, Right : Vectors.Vector) return Vectors.Vector; + function Nxor (Left, Right : Vectors.Vector) return Vectors.Vector; -- The three boolean operations "nand", "nor" and "nxor" are needed -- for cases where the compiler moves boolean array operations into -- the body of the loop that iterates over the array elements. diff --git a/gcc/ada/libgnat/s-vs_int.ads b/gcc/ada/libgnat/s-vs_int.ads deleted file mode 100644 index a4cc0dc..0000000 --- a/gcc/ada/libgnat/s-vs_int.ads +++ /dev/null @@ -1,59 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . V S _ I N T -- --- -- --- S p e c -- --- -- --- Copyright (C) 2023-2025, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains specification functions for scanning signed Integer --- values for use in ``Text_IO.Integer_IO``, and the Value attribute. - --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore, - Subprogram_Variant => Ignore); - -with System.Unsigned_Types; -with System.Value_I_Spec; -with System.Vs_Uns; - -package System.Vs_Int with SPARK_Mode, Ghost is - pragma Preelaborate; - - subtype Unsigned is Unsigned_Types.Unsigned; - - package Spec is new System.Value_I_Spec - (Integer, Unsigned, System.Vs_Uns.Spec); - -end System.Vs_Int; diff --git a/gcc/ada/libgnat/s-vs_lli.ads b/gcc/ada/libgnat/s-vs_lli.ads deleted file mode 100644 index 3a4a010..0000000 --- a/gcc/ada/libgnat/s-vs_lli.ads +++ /dev/null @@ -1,60 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . V S _ L L I -- --- -- --- S p e c -- --- -- --- Copyright (C) 2023-2025, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains specification functions for scanning --- Long_Long_Integer values for use in ``Text_IO.Integer_IO``, and the Value --- attribute. - --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore, - Subprogram_Variant => Ignore); - -with System.Unsigned_Types; -with System.Value_I_Spec; -with System.Vs_LLU; - -package System.Vs_LLI with SPARK_Mode, Ghost is - pragma Preelaborate; - - subtype Long_Long_Unsigned is Unsigned_Types.Long_Long_Unsigned; - - package Spec is new System.Value_I_Spec - (Long_Long_Integer, Long_Long_Unsigned, System.Vs_LLU.Spec); - -end System.Vs_LLI; diff --git a/gcc/ada/libgnat/s-vs_llu.ads b/gcc/ada/libgnat/s-vs_llu.ads deleted file mode 100644 index e1c0fec..0000000 --- a/gcc/ada/libgnat/s-vs_llu.ads +++ /dev/null @@ -1,58 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . V S _ L L U -- --- -- --- S p e c -- --- -- --- Copyright (C) 2023-2025, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains specification functions for scanning --- Long_Long_Unsigned values for use in ``Text_IO.Modular_IO``, and the Value --- attribute. - --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore, - Subprogram_Variant => Ignore); - -with System.Unsigned_Types; -with System.Value_U_Spec; - -package System.Vs_LLU with SPARK_Mode, Ghost is - pragma Preelaborate; - - subtype Long_Long_Unsigned is Unsigned_Types.Long_Long_Unsigned; - - package Spec is new System.Value_U_Spec (Long_Long_Unsigned); - -end System.Vs_LLU; diff --git a/gcc/ada/libgnat/s-vs_uns.ads b/gcc/ada/libgnat/s-vs_uns.ads deleted file mode 100644 index 7e5aac3..0000000 --- a/gcc/ada/libgnat/s-vs_uns.ads +++ /dev/null @@ -1,57 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . V S _ U N S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2023-2025, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains specification functions for scanning modular Unsigned --- values for use in ``Text_IO.Modular_IO``, and the Value attribute. - --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore, - Subprogram_Variant => Ignore); - -with System.Unsigned_Types; -with System.Value_U_Spec; - -package System.Vs_Uns with SPARK_Mode, Ghost is - pragma Preelaborate; - - subtype Unsigned is Unsigned_Types.Unsigned; - - package Spec is new System.Value_U_Spec (Unsigned); - -end System.Vs_Uns; diff --git a/gcc/ada/libgnat/s-vsllli.ads b/gcc/ada/libgnat/s-vsllli.ads deleted file mode 100644 index 5648060..0000000 --- a/gcc/ada/libgnat/s-vsllli.ads +++ /dev/null @@ -1,60 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . V S _ L L L I -- --- -- --- S p e c -- --- -- --- Copyright (C) 2023-2025, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains specification functions for scanning --- ``Long_Long_Long_Integer`` values for use in ``Text_IO.Integer_IO``, and --- the Value attribute. - --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore, - Subprogram_Variant => Ignore); - -with System.Unsigned_Types; -with System.Value_I_Spec; -with System.Vs_LLLU; - -package System.Vs_LLLI with SPARK_Mode, Ghost is - pragma Preelaborate; - - subtype Long_Long_Long_Unsigned is Unsigned_Types.Long_Long_Long_Unsigned; - - package Spec is new System.Value_I_Spec - (Long_Long_Long_Integer, Long_Long_Long_Unsigned, System.Vs_LLLU.Spec); - -end System.Vs_LLLI; diff --git a/gcc/ada/libgnat/s-vslllu.ads b/gcc/ada/libgnat/s-vslllu.ads deleted file mode 100644 index 7fe1235..0000000 --- a/gcc/ada/libgnat/s-vslllu.ads +++ /dev/null @@ -1,58 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . V S _ L L L U -- --- -- --- S p e c -- --- -- --- Copyright (C) 2023-2025, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains specification functions for scanning --- Long_Long_Long_Unsigned values for use in Text_IO.Modular_IO, and the Value --- attribute. - --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore, - Subprogram_Variant => Ignore); - -with System.Unsigned_Types; -with System.Value_U_Spec; - -package System.Vs_LLLU with SPARK_Mode, Ghost is - pragma Preelaborate; - - subtype Long_Long_Long_Unsigned is Unsigned_Types.Long_Long_Long_Unsigned; - - package Spec is new System.Value_U_Spec (Long_Long_Long_Unsigned); - -end System.Vs_LLLU; diff --git a/gcc/ada/libgnat/s-widint.ads b/gcc/ada/libgnat/s-widint.ads index 22e342c..8af8d91 100644 --- a/gcc/ada/libgnat/s-widint.ads +++ b/gcc/ada/libgnat/s-widint.ads @@ -31,24 +31,11 @@ -- Width attribute for signed integers up to Integer --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore); - with System.Width_I; package System.Wid_Int with SPARK_Mode is - function Width_Integer is new Width_I (Integer); pragma Pure_Function (Width_Integer); - end System.Wid_Int; diff --git a/gcc/ada/libgnat/s-widlli.ads b/gcc/ada/libgnat/s-widlli.ads index 3490b3f..a977096 100644 --- a/gcc/ada/libgnat/s-widlli.ads +++ b/gcc/ada/libgnat/s-widlli.ads @@ -31,24 +31,11 @@ -- Width attribute for signed integers larger than Integer --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore); - with System.Width_I; package System.Wid_LLI with SPARK_Mode is - function Width_Long_Long_Integer is new Width_I (Long_Long_Integer); pragma Pure_Function (Width_Long_Long_Integer); - end System.Wid_LLI; diff --git a/gcc/ada/libgnat/s-widllli.ads b/gcc/ada/libgnat/s-widllli.ads index ee8f7af..325e80f 100644 --- a/gcc/ada/libgnat/s-widllli.ads +++ b/gcc/ada/libgnat/s-widllli.ads @@ -31,25 +31,12 @@ -- Width attribute for signed integers larger than Long_Long_Integer --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore); - with System.Width_I; package System.Wid_LLLI with SPARK_Mode is - function Width_Long_Long_Long_Integer is new Width_I (Long_Long_Long_Integer); pragma Pure_Function (Width_Long_Long_Long_Integer); - end System.Wid_LLLI; diff --git a/gcc/ada/libgnat/s-widlllu.ads b/gcc/ada/libgnat/s-widlllu.ads index db5b9d1..8a5c04f 100644 --- a/gcc/ada/libgnat/s-widlllu.ads +++ b/gcc/ada/libgnat/s-widlllu.ads @@ -31,17 +31,6 @@ -- Width attribute for modular integers larger than Long_Long_Integer --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore); - with System.Width_U; with System.Unsigned_Types; diff --git a/gcc/ada/libgnat/s-widllu.ads b/gcc/ada/libgnat/s-widllu.ads index 0fd3135..f8c8284 100644 --- a/gcc/ada/libgnat/s-widllu.ads +++ b/gcc/ada/libgnat/s-widllu.ads @@ -31,17 +31,6 @@ -- Width attribute for modular integers larger than Integer --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore); - with System.Width_U; with System.Unsigned_Types; diff --git a/gcc/ada/libgnat/s-widthi.adb b/gcc/ada/libgnat/s-widthi.adb index 9595790..c66d662 100644 --- a/gcc/ada/libgnat/s-widthi.adb +++ b/gcc/ada/libgnat/s-widthi.adb @@ -29,109 +29,9 @@ -- -- ------------------------------------------------------------------------------ -with Ada.Numerics.Big_Numbers.Big_Integers_Ghost; -use Ada.Numerics.Big_Numbers.Big_Integers_Ghost; - function System.Width_I (Lo, Hi : Int) return Natural is - - -- Ghost code, loop invariants and assertions in this unit are meant for - -- analysis only, not for run-time checking, as it would be too costly - -- otherwise. This is enforced by setting the assertion policy to Ignore. - - pragma Assertion_Policy (Ghost => Ignore, - Loop_Invariant => Ignore, - Assert => Ignore); - - ----------------------- - -- Local Subprograms -- - ----------------------- - - package Signed_Conversion is new Signed_Conversions (Int => Int); - - function Big (Arg : Int) return Big_Integer renames - Signed_Conversion.To_Big_Integer; - - -- Maximum value of exponent for 10 that fits in Uns'Base - function Max_Log10 return Natural is - (case Int'Base'Size is - when 8 => 2, - when 16 => 4, - when 32 => 9, - when 64 => 19, - when 128 => 38, - when others => raise Program_Error) - with Ghost; - - ------------------ - -- Local Lemmas -- - ------------------ - - procedure Lemma_Lower_Mult (A, B, C : Big_Natural) - with - Ghost, - Pre => A <= B, - Post => A * C <= B * C; - - procedure Lemma_Div_Commutation (X, Y : Int) - with - Ghost, - Pre => X >= 0 and Y > 0, - Post => Big (X) / Big (Y) = Big (X / Y); - - procedure Lemma_Div_Twice (X : Big_Natural; Y, Z : Big_Positive) - with - Ghost, - Post => X / Y / Z = X / (Y * Z); - - ---------------------- - -- Lemma_Lower_Mult -- - ---------------------- - - procedure Lemma_Lower_Mult (A, B, C : Big_Natural) is null; - - --------------------------- - -- Lemma_Div_Commutation -- - --------------------------- - - procedure Lemma_Div_Commutation (X, Y : Int) is null; - - --------------------- - -- Lemma_Div_Twice -- - --------------------- - - procedure Lemma_Div_Twice (X : Big_Natural; Y, Z : Big_Positive) is - XY : constant Big_Natural := X / Y; - YZ : constant Big_Natural := Y * Z; - XYZ : constant Big_Natural := X / Y / Z; - R : constant Big_Natural := (XY rem Z) * Y + (X rem Y); - begin - pragma Assert (X = XY * Y + (X rem Y)); - pragma Assert (XY = XY / Z * Z + (XY rem Z)); - pragma Assert (X = XYZ * YZ + R); - pragma Assert ((XY rem Z) * Y <= (Z - 1) * Y); - pragma Assert (R <= YZ - 1); - pragma Assert (X / YZ = (XYZ * YZ + R) / YZ); - pragma Assert (X / YZ = XYZ + R / YZ); - end Lemma_Div_Twice; - - -- Local variables - W : Natural; T : Int; - - -- Local ghost variables - - Max_W : constant Natural := Max_Log10 with Ghost; - Big_10 : constant Big_Integer := Big (10) with Ghost; - - Pow : Big_Integer := 1 with Ghost; - T_Init : constant Int := - Int'Max (abs Int'Max (Lo, Int'First + 1), - abs Int'Max (Hi, Int'First + 1)) - with Ghost; - --- Start of processing for System.Width_I - begin if Lo > Hi then return 0; @@ -151,41 +51,10 @@ begin -- Increase value if more digits required while T >= 10 loop - Lemma_Div_Commutation (T, 10); - Lemma_Div_Twice (Big (T_Init), Big_10 ** (W - 2), Big_10); - T := T / 10; W := W + 1; - Pow := Pow * 10; - - pragma Loop_Invariant (T >= 0); - pragma Loop_Invariant (W in 3 .. Max_W + 3); - pragma Loop_Invariant (Pow = Big_10 ** (W - 2)); - pragma Loop_Invariant (Big (T) = Big (T_Init) / Pow); - pragma Loop_Variant (Decreases => T); end loop; - declare - F : constant Big_Positive := Big_10 ** (W - 2) with Ghost; - Q : constant Big_Natural := Big (T_Init) / F with Ghost; - R : constant Big_Natural := Big (T_Init) rem F with Ghost; - begin - pragma Assert (Q < Big_10); - pragma Assert (Big (T_Init) = Q * F + R); - Lemma_Lower_Mult (Q, Big (9), F); - pragma Assert (Big (T_Init) <= Big (9) * F + F - 1); - pragma Assert (Big (T_Init) < Big_10 * F); - pragma Assert (Big_10 * F = Big_10 ** (W - 1)); - end; - - -- This is an expression of the functional postcondition for Width_I, - -- which cannot be expressed readily as a postcondition as this would - -- require making the instantiation Signed_Conversion and function Big - -- available from the spec. - - pragma Assert (Big (Int'Max (Lo, Int'First + 1)) < Big_10 ** (W - 1)); - pragma Assert (Big (Int'Max (Hi, Int'First + 1)) < Big_10 ** (W - 1)); - return W; end if; diff --git a/gcc/ada/libgnat/s-widthu.adb b/gcc/ada/libgnat/s-widthu.adb index df27e50..fe51d61 100644 --- a/gcc/ada/libgnat/s-widthu.adb +++ b/gcc/ada/libgnat/s-widthu.adb @@ -31,110 +31,12 @@ package body System.Width_U is - -- Ghost code, loop invariants and assertions in this unit are meant for - -- analysis only, not for run-time checking, as it would be too costly - -- otherwise. This is enforced by setting the assertion policy to Ignore. - - pragma Assertion_Policy (Ghost => Ignore, - Loop_Invariant => Ignore, - Assert => Ignore, - Assert_And_Cut => Ignore, - Subprogram_Variant => Ignore); - function Width (Lo, Hi : Uns) return Natural is - - -- Ghost code, loop invariants and assertions in this unit are meant for - -- analysis only, not for run-time checking, as it would be too costly - -- otherwise. This is enforced by setting the assertion policy to - -- Ignore. - - pragma Assertion_Policy (Ghost => Ignore, - Loop_Invariant => Ignore, - Assert => Ignore); - - ------------------ - -- Local Lemmas -- - ------------------ - - procedure Lemma_Lower_Mult (A, B, C : Big_Natural) - with - Ghost, - Pre => A <= B, - Post => A * C <= B * C; - - procedure Lemma_Div_Commutation (X, Y : Uns) - with - Ghost, - Pre => Y /= 0, - Post => Big (X) / Big (Y) = Big (X / Y); - - procedure Lemma_Div_Twice (X : Big_Natural; Y, Z : Big_Positive) - with - Ghost, - Post => X / Y / Z = X / (Y * Z); - - procedure Lemma_Euclidian (V, Q, F, R : Big_Integer) - with - Ghost, - Pre => F > 0 and then Q = V / F and then R = V rem F, - Post => V = Q * F + R; - -- Ghost lemma to prove the relation between the quotient/remainder of - -- division by F and the value V. - - ---------------------- - -- Lemma_Lower_Mult -- - ---------------------- - - procedure Lemma_Lower_Mult (A, B, C : Big_Natural) is null; - - --------------------------- - -- Lemma_Div_Commutation -- - --------------------------- - - procedure Lemma_Div_Commutation (X, Y : Uns) is null; - - --------------------- - -- Lemma_Div_Twice -- - --------------------- - - procedure Lemma_Div_Twice (X : Big_Natural; Y, Z : Big_Positive) is - XY : constant Big_Natural := X / Y; - YZ : constant Big_Natural := Y * Z; - XYZ : constant Big_Natural := X / Y / Z; - R : constant Big_Natural := (XY rem Z) * Y + (X rem Y); - begin - pragma Assert (X = XY * Y + (X rem Y)); - pragma Assert (XY = XY / Z * Z + (XY rem Z)); - pragma Assert (X = XYZ * YZ + R); - pragma Assert ((XY rem Z) * Y <= (Z - 1) * Y); - pragma Assert (R <= YZ - 1); - pragma Assert (X / YZ = (XYZ * YZ + R) / YZ); - pragma Assert (X / YZ = XYZ + R / YZ); - end Lemma_Div_Twice; - - --------------------- - -- Lemma_Euclidian -- - --------------------- - - procedure Lemma_Euclidian (V, Q, F, R : Big_Integer) is null; - - -- Local variables - W : Natural; T : Uns; - - -- Local ghost variables - - Max_W : constant Natural := Max_Log10 with Ghost; - Pow : Big_Integer := 1 with Ghost; - T_Init : constant Uns := Uns'Max (Lo, Hi) with Ghost; - - -- Start of processing for System.Width_U - begin if Lo > Hi then return 0; - else -- Minimum value is 2, one for space, one for digit @@ -147,32 +49,10 @@ package body System.Width_U is -- Increase value if more digits required while T >= 10 loop - Lemma_Div_Commutation (T, 10); - Lemma_Div_Twice (Big (T_Init), Big_10 ** (W - 2), Big_10); - T := T / 10; W := W + 1; - Pow := Pow * 10; - - pragma Loop_Invariant (W in 3 .. Max_W + 2); - pragma Loop_Invariant (Pow = Big_10 ** (W - 2)); - pragma Loop_Invariant (Big (T) = Big (T_Init) / Pow); - pragma Loop_Variant (Decreases => T); end loop; - declare - F : constant Big_Integer := Big_10 ** (W - 2) with Ghost; - Q : constant Big_Integer := Big (T_Init) / F with Ghost; - R : constant Big_Integer := Big (T_Init) rem F with Ghost; - begin - pragma Assert (Q < Big_10); - Lemma_Euclidian (Big (T_Init), Q, F, R); - Lemma_Lower_Mult (Q, Big (9), F); - pragma Assert (Big (T_Init) <= Big (9) * F + F - 1); - pragma Assert (Big (T_Init) < Big_10 * F); - pragma Assert (Big_10 * F = Big_10 ** (W - 1)); - end; - return W; end if; end Width; diff --git a/gcc/ada/libgnat/s-widthu.ads b/gcc/ada/libgnat/s-widthu.ads index 56da0a2..076dace 100644 --- a/gcc/ada/libgnat/s-widthu.ads +++ b/gcc/ada/libgnat/s-widthu.ads @@ -29,65 +29,14 @@ -- -- ------------------------------------------------------------------------------ --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore, - Subprogram_Variant => Ignore); - -- Compute Width attribute for non-static type derived from a modular integer -- type. The arguments Lo, Hi are the bounds of the type. -with Ada.Numerics.Big_Numbers.Big_Integers_Ghost; - generic - type Uns is mod <>; package System.Width_U with Pure is - package BI_Ghost renames Ada.Numerics.Big_Numbers.Big_Integers_Ghost; - subtype Big_Integer is BI_Ghost.Big_Integer with Ghost; - subtype Big_Natural is BI_Ghost.Big_Natural with Ghost; - subtype Big_Positive is BI_Ghost.Big_Positive with Ghost; - use type BI_Ghost.Big_Integer; - - package Unsigned_Conversion is - new BI_Ghost.Unsigned_Conversions (Int => Uns); - - function Big (Arg : Uns) return Big_Integer renames - Unsigned_Conversion.To_Big_Integer; - - Big_10 : constant Big_Integer := Big (Uns'(10)) with Ghost; - - -- Maximum value of exponent for 10 that fits in Uns'Base - function Max_Log10 return Natural is - (case Uns'Base'Size is - when 8 => 2, - when 16 => 4, - when 32 => 9, - when 64 => 19, - when 128 => 38, - when others => raise Program_Error) - with Ghost; - - function Width (Lo, Hi : Uns) return Natural - with - Post => - (declare - W : constant Natural := System.Width_U.Width'Result; - begin - (if Lo > Hi then W = 0 - else W > 0 - and then W <= Max_Log10 + 2 - and then Big (Lo) < Big_10 ** (W - 1) - and then Big (Hi) < Big_10 ** (W - 1))); - + function Width (Lo, Hi : Uns) return Natural; end System.Width_U; diff --git a/gcc/ada/libgnat/s-widuns.ads b/gcc/ada/libgnat/s-widuns.ads index d81b862..6ac2928 100644 --- a/gcc/ada/libgnat/s-widuns.ads +++ b/gcc/ada/libgnat/s-widuns.ads @@ -31,17 +31,6 @@ -- Width attribute for modular integers up to Integer --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore); - with System.Width_U; with System.Unsigned_Types; diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads index 687d1ed..cbe4701 100644 --- a/gcc/ada/opt.ads +++ b/gcc/ada/opt.ads @@ -308,6 +308,10 @@ package Opt is -- GNATMAKE -- Set to True to check readonly files during the make process + Check_Semantics_Only_Mode : Boolean := False; + -- GNATMAKE + -- Set to True when -gnatc is present to only perform semantic checking. + Check_Source_Files : Boolean := True; -- GNATBIND, GNATMAKE -- Set to True to enable consistency checking for any source files that @@ -1518,10 +1522,6 @@ package Opt is -- used for inconsistency error messages. A value of System_Location is -- used if the policy is set in package System. - Tasking_Used : Boolean := False; - -- Set True if any tasking construct is encountered. Used to activate the - -- output of the Q, L and T lines in ALI files. - Time_Slice_Set : Boolean := False; -- GNATBIND -- Set True if a pragma Time_Slice is processed in the main unit, or diff --git a/gcc/ada/osint.adb b/gcc/ada/osint.adb index bf2affe..26b0dbb 100644 --- a/gcc/ada/osint.adb +++ b/gcc/ada/osint.adb @@ -64,6 +64,14 @@ package body Osint is -- Used in Locate_File as a fake directory when Name is already an -- absolute path. + procedure Get_Current_Dir + (Dir : System.Address; Length : System.Address); + pragma Import (C, Get_Current_Dir, "__gnat_get_current_dir"); + + Max_Path : Integer; + pragma Import (C, Max_Path, "__gnat_max_path_len"); + -- Maximum length of a path name + ------------------------------------- -- Use of Name_Find and Name_Enter -- ------------------------------------- @@ -1426,6 +1434,24 @@ package body Osint is Smart_Find_File (N, Source, Full_File, Attr.all); end Full_Source_Name; + --------------------- + -- Get_Current_Dir -- + --------------------- + + function Get_Current_Dir return String is + Path_Len : Natural := Max_Path; + Buffer : String (1 .. 1 + Max_Path + 1); + + begin + Get_Current_Dir (Buffer'Address, Path_Len'Address); + + if Path_Len = 0 then + raise Program_Error; + end if; + + return Buffer (1 .. Path_Len); + end Get_Current_Dir; + ------------------- -- Get_Directory -- ------------------- @@ -1517,15 +1543,6 @@ package body Osint is (Search_Dir : String; File_Type : Search_File_Type) return String_Ptr is - procedure Get_Current_Dir - (Dir : System.Address; - Length : System.Address); - pragma Import (C, Get_Current_Dir, "__gnat_get_current_dir"); - - Max_Path : Integer; - pragma Import (C, Max_Path, "__gnat_max_path_len"); - -- Maximum length of a path name - Current_Dir : String_Ptr; Default_Search_Dir : String_Access; Default_Suffix_Dir : String_Access; @@ -2732,6 +2749,84 @@ package body Osint is end Read_Source_File; ------------------- + -- Relative_Path -- + ------------------- + + function Relative_Path (Path : String; Ref : String) return String is + Norm_Path : constant String := + Normalize_Pathname (Name => Path, Resolve_Links => False); + Norm_Ref : constant String := + Normalize_Pathname (Name => Ref, Resolve_Links => False); + Rel_Path : Bounded_String; + Last : Natural := Norm_Ref'Last; + Old : Natural; + Depth : Natural := 0; + + begin + pragma Assert (System.OS_Lib.Is_Absolute_Path (Norm_Path)); + pragma Assert (System.OS_Lib.Is_Absolute_Path (Norm_Ref)); + pragma Assert (System.OS_Lib.Is_Directory (Norm_Ref)); + + -- If the root drives are different on Windows then we cannot create a + -- relative path. + + if Root (Norm_Path) /= Root (Norm_Ref) then + return Norm_Path; + end if; + + if Norm_Path = Norm_Ref then + return "."; + end if; + + loop + exit when Last - Norm_Ref'First + 1 <= Norm_Path'Length + and then + Norm_Path + (Norm_Path'First .. + Norm_Path'First + Last - Norm_Ref'First) = + Norm_Ref (Norm_Ref'First .. Last); + + Old := Last; + for J in reverse Norm_Ref'First .. Last - 1 loop + if Is_Directory_Separator (Norm_Ref (J)) then + Depth := Depth + 1; + Last := J; + exit; + end if; + end loop; + + if Old = Last then + -- No Dir_Separator in Ref... Let's return Path + return Norm_Path; + end if; + end loop; + + -- Move up the directory chain to the common point + + for I in 1 .. Depth loop + Append (Rel_Path, ".." & System.OS_Lib.Directory_Separator); + end loop; + + -- Avoid starting the relative path with a directory separator + + if Last < Norm_Path'Length + and then Is_Directory_Separator (Norm_Path (Norm_Path'First + Last)) + then + Last := Last + 1; + end if; + + -- Add the rest of the path from the common point + + Append + (Rel_Path, + Norm_Path + (Norm_Path'First + Last - Norm_Ref'First + 1 .. + Norm_Path'Last)); + + return To_String (Rel_Path); + end Relative_Path; + + ------------------- -- Relocate_Path -- ------------------- @@ -2788,6 +2883,25 @@ package body Osint is return new String'(Path); end Relocate_Path; + ---------- + -- Root -- + ---------- + + function Root (Path : String) return String is + Last : Natural := Path'First; + begin + pragma Assert (System.OS_Lib.Is_Absolute_Path (Path)); + + for I in Path'Range loop + if Is_Directory_Separator (Path (I)) then + Last := I; + exit; + end if; + end loop; + + return Path (Path'First .. Last); + end Root; + ----------------- -- Set_Program -- ----------------- diff --git a/gcc/ada/osint.ads b/gcc/ada/osint.ads index 041af41..77aaf04 100644 --- a/gcc/ada/osint.ads +++ b/gcc/ada/osint.ads @@ -166,6 +166,9 @@ package Osint is function Is_Directory_Separator (C : Character) return Boolean; -- Returns True if C is a directory separator + function Get_Current_Dir return String; + -- Returns the current working directory for the execution environment + function Get_Directory (Name : File_Name_Type) return File_Name_Type; -- Get the prefix directory name (if any) from Name. The last separator -- is preserved. Return the normalized current directory if there is no @@ -230,6 +233,15 @@ package Osint is (Canonical_File : String) return String_Access; -- Convert a canonical syntax file specification to host syntax + function Relative_Path (Path : String; Ref : String) return String; + -- Given an absolute path Path calculate its relative path from a reference + -- directory Ref. + -- + -- If the paths are the same it will return ".". + -- + -- If the paths are on different drives on Windows based systems then it + -- will return the normalized version of Path. + function Relocate_Path (Prefix : String; Path : String) return String_Ptr; @@ -243,6 +255,9 @@ package Osint is -- If the above computation fails, return Path. This function assumes -- Prefix'First = Path'First. + function Root (Path : String) return String; + -- Return the root of an absolute Path. + function Shared_Lib (Name : String) return String; -- Returns the runtime shared library in the form -l<name>-<version> where -- version is the GNAT runtime library option for the platform. For example diff --git a/gcc/ada/rtsfind.adb b/gcc/ada/rtsfind.adb index 70a6f12..86713ff 100644 --- a/gcc/ada/rtsfind.adb +++ b/gcc/ada/rtsfind.adb @@ -566,11 +566,11 @@ package body Rtsfind is subtype Ada_Numerics_Descendant is Ada_Descendant range Ada_Numerics_Big_Numbers .. - Ada_Numerics_Big_Numbers_Big_Integers_Ghost; + Ada_Numerics_Big_Numbers_Big_Integers; subtype Ada_Numerics_Big_Numbers_Descendant is Ada_Descendant range Ada_Numerics_Big_Numbers_Big_Integers .. - Ada_Numerics_Big_Numbers_Big_Integers_Ghost; + Ada_Numerics_Big_Numbers_Big_Integers; subtype Ada_Real_Time_Descendant is Ada_Descendant range Ada_Real_Time_Delays .. Ada_Real_Time_Timing_Events; diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index d57d4fa..37ed22b1 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -121,7 +121,6 @@ package Rtsfind is -- Children of Ada.Numerics.Big_Numbers Ada_Numerics_Big_Numbers_Big_Integers, - Ada_Numerics_Big_Numbers_Big_Integers_Ghost, -- Children of Ada.Real_Time @@ -582,7 +581,6 @@ package Rtsfind is RE_Reference, -- Ada.Interrupts RE_Big_Integer, -- Ada.Numerics.Big_Numbers.Big_Integers - RO_GH_Big_Integer, -- Ada.Numerics.Big_Numbers.Big_Integers_Ghost RO_SP_Big_Integer, -- SPARK.Big_Integers RE_Names, -- Ada.Interrupts.Names @@ -2231,7 +2229,6 @@ package Rtsfind is RE_Reference => Ada_Interrupts, RE_Big_Integer => Ada_Numerics_Big_Numbers_Big_Integers, - RO_GH_Big_Integer => Ada_Numerics_Big_Numbers_Big_Integers_Ghost, RO_SP_Big_Integer => SPARK_Big_Integers, RE_Names => Ada_Interrupts_Names, diff --git a/gcc/ada/sem.ads b/gcc/ada/sem.ads index f8a67a9..6113097 100644 --- a/gcc/ada/sem.ads +++ b/gcc/ada/sem.ads @@ -109,7 +109,7 @@ -- pragmas that appear with subprogram specifications rather than in the body. -- Collectively we call these Spec_Expressions. The routine that performs the --- special analysis is called Preanalyze_Spec_Expression. +-- special analysis is called Preanalyze_And_Resolve_Spec_Expression. -- Expansion has to be deferred since you can't generate code for expressions -- that reference types that have not been frozen yet. As an example, consider @@ -198,11 +198,11 @@ -- strict preanalysis of other expressions is that we do carry out freezing -- in the former (for static scalar expressions) but not in the latter. The -- routine that performs preanalysis of default expressions is called --- Preanalyze_Spec_Expression and is in Sem_Ch3. The routine that performs --- strict preanalysis and corresponding resolution is in Sem_Res and it is --- called Preanalyze_And_Resolve. Preanalyze_Spec_Expression relaxes the --- strictness of Preanalyze_And_Resolve setting to True the global boolean --- variable In_Spec_Expression before calling Preanalyze_And_Resolve. +-- Preanalyze_And_Resolve_Spec_Expression and is in Sem_Ch3. The routine that +-- performs strict preanalysis and corresponding resolution is in Sem_Res and +-- it is called Preanalyze_And_Resolve. Preanalyze_And_Resolve_Spec_Expression +-- relaxes the strictness of Preanalyze_And_Resolve setting to True the global +-- boolean variable In_Spec_Expression before calling Preanalyze_And_Resolve. with Alloc; with Einfo.Entities; use Einfo.Entities; diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index af08fdb..08da29a 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -7511,13 +7511,14 @@ package body Sem_Attr is Set_Etype (N, Standard_Boolean); Validate_Non_Static_Attribute_Function_Call; - if P_Type in Standard_Boolean + if Root_Type (P_Type) in Standard_Boolean | Standard_Character | Standard_Wide_Character | Standard_Wide_Wide_Character then Error_Attr_P - ("prefix of % attribute must not be a type in Standard"); + ("prefix of % attribute must not be a type originating from " & + "Standard"); end if; if Discard_Names (First_Subtype (P_Type)) then diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb index de5a8c8..9af96fc 100644 --- a/gcc/ada/sem_ch10.adb +++ b/gcc/ada/sem_ch10.adb @@ -123,15 +123,6 @@ package body Sem_Ch10 is -- Verify that a stub is declared immediately within a compilation unit, -- and not in an inner frame. - procedure Expand_With_Clause (Item : Node_Id; Nam : Node_Id; N : Node_Id); - -- When a child unit appears in a context clause, the implicit withs on - -- parents are made explicit, and with clauses are inserted in the context - -- clause before the one for the child. If a parent in the with_clause - -- is a renaming, the implicit with_clause is on the renaming whose name - -- is mentioned in the with_clause, and not on the package it renames. - -- N is the compilation unit whose list of context items receives the - -- implicit with_clauses. - procedure Generate_Parent_References (N : Node_Id; P_Id : Entity_Id); -- Generate cross-reference information for the parents of child units -- and of subunits. N is a defining_program_unit_name, and P_Id is the @@ -2955,6 +2946,7 @@ package body Sem_Ch10 is if Ada_Version >= Ada_95 and then In_Predefined_Renaming (U) + and then Comes_From_Source (N) then if Restriction_Check_Required (No_Obsolescent_Features) then Check_Restriction (No_Obsolescent_Features, N); diff --git a/gcc/ada/sem_ch10.ads b/gcc/ada/sem_ch10.ads index c80c412..9585785 100644 --- a/gcc/ada/sem_ch10.ads +++ b/gcc/ada/sem_ch10.ads @@ -45,6 +45,15 @@ package Sem_Ch10 is -- set when Ent is a tagged type and its class-wide type needs to appear -- in the tree. + procedure Expand_With_Clause (Item : Node_Id; Nam : Node_Id; N : Node_Id); + -- When a child unit appears in a context clause, the implicit withs on + -- parents are made explicit, and with clauses are inserted in the context + -- clause before the one for the child. If a parent in the with_clause + -- is a renaming, the implicit with_clause is on the renaming whose name + -- is mentioned in the with_clause, and not on the package it renames. + -- N is the compilation unit whose list of context items receives the + -- implicit with_clauses. + procedure Install_Context (N : Node_Id; Chain : Boolean := True); -- Installs the entities from the context clause of the given compilation -- unit into the visibility chains. This is done before analyzing a unit. diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 5768e28e..d961f03 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -3371,7 +3371,7 @@ package body Sem_Ch12 is end if; if Present (E) then - Preanalyze_Spec_Expression (E, T); + Preanalyze_And_Resolve_Spec_Expression (E, T); -- The default for a ghost generic formal IN parameter of -- access-to-variable type should be a ghost object (SPARK @@ -4195,7 +4195,7 @@ package body Sem_Ch12 is elsif Present (Expr) then Push_Scope (Nam); Install_Formals (Nam); - Preanalyze_Spec_Expression (Expr, Etype (Nam)); + Preanalyze_And_Resolve_Spec_Expression (Expr, Etype (Nam)); End_Scope; end if; diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 072ec66..69e18b0 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -6502,7 +6502,8 @@ package body Sem_Ch13 is -- and restored before and after analysis. Push_Type (U_Ent); - Preanalyze_Spec_Expression (Expr, RTE (RE_CPU_Range)); + Preanalyze_And_Resolve_Spec_Expression + (Expr, RTE (RE_CPU_Range)); Pop_Type (U_Ent); -- AI12-0117-1, "Restriction No_Tasks_Unassigned_To_CPU": @@ -6592,10 +6593,8 @@ package body Sem_Ch13 is -- The visibility to the components must be restored Push_Type (U_Ent); - - Preanalyze_Spec_Expression + Preanalyze_And_Resolve_Spec_Expression (Expr, RTE (RE_Dispatching_Domain)); - Pop_Type (U_Ent); end if; @@ -6674,10 +6673,8 @@ package body Sem_Ch13 is -- The visibility to the components must be restored Push_Type (U_Ent); - - Preanalyze_Spec_Expression + Preanalyze_And_Resolve_Spec_Expression (Expr, RTE (RE_Interrupt_Priority)); - Pop_Type (U_Ent); -- Check the No_Task_At_Interrupt_Priority restriction @@ -6843,7 +6840,8 @@ package body Sem_Ch13 is -- The visibility to the components must be restored Push_Type (U_Ent); - Preanalyze_Spec_Expression (Expr, Standard_Integer); + Preanalyze_And_Resolve_Spec_Expression + (Expr, Standard_Integer); Pop_Type (U_Ent); if not Is_OK_Static_Expression (Expr) then @@ -10039,8 +10037,8 @@ package body Sem_Ch13 is -- If the predicate pragma comes from an aspect, replace the -- saved expression because we need the subtype references - -- replaced for the calls to Preanalyze_Spec_Expression in - -- Check_Aspect_At_xxx routines. + -- replaced for the calls to Preanalyze_And_Resolve_Spec_ + -- Expression in Check_Aspect_At_xxx routines. if Present (Asp) then Set_Expression_Copy (Asp, New_Copy_Tree (Arg2_Copy)); @@ -10853,12 +10851,14 @@ package body Sem_Ch13 is | Aspect_Static_Predicate then Push_Type (Ent); - Preanalyze_Spec_Expression (Freeze_Expr, Standard_Boolean); + Preanalyze_And_Resolve_Spec_Expression + (Freeze_Expr, Standard_Boolean); Pop_Type (Ent); elsif A_Id = Aspect_Priority then Push_Type (Ent); - Preanalyze_Spec_Expression (Freeze_Expr, Any_Integer); + Preanalyze_And_Resolve_Spec_Expression + (Freeze_Expr, Any_Integer); Pop_Type (Ent); else @@ -10908,7 +10908,8 @@ package body Sem_Ch13 is elsif A_Id in Aspect_Default_Component_Value | Aspect_Default_Value and then Is_Private_Type (T) then - Preanalyze_Spec_Expression (End_Decl_Expr, Full_View (T)); + Preanalyze_And_Resolve_Spec_Expression + (End_Decl_Expr, Full_View (T)); -- The following aspect expressions may contain references to -- components and discriminants of the type. @@ -10922,14 +10923,15 @@ package body Sem_Ch13 is | Aspect_Static_Predicate then Push_Type (Ent); - Preanalyze_Spec_Expression (End_Decl_Expr, T); + Preanalyze_And_Resolve_Spec_Expression (End_Decl_Expr, T); Pop_Type (Ent); elsif A_Id = Aspect_Predicate_Failure then - Preanalyze_Spec_Expression (End_Decl_Expr, Standard_String); + Preanalyze_And_Resolve_Spec_Expression + (End_Decl_Expr, Standard_String); elsif Present (End_Decl_Expr) then - Preanalyze_Spec_Expression (End_Decl_Expr, T); + Preanalyze_And_Resolve_Spec_Expression (End_Decl_Expr, T); end if; Err := @@ -11359,7 +11361,7 @@ package body Sem_Ch13 is -- the aspect_specification cause freezing (RM 13.14(7.2/5)). if Present (Expression (ASN)) then - Preanalyze_Spec_Expression (Expression (ASN), T); + Preanalyze_And_Resolve_Spec_Expression (Expression (ASN), T); end if; end Check_Aspect_At_Freeze_Point; @@ -13928,7 +13930,7 @@ package body Sem_Ch13 is Next (First (Pragma_Argument_Associations (Ritem))); begin Push_Type (E); - Preanalyze_Spec_Expression + Preanalyze_And_Resolve_Spec_Expression (Expression (Arg), Standard_Boolean); Pop_Type (E); end; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 74eac9c..47e7ede 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -41,7 +41,6 @@ with Exp_Disp; use Exp_Disp; with Exp_Dist; use Exp_Dist; with Exp_Tss; use Exp_Tss; with Exp_Util; use Exp_Util; -with Expander; use Expander; with Fmap; with Freeze; use Freeze; with Ghost; use Ghost; @@ -623,9 +622,11 @@ package body Sem_Ch3 is -- Create a new ordinary fixed point type, and apply the constraint to -- obtain subtype of it. - procedure Preanalyze_Default_Expression (N : Node_Id; T : Entity_Id); - -- Wrapper on Preanalyze_Spec_Expression for default expressions, so that - -- In_Default_Expr can be properly adjusted. + procedure Preanalyze_And_Resolve_Default_Expression + (N : Node_Id; + T : Entity_Id); + -- Wrapper on Preanalyze_And_Resolve_Spec_Expression for default + -- expressions, so that In_Default_Expr can be properly adjusted. procedure Prepare_Private_Subtype_Completion (Id : Entity_Id; @@ -2110,7 +2111,7 @@ package body Sem_Ch3 is -- package Sem). if Present (E) then - Preanalyze_Default_Expression (E, T); + Preanalyze_And_Resolve_Default_Expression (E, T); Check_Initialization (T, E); if Ada_Version >= Ada_2005 @@ -2507,7 +2508,8 @@ package body Sem_Ch3 is (First (Pragma_Argument_Associations (ASN)))); Set_Parent (Exp, ASN); - Preanalyze_Assert_Expression (Exp, Standard_Boolean); + Preanalyze_And_Resolve_Assert_Expression + (Exp, Standard_Boolean); end if; ASN := Next_Pragma (ASN); @@ -4991,7 +4993,7 @@ package body Sem_Ch3 is if Is_Array_Type (T) and then No_Initialization (N) - and then Nkind (Original_Node (E)) = N_Aggregate + and then Nkind (Unqualify (Original_Node (E))) = N_Aggregate then Act_T := Etype (E); @@ -5137,10 +5139,7 @@ package body Sem_Ch3 is elsif Is_Array_Type (T) and then No_Initialization (N) - and then (Nkind (Original_Node (E)) = N_Aggregate - or else (Nkind (Original_Node (E)) = N_Qualified_Expression - and then Nkind (Original_Node (Expression - (Original_Node (E)))) = N_Aggregate)) + and then Nkind (Unqualify (Original_Node (E))) = N_Aggregate then if not Is_Entity_Name (Object_Definition (N)) then Act_T := Etype (E); @@ -6633,8 +6632,6 @@ package body Sem_Ch3 is end; end if; - -- Constrained array case - if No (T) then -- We might be creating more than one itype with the same Related_Id, -- e.g. for an array object definition and its initial value. Give @@ -6644,6 +6641,8 @@ package body Sem_Ch3 is T := Create_Itype (E_Void, P, Related_Id, 'T', Suffix_Index => -1); end if; + -- Constrained array case + if Nkind (Def) = N_Constrained_Array_Definition then Index := First (Discrete_Subtype_Definitions (Def)); @@ -20857,67 +20856,71 @@ package body Sem_Ch3 is Set_Is_Constrained (T); end Ordinary_Fixed_Point_Type_Declaration; - ---------------------------------- - -- Preanalyze_Assert_Expression -- - ---------------------------------- + ---------------------------------------------- + -- Preanalyze_And_Resolve_Assert_Expression -- + ---------------------------------------------- - procedure Preanalyze_Assert_Expression (N : Node_Id; T : Entity_Id) is + procedure Preanalyze_And_Resolve_Assert_Expression + (N : Node_Id; + T : Entity_Id) is begin In_Assertion_Expr := In_Assertion_Expr + 1; - Preanalyze_Spec_Expression (N, T); + Preanalyze_And_Resolve_Spec_Expression (N, T); In_Assertion_Expr := In_Assertion_Expr - 1; - end Preanalyze_Assert_Expression; - - -- ??? The variant below explicitly saves and restores all the flags, - -- because it is impossible to compose the existing variety of - -- Analyze/Resolve (and their wrappers, e.g. Preanalyze_Spec_Expression) - -- to achieve the desired semantics. + end Preanalyze_And_Resolve_Assert_Expression; - procedure Preanalyze_Assert_Expression (N : Node_Id) is - Save_In_Spec_Expression : constant Boolean := In_Spec_Expression; - Save_Full_Analysis : constant Boolean := Full_Analysis; + ---------------------------------------------- + -- Preanalyze_And_Resolve_Assert_Expression -- + ---------------------------------------------- + procedure Preanalyze_And_Resolve_Assert_Expression (N : Node_Id) is begin In_Assertion_Expr := In_Assertion_Expr + 1; - In_Spec_Expression := True; - Full_Analysis := False; - Expander_Mode_Save_And_Set (False); - - if GNATprove_Mode then - Analyze_And_Resolve (N); - else - Analyze_And_Resolve (N, Suppress => All_Checks); - end if; - - Expander_Mode_Restore; - Full_Analysis := Save_Full_Analysis; - In_Spec_Expression := Save_In_Spec_Expression; + Preanalyze_And_Resolve_Spec_Expression (N); In_Assertion_Expr := In_Assertion_Expr - 1; - end Preanalyze_Assert_Expression; + end Preanalyze_And_Resolve_Assert_Expression; - ----------------------------------- - -- Preanalyze_Default_Expression -- - ----------------------------------- + ----------------------------------------------- + -- Preanalyze_And_Resolve_Default_Expression -- + ----------------------------------------------- - procedure Preanalyze_Default_Expression (N : Node_Id; T : Entity_Id) is + procedure Preanalyze_And_Resolve_Default_Expression + (N : Node_Id; + T : Entity_Id) + is Save_In_Default_Expr : constant Boolean := In_Default_Expr; begin In_Default_Expr := True; - Preanalyze_Spec_Expression (N, T); + Preanalyze_And_Resolve_Spec_Expression (N, T); In_Default_Expr := Save_In_Default_Expr; - end Preanalyze_Default_Expression; + end Preanalyze_And_Resolve_Default_Expression; - -------------------------------- - -- Preanalyze_Spec_Expression -- - -------------------------------- + -------------------------------------------- + -- Preanalyze_And_Resolve_Spec_Expression -- + -------------------------------------------- - procedure Preanalyze_Spec_Expression (N : Node_Id; T : Entity_Id) is + procedure Preanalyze_And_Resolve_Spec_Expression + (N : Node_Id; + T : Entity_Id) + is Save_In_Spec_Expression : constant Boolean := In_Spec_Expression; begin In_Spec_Expression := True; Preanalyze_And_Resolve (N, T); In_Spec_Expression := Save_In_Spec_Expression; - end Preanalyze_Spec_Expression; + end Preanalyze_And_Resolve_Spec_Expression; + + -------------------------------------------- + -- Preanalyze_And_Resolve_Spec_Expression -- + -------------------------------------------- + + procedure Preanalyze_And_Resolve_Spec_Expression (N : Node_Id) is + Save_In_Spec_Expression : constant Boolean := In_Spec_Expression; + begin + In_Spec_Expression := True; + Preanalyze_And_Resolve (N); + In_Spec_Expression := Save_In_Spec_Expression; + end Preanalyze_And_Resolve_Spec_Expression; ---------------------------------------- -- Prepare_Private_Subtype_Completion -- @@ -21076,7 +21079,8 @@ package body Sem_Ch3 is -- Per-Object Expressions" in spec of package Sem). if Present (Expression (Discr)) then - Preanalyze_Default_Expression (Expression (Discr), Discr_Type); + Preanalyze_And_Resolve_Default_Expression + (Expression (Discr), Discr_Type); -- Legaity checks diff --git a/gcc/ada/sem_ch3.ads b/gcc/ada/sem_ch3.ads index 3d9aa0a..00a6fa77 100644 --- a/gcc/ada/sem_ch3.ads +++ b/gcc/ada/sem_ch3.ads @@ -236,19 +236,23 @@ package Sem_Ch3 is -- Always False in Ada 95 mode. Equivalent to OK_For_Limited_Init_In_05 in -- Ada 2005 mode. - procedure Preanalyze_Assert_Expression (N : Node_Id; T : Entity_Id); - -- Wrapper on Preanalyze_Spec_Expression for assertion expressions, so that - -- In_Assertion_Expr can be properly adjusted. + procedure Preanalyze_And_Resolve_Assert_Expression + (N : Node_Id; + T : Entity_Id); + -- Wrapper on Preanalyze_And_Resolve_Spec_Expression for assertion + -- expressions, so that In_Assertion_Expr can be properly adjusted. -- -- This routine must not be called when N is the root of a subtree that is -- not in its final place since it freezes static expression entities, -- which would be misplaced in the tree. Preanalyze_And_Resolve must be -- used in such a case to avoid reporting spurious errors. - procedure Preanalyze_Assert_Expression (N : Node_Id); + procedure Preanalyze_And_Resolve_Assert_Expression (N : Node_Id); -- Similar to the above, but without forcing N to be of a particular type - procedure Preanalyze_Spec_Expression (N : Node_Id; T : Entity_Id); + procedure Preanalyze_And_Resolve_Spec_Expression + (N : Node_Id; + T : Entity_Id); -- Default and per object expressions do not freeze their components, and -- must be analyzed and resolved accordingly. The analysis is done by -- calling the Preanalyze_And_Resolve routine and setting the global @@ -263,6 +267,9 @@ package Sem_Ch3 is -- which would be misplaced in the tree. Preanalyze_And_Resolve must be -- used in such a case to avoid reporting spurious errors. + procedure Preanalyze_And_Resolve_Spec_Expression (N : Node_Id); + -- Similar to the above, but without forcing N to be of a particular type + procedure Process_Full_View (N : Node_Id; Full_T, Priv_T : Entity_Id); -- Process some semantic actions when the full view of a private type is -- encountered and analyzed. The first action is to create the full views diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 05bbeed..d4e6d16 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -581,16 +581,21 @@ package body Sem_Ch6 is Set_Has_Completion (Def_Id, not Is_Ignored_Ghost_Entity (Def_Id)); Push_Scope (Def_Id); Install_Formals (Def_Id); - Preanalyze_Spec_Expression (Expr, Typ); + Preanalyze_And_Resolve_Spec_Expression (Expr, Typ); End_Scope; else Push_Scope (Def_Id); Install_Formals (Def_Id); - Preanalyze_Spec_Expression (Expr, Typ); + Preanalyze_And_Resolve_Spec_Expression (Expr, Typ); Check_Limited_Return (Orig_N, Expr, Typ); End_Scope; end if; + if Is_Incomplete_Type (Typ) then + Error_Msg_NE + ("premature usage of incomplete}", Expr, First_Subtype (Typ)); + end if; + -- In the case of an expression function marked with the aspect -- Static, we need to check the requirement that the function's -- expression is a potentially static expression. This is done @@ -617,7 +622,7 @@ package body Sem_Ch6 is begin Set_Checking_Potentially_Static_Expression (True); - Preanalyze_Spec_Expression (Exp_Copy, Typ); + Preanalyze_And_Resolve_Spec_Expression (Exp_Copy, Typ); if not Is_Static_Expression (Exp_Copy) then Error_Msg_N @@ -6094,7 +6099,7 @@ package body Sem_Ch6 is if NewD then Push_Scope (New_Id); - Preanalyze_Spec_Expression + Preanalyze_And_Resolve_Spec_Expression (Default_Value (New_Formal), Etype (New_Formal)); End_Scope; end if; @@ -6517,7 +6522,7 @@ package body Sem_Ch6 is -- expanded, so expand now to check conformance. if NewD then - Preanalyze_Spec_Expression + Preanalyze_And_Resolve_Spec_Expression (Expression (New_Discr), New_Discr_Type); end if; @@ -13207,7 +13212,7 @@ package body Sem_Ch6 is -- Do the special preanalysis of the expression (see section on -- "Handling of Default Expressions" in the spec of package Sem). - Preanalyze_Spec_Expression (Default, Formal_Type); + Preanalyze_And_Resolve_Spec_Expression (Default, Formal_Type); -- An access to constant cannot be the default for -- an access parameter that is an access to variable. diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 0a9ef41..65d3096 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -77,6 +77,7 @@ with Style; with Table; with Tbuild; use Tbuild; with Uintp; use Uintp; +with Uname; use Uname; with Warnsw; use Warnsw; package body Sem_Ch8 is @@ -4300,6 +4301,44 @@ package body Sem_Ch8 is begin pragma Assert (Nkind (Clause) = N_Use_Package_Clause); + + -- Perform "use implies with" expansion (when extensions are enabled) + -- by inserting an extra with clause since redundant clauses don't + -- really matter. + + if All_Extensions_Allowed and then Is_In_Context_Clause (Clause) then + declare + Unum : Unit_Number_Type; + With_Clause : constant Node_Id := + Make_With_Clause (Sloc (Clause), + Name => New_Copy_Tree (Pack)); + begin + -- Attempt to load the unit mentioned in the use clause + + Unum := Load_Unit + (Load_Name => Get_Unit_Name (With_Clause), + Required => False, + Subunit => False, + Error_Node => Clause, + With_Node => With_Clause); + + -- Either we can't file the unit or the use clause is a + -- reference to a nested package - in that case just handle + -- the use clause normally. + + if Unum /= No_Unit then + + Set_Library_Unit (With_Clause, Cunit (Unum)); + Set_Is_Implicit_With (With_Clause); + + Analyze (With_Clause); + Expand_With_Clause + (With_Clause, Name (With_Clause), + Enclosing_Comp_Unit_Node (Clause)); + end if; + end; + end if; + Analyze (Pack); -- Verify that the package standard is not directly named in a @@ -9504,6 +9543,11 @@ package body Sem_Ch8 is and then Present (Scope (Entity (E))) then Mark_Use_Package (Scope (Entity (E))); + + -- Additionally mark the types of the formals and the return + -- types as used when dealing with an overloaded operator. + + Mark_Parameters (Entity (E)); end if; Curr := Current_Use_Clause (Base); diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb index 71394aa..031c49f 100644 --- a/gcc/ada/sem_ch9.adb +++ b/gcc/ada/sem_ch9.adb @@ -753,8 +753,6 @@ package body Sem_Ch9 is T_Name : Node_Id; begin - Tasking_Used := True; - T_Name := First (Names (N)); while Present (T_Name) loop Analyze (T_Name); @@ -790,8 +788,6 @@ package body Sem_Ch9 is procedure Analyze_Accept_Alternative (N : Node_Id) is begin - Tasking_Used := True; - if Present (Pragmas_Before (N)) then Analyze_List (Pragmas_Before (N)); end if; @@ -823,8 +819,6 @@ package body Sem_Ch9 is Task_Nam : Entity_Id := Empty; -- initialize to prevent warning begin - Tasking_Used := True; - -- Entry name is initialized to Any_Id. It should get reset to the -- matching entry entity. An error is signalled if it is not reset. @@ -1064,7 +1058,6 @@ package body Sem_Ch9 is Trigger : Node_Id; begin - Tasking_Used := True; Check_Restriction (Max_Asynchronous_Select_Nesting, N); Check_Restriction (No_Select_Statements, N); @@ -1109,7 +1102,6 @@ package body Sem_Ch9 is Is_Disp_Select : Boolean := False; begin - Tasking_Used := True; Check_Restriction (No_Select_Statements, N); -- Ada 2005 (AI-345): The trigger may be a dispatching call @@ -1154,7 +1146,6 @@ package body Sem_Ch9 is Typ : Entity_Id; begin - Tasking_Used := True; Check_Restriction (No_Delay, N); if Present (Pragmas_Before (N)) then @@ -1206,7 +1197,6 @@ package body Sem_Ch9 is E : constant Node_Id := Expression (N); begin - Tasking_Used := True; Check_Restriction (No_Relative_Delay, N); Check_Restriction (No_Delay, N); Check_Potentially_Blocking_Operation (N); @@ -1231,7 +1221,6 @@ package body Sem_Ch9 is Typ : Entity_Id; begin - Tasking_Used := True; Check_Restriction (No_Delay, N); Check_Potentially_Blocking_Operation (N); Analyze_And_Resolve (E); @@ -1266,8 +1255,6 @@ package body Sem_Ch9 is Freeze_Previous_Contracts (N); - Tasking_Used := True; - -- Entry_Name is initialized to Any_Id. It should get reset to the -- matching entry entity. An error is signalled if it is not reset. @@ -1518,8 +1505,6 @@ package body Sem_Ch9 is Formals : constant List_Id := Parameter_Specifications (N); begin - Tasking_Used := True; - if Present (Index) then Analyze (Index); @@ -1545,8 +1530,6 @@ package body Sem_Ch9 is Call : constant Node_Id := Entry_Call_Statement (N); begin - Tasking_Used := True; - if Present (Pragmas_Before (N)) then Analyze_List (Pragmas_Before (N)); end if; @@ -1589,8 +1572,6 @@ package body Sem_Ch9 is begin Generate_Definition (Def_Id); - Tasking_Used := True; - -- Case of no discrete subtype definition if No (D_Sdef) then @@ -1751,7 +1732,6 @@ package body Sem_Ch9 is Loop_Id : constant Entity_Id := Make_Temporary (Sloc (N), 'L'); begin - Tasking_Used := True; Analyze (Def); -- There is no elaboration of the entry index specification. Therefore, @@ -1848,7 +1828,6 @@ package body Sem_Ch9 is Freeze_Previous_Contracts (N); - Tasking_Used := True; Mutate_Ekind (Body_Id, E_Protected_Body); Set_Etype (Body_Id, Standard_Void_Type); Spec_Id := Find_Concurrent_Spec (Body_Id); @@ -1991,7 +1970,6 @@ package body Sem_Ch9 is -- Start of processing for Analyze_Protected_Definition begin - Tasking_Used := True; Analyze_Declarations (Visible_Declarations (N)); if not Is_Empty_List (Private_Declarations (N)) then @@ -2047,7 +2025,6 @@ package body Sem_Ch9 is return; end if; - Tasking_Used := True; Check_Restriction (No_Protected_Types, N); T := Find_Type_Name (N); @@ -2422,7 +2399,6 @@ package body Sem_Ch9 is Modes => True, Warnings => True); - Tasking_Used := True; Check_Restriction (No_Requeue_Statements, N); Check_Unreachable_Code (N); @@ -2754,7 +2730,6 @@ package body Sem_Ch9 is Alt_Count : Uint := Uint_0; begin - Tasking_Used := True; Check_Restriction (No_Select_Statements, N); -- Loop to analyze alternatives @@ -2871,7 +2846,6 @@ package body Sem_Ch9 is begin Generate_Definition (Obj_Id); - Tasking_Used := True; -- A single protected declaration is transformed into a pair of an -- anonymous protected type and an object of that type. Generate: @@ -2959,7 +2933,6 @@ package body Sem_Ch9 is begin Generate_Definition (Obj_Id); - Tasking_Used := True; -- A single task declaration is transformed into a pair of an anonymous -- task type and an object of that type. Generate: @@ -3074,7 +3047,6 @@ package body Sem_Ch9 is Freeze_Previous_Contracts (N); - Tasking_Used := True; Set_Scope (Body_Id, Current_Scope); Mutate_Ekind (Body_Id, E_Task_Body); Set_Etype (Body_Id, Standard_Void_Type); @@ -3219,8 +3191,6 @@ package body Sem_Ch9 is L : Entity_Id; begin - Tasking_Used := True; - if Present (Visible_Declarations (N)) then Analyze_Declarations (Visible_Declarations (N)); end if; @@ -3265,8 +3235,6 @@ package body Sem_Ch9 is -- Proceed ahead with analysis of task type declaration - Tasking_Used := True; - -- The sequential partition elaboration policy is supported only in the -- restricted profile. @@ -3448,8 +3416,6 @@ package body Sem_Ch9 is procedure Analyze_Terminate_Alternative (N : Node_Id) is begin - Tasking_Used := True; - if Present (Pragmas_Before (N)) then Analyze_List (Pragmas_Before (N)); end if; @@ -3469,7 +3435,6 @@ package body Sem_Ch9 is Is_Disp_Select : Boolean := False; begin - Tasking_Used := True; Check_Restriction (No_Select_Statements, N); -- Ada 2005 (AI-345): The trigger may be a dispatching call @@ -3504,8 +3469,6 @@ package body Sem_Ch9 is Trigger : constant Node_Id := Triggering_Statement (N); begin - Tasking_Used := True; - if Present (Pragmas_Before (N)) then Analyze_List (Pragmas_Before (N)); end if; diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb index b7dfe01..5d15063 100644 --- a/gcc/ada/sem_eval.adb +++ b/gcc/ada/sem_eval.adb @@ -4989,27 +4989,41 @@ package body Sem_Eval is end if; end Check_Elab_Call; - Modulus, Val : Uint; - begin - if Compile_Time_Known_Value (Left) - and then Compile_Time_Known_Value (Right) + if not (Compile_Time_Known_Value (Left) + and then Compile_Time_Known_Value (Right)) then - pragma Assert (not Non_Binary_Modulus (Typ)); + return; + end if; + + pragma Assert (not Non_Binary_Modulus (Typ)); + pragma Assert (Expr_Value (Right) >= Uint_0); -- Amount is always Natural + + -- Shift by zero bits is a no-op + if Expr_Value (Right) = Uint_0 then + Fold_Uint (N, Expr_Value (Left), Static => Static); + return; + end if; + + declare + Modulus : constant Uint := + (if Is_Modular_Integer_Type (Typ) then Einfo.Entities.Modulus (Typ) + else Uint_2 ** RM_Size (Typ)); + Amount : constant Uint := UI_Min (Expr_Value (Right), RM_Size (Typ)); + -- Shift by an Amount greater than the size is all-zeros or all-ones. + -- Without this "min", we could use huge amounts of time and memory + -- below (e.g. 2**Amount, if Amount were a billion). + + Val : Uint; + begin if Op = N_Op_Shift_Left then Check_Elab_Call; - if Is_Modular_Integer_Type (Typ) then - Modulus := Einfo.Entities.Modulus (Typ); - else - Modulus := Uint_2 ** RM_Size (Typ); - end if; - -- Fold Shift_Left (X, Y) by computing -- (X * 2**Y) rem modulus [- Modulus] - Val := (Expr_Value (Left) * (Uint_2 ** Expr_Value (Right))) + Val := (Expr_Value (Left) * (Uint_2 ** Amount)) rem Modulus; if Is_Modular_Integer_Type (Typ) @@ -5023,49 +5037,32 @@ package body Sem_Eval is elsif Op = N_Op_Shift_Right then Check_Elab_Call; - -- X >> 0 is a no-op + -- Fold X >> Y by computing (X [+ Modulus]) / 2**Y. + -- Note that after a Shift_Right operation (with Y > 0), the + -- result is always positive, even if the original operand was + -- negative. - if Expr_Value (Right) = Uint_0 then - Fold_Uint (N, Expr_Value (Left), Static => Static); - else - if Is_Modular_Integer_Type (Typ) then - Modulus := Einfo.Entities.Modulus (Typ); + declare + M : Unat; + begin + if Expr_Value (Left) >= Uint_0 then + M := Uint_0; else - Modulus := Uint_2 ** RM_Size (Typ); + M := Modulus; end if; - -- Fold X >> Y by computing (X [+ Modulus]) / 2**Y - -- Note that after a Shift_Right operation (with Y > 0), the - -- result is always positive, even if the original operand was - -- negative. - - declare - M : Unat; - begin - if Expr_Value (Left) >= Uint_0 then - M := Uint_0; - else - M := Modulus; - end if; + Fold_Uint + (N, + (Expr_Value (Left) + M) / (Uint_2 ** Amount), + Static => Static); + end; - Fold_Uint - (N, - (Expr_Value (Left) + M) / (Uint_2 ** Expr_Value (Right)), - Static => Static); - end; - end if; elsif Op = N_Op_Shift_Right_Arithmetic then Check_Elab_Call; declare - Two_Y : constant Uint := Uint_2 ** Expr_Value (Right); + Two_Y : constant Uint := Uint_2 ** Amount; begin - if Is_Modular_Integer_Type (Typ) then - Modulus := Einfo.Entities.Modulus (Typ); - else - Modulus := Uint_2 ** RM_Size (Typ); - end if; - -- X / 2**Y if X if positive or a small enough modular integer if (Is_Modular_Integer_Type (Typ) @@ -5096,7 +5093,7 @@ package body Sem_Eval is (N, (Expr_Value (Left)) / Two_Y + (Two_Y - Uint_1) - * Uint_2 ** (RM_Size (Typ) - Expr_Value (Right)), + * Uint_2 ** (RM_Size (Typ) - Amount), Static => Static); -- Negative signed integer, compute via multiple/divide the @@ -5108,13 +5105,15 @@ package body Sem_Eval is (N, (Modulus + Expr_Value (Left)) / Two_Y + (Two_Y - Uint_1) - * Uint_2 ** (RM_Size (Typ) - Expr_Value (Right)) + * Uint_2 ** (RM_Size (Typ) - Amount) - Modulus, Static => Static); end if; end; + else + raise Program_Error; end if; - end if; + end; end Fold_Shift; -------------- diff --git a/gcc/ada/sem_eval.ads b/gcc/ada/sem_eval.ads index 138278f..7df1c4c 100644 --- a/gcc/ada/sem_eval.ads +++ b/gcc/ada/sem_eval.ads @@ -342,41 +342,12 @@ package Sem_Eval is -- set of messages is all posted. procedure Fold_Str (N : Node_Id; Val : String_Id; Static : Boolean); - -- Rewrite N with a new N_String_Literal node as the result of the compile - -- time evaluation of the node N. Val is the resulting string value from - -- the folding operation. The Is_Static_Expression flag is set in the - -- result node. The result is fully analyzed and resolved. Static indicates - -- whether the result should be considered static or not (True = consider - -- static). The point here is that normally all string literals are static, - -- but if this was the result of some sequence of evaluation where values - -- were known at compile time but not static, then the result is not - -- static. The call has no effect if Raises_Constraint_Error (N) is True, - -- since there is no point in folding if we have an error. - procedure Fold_Uint (N : Node_Id; Val : Uint; Static : Boolean); - -- Rewrite N with a (N_Integer_Literal, N_Identifier, N_Character_Literal) - -- node as the result of the compile time evaluation of the node N. Val is - -- the result in the integer case and is the position of the literal in the - -- literals list for the enumeration case. Is_Static_Expression is set True - -- in the result node. The result is fully analyzed/resolved. Static - -- indicates whether the result should be considered static or not (True = - -- consider static). The point here is that normally all integer literals - -- are static, but if this was the result of some sequence of evaluation - -- where values were known at compile time but not static, then the result - -- is not static. The call has no effect if Raises_Constraint_Error (N) is - -- True, since there is no point in folding if we have an error. - procedure Fold_Ureal (N : Node_Id; Val : Ureal; Static : Boolean); - -- Rewrite N with a new N_Real_Literal node as the result of the compile - -- time evaluation of the node N. Val is the resulting real value from the - -- folding operation. The Is_Static_Expression flag is set in the result - -- node. The result is fully analyzed and result. Static indicates whether - -- the result should be considered static or not (True = consider static). - -- The point here is that normally all string literals are static, but if - -- this was the result of some sequence of evaluation where values were - -- known at compile time but not static, then the result is not static. - -- The call has no effect if Raises_Constraint_Error (N) is True, since - -- there is no point in folding if we have an error. + -- Rewrite N with a new literal node with compile-time-known value Val. + -- Is_Static_Expression is set to Static. This has no effect if + -- Raises_Constraint_Error (N) is True, since there is no point in + -- folding if we have an error. procedure Fold (N : Node_Id); -- Rewrite N with the relevant value if Compile_Time_Known_Value (N) is diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 621edc7..fafd274 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -474,7 +474,8 @@ package body Sem_Prag is end if; Errors := Serious_Errors_Detected; - Preanalyze_Assert_Expression (Expression (Arg1), Standard_Boolean); + Preanalyze_And_Resolve_Assert_Expression + (Expression (Arg1), Standard_Boolean); -- Emit a clarification message when the expression contains at least -- one undefined reference, possibly due to contract freezing. @@ -564,7 +565,8 @@ package body Sem_Prag is if Nkind (Case_Guard) /= N_Others_Choice then Errors := Serious_Errors_Detected; - Preanalyze_Assert_Expression (Case_Guard, Standard_Boolean); + Preanalyze_And_Resolve_Assert_Expression + (Case_Guard, Standard_Boolean); -- Emit a clarification message when the case guard contains -- at least one undefined reference, possibly due to contract @@ -579,7 +581,8 @@ package body Sem_Prag is end if; Errors := Serious_Errors_Detected; - Preanalyze_Assert_Expression (Conseq, Standard_Boolean); + Preanalyze_And_Resolve_Assert_Expression + (Conseq, Standard_Boolean); -- Emit a clarification message when the consequence contains -- at least one undefined reference, possibly due to contract @@ -2391,9 +2394,10 @@ package body Sem_Prag is Errors := Serious_Errors_Detected; - -- Preanalyze_Assert_Expression enforcing the expression type + -- Preanalyze_And_Resolve_Assert_Expression enforcing the expression + -- type. - Preanalyze_Assert_Expression (Consequence, Any_Boolean); + Preanalyze_And_Resolve_Assert_Expression (Consequence, Any_Boolean); Check_Params (Consequence); @@ -2621,7 +2625,8 @@ package body Sem_Prag is if Nkind (Case_Guard) /= N_Others_Choice then Errors := Serious_Errors_Detected; - Preanalyze_Assert_Expression (Case_Guard, Standard_Boolean); + Preanalyze_And_Resolve_Assert_Expression + (Case_Guard, Standard_Boolean); -- Emit a clarification message when the case guard contains -- at least one undefined reference, possibly due to contract @@ -5112,10 +5117,6 @@ package body Sem_Prag is -- Determines if the placement of the current pragma is appropriate -- for a configuration pragma. - function Is_In_Context_Clause return Boolean; - -- Returns True if pragma appears within the context clause of a unit, - -- and False for any other placement (does not generate any messages). - function Is_Static_String_Expression (Arg : Node_Id) return Boolean; -- Analyzes the argument, and determines if it is a static string -- expression, returns True if so, False if non-static or not String. @@ -5585,7 +5586,7 @@ package body Sem_Prag is if Present (Arg2) then Check_Optional_Identifier (Arg2, Name_Message); - Preanalyze_Assert_Expression + Preanalyze_And_Resolve_Assert_Expression (Get_Pragma_Arg (Arg2), Standard_String); end if; end if; @@ -6009,7 +6010,7 @@ package body Sem_Prag is -- Check case of appearing within context clause - if not Is_Unused and then Is_In_Context_Clause then + if not Is_Unused and then Is_In_Context_Clause (N) then -- The arguments must all be units mentioned in a with clause in -- the same context clause. Note that Par.Prag already checked @@ -8127,27 +8128,6 @@ package body Sem_Prag is end if; end Is_Configuration_Pragma; - -------------------------- - -- Is_In_Context_Clause -- - -------------------------- - - function Is_In_Context_Clause return Boolean is - Plist : List_Id; - Parent_Node : Node_Id; - - begin - if Is_List_Member (N) then - Plist := List_Containing (N); - Parent_Node := Parent (Plist); - - return Present (Parent_Node) - and then Nkind (Parent_Node) = N_Compilation_Unit - and then Context_Items (Parent_Node) = Plist; - end if; - - return False; - end Is_In_Context_Clause; - --------------------------------- -- Is_Static_String_Expression -- --------------------------------- @@ -14065,7 +14045,7 @@ package body Sem_Prag is -- Perform preanalysis to deal with embedded Loop_Entry -- attributes. - Preanalyze_Assert_Expression (Expr, Any_Boolean); + Preanalyze_And_Resolve_Assert_Expression (Expr, Any_Boolean); end if; -- Implement Assert[_And_Cut]/Assume/Loop_Invariant by generating @@ -16166,7 +16146,8 @@ package body Sem_Prag is -- described in "Handling of Default and Per-Object -- Expressions" in sem.ads. - Preanalyze_Spec_Expression (Arg, RTE (RE_CPU_Range)); + Preanalyze_And_Resolve_Spec_Expression + (Arg, RTE (RE_CPU_Range)); -- See comment in Sem_Ch13 about the following restrictions @@ -16212,7 +16193,7 @@ package body Sem_Prag is -- The expression must be analyzed in the special manner described -- in "Handling of Default and Per-Object Expressions" in sem.ads. - Preanalyze_Spec_Expression (Arg, RTE (RE_Time_Span)); + Preanalyze_And_Resolve_Spec_Expression (Arg, RTE (RE_Time_Span)); -- Only protected types allowed @@ -16841,7 +16822,8 @@ package body Sem_Prag is -- described in "Handling of Default and Per-Object -- Expressions" in sem.ads. - Preanalyze_Spec_Expression (Arg, RTE (RE_Dispatching_Domain)); + Preanalyze_And_Resolve_Spec_Expression + (Arg, RTE (RE_Dispatching_Domain)); -- Check duplicate pragma before we chain the pragma in the Rep -- Item chain of Ent. @@ -16869,7 +16851,7 @@ package body Sem_Prag is begin -- Pragma must be in context items list of a compilation unit - if not Is_In_Context_Clause then + if not Is_In_Context_Clause (N) then Pragma_Misplaced; end if; @@ -16965,7 +16947,7 @@ package body Sem_Prag is -- Pragma must be in context items list of a compilation unit - if not Is_In_Context_Clause then + if not Is_In_Context_Clause (N) then Pragma_Misplaced; end if; @@ -20074,7 +20056,8 @@ package body Sem_Prag is -- described in "Handling of Default and Per-Object -- Expressions" in sem.ads. - Preanalyze_Spec_Expression (Arg, RTE (RE_Interrupt_Priority)); + Preanalyze_And_Resolve_Spec_Expression + (Arg, RTE (RE_Interrupt_Priority)); end if; if Nkind (P) not in N_Task_Definition | N_Protected_Definition then @@ -20979,10 +20962,10 @@ package body Sem_Prag is ("Structural variant shall be the only variant", Variant); end if; - -- Preanalyze_Assert_Expression, but without enforcing any of - -- the two acceptable types. + -- Preanalyze_And_Resolve_Assert_Expression, but without + -- enforcing any of the two acceptable types. - Preanalyze_Assert_Expression (Expression (Variant)); + Preanalyze_And_Resolve_Assert_Expression (Expression (Variant)); -- Expression of a discrete type is allowed. Nothing to -- check for structural variants. @@ -20992,7 +20975,7 @@ package body Sem_Prag is then null; - -- Expression of a Big_Integer type (or its ghost variant) is + -- Expression of a Big_Integer type (or its SPARK variant) is -- only allowed in Decreases clause. elsif @@ -21000,9 +20983,6 @@ package body Sem_Prag is RE_Big_Integer) or else Is_RTE (Base_Type (Etype (Expression (Variant))), - RO_GH_Big_Integer) - or else - Is_RTE (Base_Type (Etype (Expression (Variant))), RO_SP_Big_Integer) then if Chars (Variant) = Name_Increases then @@ -23410,7 +23390,8 @@ package body Sem_Prag is -- described in "Handling of Default and Per-Object -- Expressions" in sem.ads. - Preanalyze_Spec_Expression (Arg, RTE (RE_Any_Priority)); + Preanalyze_And_Resolve_Spec_Expression + (Arg, RTE (RE_Any_Priority)); if not Is_OK_Static_Expression (Arg) then Check_Restriction (Static_Priorities, Arg); @@ -24397,7 +24378,7 @@ package body Sem_Prag is -- The expression must be analyzed in the special manner described -- in "Handling of Default and Per-Object Expressions" in sem.ads. - Preanalyze_Spec_Expression (Arg, RTE (RE_Time_Span)); + Preanalyze_And_Resolve_Spec_Expression (Arg, RTE (RE_Time_Span)); -- Subprogram case @@ -24657,7 +24638,7 @@ package body Sem_Prag is -- The expression must be analyzed in the special manner -- described in "Handling of Default Expressions" in sem.ads. - Preanalyze_Spec_Expression (Arg, Any_Integer); + Preanalyze_And_Resolve_Spec_Expression (Arg, Any_Integer); -- The pragma cannot appear if the No_Secondary_Stack -- restriction is in effect. @@ -25815,7 +25796,7 @@ package body Sem_Prag is -- in "Handling of Default Expressions" in sem.ads. Arg := Get_Pragma_Arg (Arg1); - Preanalyze_Spec_Expression (Arg, Any_Integer); + Preanalyze_And_Resolve_Spec_Expression (Arg, Any_Integer); if not Is_OK_Static_Expression (Arg) then Check_Restriction (Static_Storage_Size, Arg); @@ -28241,7 +28222,7 @@ package body Sem_Prag is end if; Errors := Serious_Errors_Detected; - Preanalyze_Assert_Expression (Expr, Standard_Boolean); + Preanalyze_And_Resolve_Assert_Expression (Expr, Standard_Boolean); -- Emit a clarification message when the expression contains at least -- one undefined reference, possibly due to contract freezing. @@ -30956,34 +30937,67 @@ package body Sem_Prag is -- end Pack; if Constit_Id = Any_Id then - SPARK_Msg_NE ("& is undefined", Constit, Constit_Id); + -- A "Foo is undefined" message has already been + -- generated for this constituent. Emit an additional + -- message in the special case where the named + -- would-be constituent was declared too late in the + -- declaration list (as opposed to, for example, not + -- being declared at all). + + -- Look for named constituent after freezing point + if Present (Freeze_Id) then + declare + Decl : Node_Id; + begin + Decl := Enclosing_Declaration (Freeze_Id); - -- Emit a specialized info message when the contract of - -- the related package body was "frozen" by another body. - -- Note that it is not possible to precisely identify why - -- the constituent is undefined because it is not visible - -- when pragma Refined_State is analyzed. This message is - -- a reasonable approximation. + while Present (Decl) loop + if Nkind (Decl) = N_Object_Declaration + and then Same_Name (Defining_Identifier (Decl), + Constit) + and then not Constant_Present (Decl) + then + Error_Msg_Node_1 := Constit; + Error_Msg_Sloc := + Sloc (Defining_Identifier (Decl)); - if Present (Freeze_Id) and then not Freeze_Posted then - Freeze_Posted := True; + SPARK_Msg_NE + ("abstract state constituent & declared" + & " too late #!", Constit, Constit); - Error_Msg_Name_1 := Chars (Body_Id); - Error_Msg_Sloc := Sloc (Freeze_Id); - SPARK_Msg_NE - ("body & declared # freezes the contract of %", - N, Freeze_Id); - SPARK_Msg_N - ("\all constituents must be declared before body #", - N); + exit; + end if; + Next (Decl); + end loop; + end; + + -- Emit a specialized info message when the contract + -- of the related package body was "frozen" by + -- another body. If a "declared too late" message + -- is generated, this will clarify what is meant by + -- "too late". + + if not Freeze_Posted then + Freeze_Posted := True; - -- A misplaced constituent is a critical error because - -- pragma Refined_Depends or Refined_Global depends on - -- the proper link between a state and a constituent. - -- Stop the compilation, as this leads to a multitude - -- of misleading cascaded errors. + Error_Msg_Name_1 := Chars (Body_Id); + Error_Msg_Sloc := Sloc (Freeze_Id); + SPARK_Msg_NE + ("body & declared # freezes the contract of %", + N, Freeze_Id); + SPARK_Msg_N + ("\all constituents must be declared" & + " before body #", N); - raise Unrecoverable_Error; + -- A misplaced constituent is a critical error + -- because pragma Refined_Depends or + -- Refined_Global depends on the proper link + -- between a state and a constituent. Stop the + -- compilation, as this leads to a multitude of + -- misleading cascaded errors. + + raise Unrecoverable_Error; + end if; end if; -- The constituent is a valid state or object @@ -31452,10 +31466,10 @@ package body Sem_Prag is Errors := Serious_Errors_Detected; - -- Preanalyze_Assert_Expression, but without enforcing any of the - -- acceptable types. + -- Preanalyze_And_Resolve_Assert_Expression, but without enforcing + -- any of the acceptable types. - Preanalyze_Assert_Expression (Expr); + Preanalyze_And_Resolve_Assert_Expression (Expr); -- Expression of a discrete type is allowed. Nothing more to check -- for structural variants. @@ -31468,12 +31482,8 @@ package body Sem_Prag is -- Expression of a Big_Integer type (or its ghost variant) is only -- allowed in Decreases clause. - elsif - Is_RTE (Base_Type (Etype (Expr)), RE_Big_Integer) - or else - Is_RTE (Base_Type (Etype (Expr)), RO_GH_Big_Integer) - or else - Is_RTE (Base_Type (Etype (Expr)), RO_SP_Big_Integer) + elsif Is_RTE (Base_Type (Etype (Expr)), RE_Big_Integer) + or else Is_RTE (Base_Type (Etype (Expr)), RO_SP_Big_Integer) then if Chars (Direction) = Name_Increases then Error_Msg_N @@ -31633,7 +31643,7 @@ package body Sem_Prag is From_Aspect => True); if Present (Arg) then - Preanalyze_Assert_Expression + Preanalyze_And_Resolve_Assert_Expression (Expression (Arg), Standard_Boolean); end if; end if; @@ -31641,7 +31651,8 @@ package body Sem_Prag is Arg := Test_Case_Arg (N, Arg_Nam); if Present (Arg) then - Preanalyze_Assert_Expression (Expression (Arg), Standard_Boolean); + Preanalyze_And_Resolve_Assert_Expression + (Expression (Arg), Standard_Boolean); end if; end Preanalyze_Test_Case_Arg; diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index b73b947..865f967 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -2106,8 +2106,6 @@ package body Sem_Res is Full_Analysis := False; Expander_Mode_Save_And_Set (False); - -- See also Preanalyze_And_Resolve in sem.adb for similar handling - -- Normally, we suppress all checks for this preanalysis. There is no -- point in processing them now, since they will be applied properly -- and in the proper location when the default expressions reanalyzed @@ -2150,8 +2148,13 @@ package body Sem_Res is Full_Analysis := False; Expander_Mode_Save_And_Set (False); - Analyze (N); - Resolve (N, Etype (N), Suppress => All_Checks); + -- See previous version of Preanalyze_And_Resolve for similar handling + + if GNATprove_Mode then + Analyze_And_Resolve (N); + else + Analyze_And_Resolve (N, Suppress => All_Checks); + end if; Expander_Mode_Restore; Full_Analysis := Save_Full_Analysis; @@ -6101,6 +6104,8 @@ package body Sem_Res is elsif Is_Fixed_Point_Type (It.Typ) then if Analyzed (N) then Error_Msg_N ("ambiguous operand in fixed operation", N); + elsif It.Typ = Any_Fixed then + Resolve (N, B_Typ); else Resolve (N, It.Typ); end if; @@ -7801,6 +7806,7 @@ package body Sem_Res is then Set_Entity (N, Local); Set_Etype (N, Etype (Local)); + Generate_Reference (Local, N); end if; return OK; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 0e1505b..97dc4c0 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -3025,7 +3025,7 @@ package body Sem_Util is -- For an array aggregate, a discrete_choice_list that has -- a nonstatic range is considered as two or more separate - -- occurrences of the expression (RM 6.4.1(20/3)). + -- occurrences of the expression (RM 6.4.1(6.20/3)). elsif Is_Array_Type (Etype (N)) and then Nkind (N) = N_Aggregate @@ -3110,48 +3110,105 @@ package body Sem_Util is end loop; end if; - -- Handle discrete associations + -- Handle named associations if Present (Component_Associations (N)) then Assoc := First (Component_Associations (N)); while Present (Assoc) loop - if not Box_Present (Assoc) then - Choice := First (Choices (Assoc)); - while Present (Choice) loop + Handle_Association : declare - -- For now we skip discriminants since it requires - -- performing the analysis in two phases: first one - -- analyzing discriminants and second one analyzing - -- the rest of components since discriminants are - -- evaluated prior to components: too much extra - -- work to detect a corner case??? + procedure Collect_Expression_Ids (Expr : Node_Id); + -- Collect identifiers in association expression Expr - if Nkind (Choice) in N_Has_Entity - and then Present (Entity (Choice)) - and then Ekind (Entity (Choice)) = E_Discriminant - then - null; + procedure Handle_Association_Choices + (Choices : List_Id; Expr : Node_Id); + -- Collect identifiers in an association expression + -- Expr for each choice in Choices. + + ---------------------------- + -- Collect_Expression_Ids -- + ---------------------------- - elsif Box_Present (Assoc) then - null; + procedure Collect_Expression_Ids (Expr : Node_Id) is + Comp_Expr : Node_Id; + begin + if not Analyzed (Expr) then + Comp_Expr := New_Copy_Tree (Expr); + Set_Parent (Comp_Expr, Parent (N)); + Preanalyze_Without_Errors (Comp_Expr); else - if not Analyzed (Expression (Assoc)) then - Comp_Expr := - New_Copy_Tree (Expression (Assoc)); - Set_Parent (Comp_Expr, Parent (N)); - Preanalyze_Without_Errors (Comp_Expr); + Comp_Expr := Expr; + end if; + + Collect_Identifiers (Comp_Expr); + end Collect_Expression_Ids; + + -------------------------------- + -- Handle_Association_Choices -- + -------------------------------- + + procedure Handle_Association_Choices + (Choices : List_Id; Expr : Node_Id) + is + Choice : Node_Id := First (Choices); + + begin + while Present (Choice) loop + + -- For now skip discriminants since it requires + -- performing analysis in two phases: first one + -- analyzing discriminants and second analyzing + -- the rest of components since discriminants + -- are evaluated prior to components: too much + -- extra work to detect a corner case??? + + if Nkind (Choice) in N_Has_Entity + and then Present (Entity (Choice)) + and then + Ekind (Entity (Choice)) = E_Discriminant + then + null; + else - Comp_Expr := Expression (Assoc); + Collect_Expression_Ids (Expr); end if; - Collect_Identifiers (Comp_Expr); - end if; + Next (Choice); + end loop; + end Handle_Association_Choices; - Next (Choice); - end loop; - end if; + begin + if not Box_Present (Assoc) then + if Nkind (Assoc) = N_Component_Association then + Handle_Association_Choices + (Choices (Assoc), Expression (Assoc)); + + elsif + Nkind (Assoc) = N_Iterated_Component_Association + and then Present (Defining_Identifier (Assoc)) + then + Handle_Association_Choices + (Discrete_Choices (Assoc), Expression (Assoc)); + + -- Nkind (Assoc) = N_Iterated_Component_Association + -- with iterator_specification, or + -- Nkind (Assoc) = N_Iterated_Element_Association + -- with loop_parameter_specification + -- or iterator_specification + -- + -- It seems that we might also need to deal with + -- iterable/iterator_names and iterator_filters + -- within iterator_specifications, and range bounds + -- within loop_parameter_specifications, but the + -- utility of doing that seems very low. ??? + + else + Collect_Expression_Ids (Expression (Assoc)); + end if; + end if; + end Handle_Association; Next (Assoc); end loop; @@ -8063,12 +8120,20 @@ package body Sem_Util is loop Ren := Renamed_Object (Id); + -- The reference renames a function result. Check the original + -- node in case expansion relocates the function call. + + -- Ren : ... renames Func_Call; + + if Nkind (Original_Node (Ren)) = N_Function_Call then + exit; + -- The reference renames an abstract state or a whole object -- Obj : ...; -- Ren : ... renames Obj; - if Is_Entity_Name (Ren) then + elsif Is_Entity_Name (Ren) then -- Do not follow a renaming that goes through a generic formal, -- because these entities are hidden and must not be referenced @@ -8081,14 +8146,6 @@ package body Sem_Util is Id := Entity (Ren); end if; - -- The reference renames a function result. Check the original - -- node in case expansion relocates the function call. - - -- Ren : ... renames Func_Call; - - elsif Nkind (Original_Node (Ren)) = N_Function_Call then - exit; - -- Otherwise the reference renames something which does not yield -- an abstract state or a whole object. Treat the reference as not -- having a proper entity for SPARK legality purposes. @@ -12368,9 +12425,14 @@ package body Sem_Util is while Present (Node) loop case Nkind (Node) is - when N_Null_Statement | N_Call_Marker | N_Raise_xxx_Error => + when N_Null_Statement | N_Call_Marker => null; + when N_Raise_xxx_Error => + if Comes_From_Source (Node) then + return False; + end if; + when N_Object_Declaration => if Present (Expression (Node)) and then not Side_Effect_Free (Expression (Node)) @@ -17815,6 +17877,27 @@ package body Sem_Util is return Nkind (Spec_Decl) in N_Generic_Declaration; end Is_Generic_Declaration_Or_Body; + -------------------------- + -- Is_In_Context_Clause -- + -------------------------- + + function Is_In_Context_Clause (N : Node_Id) return Boolean is + Plist : List_Id; + Parent_Node : Node_Id; + + begin + if Is_List_Member (N) then + Plist := List_Containing (N); + Parent_Node := Parent (Plist); + + return Present (Parent_Node) + and then Nkind (Parent_Node) = N_Compilation_Unit + and then Context_Items (Parent_Node) = Plist; + end if; + + return False; + end Is_In_Context_Clause; + --------------------------- -- Is_Independent_Object -- --------------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index fd749c4..167b096 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -2095,6 +2095,10 @@ package Sem_Util is -- Determine whether arbitrary declaration Decl denotes a generic package, -- a generic subprogram or a generic body. + function Is_In_Context_Clause (N : Node_Id) return Boolean; + -- Returns True if N appears within the context clause of a unit, and False + -- for any other placement. + function Is_Independent_Object (N : Node_Id) return Boolean; -- Determine whether arbitrary node N denotes a reference to an independent -- object as per RM C.6(8). diff --git a/gcc/ada/sem_warn.adb b/gcc/ada/sem_warn.adb index 35ef616..1bc97a8 100644 --- a/gcc/ada/sem_warn.adb +++ b/gcc/ada/sem_warn.adb @@ -4670,9 +4670,11 @@ package body Sem_Warn is if Nkind (Parent (LA)) in N_Procedure_Call_Statement | N_Parameter_Association then - Error_Msg_NE - ("?m?& modified by call, but value overwritten #!", - LA, Ent); + if Warn_On_All_Unread_Out_Parameters then + Error_Msg_NE + ("?m?& modified by call, but value overwritten #!", + LA, Ent); + end if; else Error_Msg_NE -- CODEFIX ("?m?useless assignment to&, value overwritten #!", diff --git a/gcc/ada/switch-c.adb b/gcc/ada/switch-c.adb index 6344a0b..1e54340 100644 --- a/gcc/ada/switch-c.adb +++ b/gcc/ada/switch-c.adb @@ -335,6 +335,7 @@ package body Switch.C is end if; Ptr := Ptr + 1; + Check_Semantics_Only_Mode := True; Operating_Mode := Check_Semantics; -- -gnatC (Generate CodePeer information) diff --git a/gcc/auto-profile.cc b/gcc/auto-profile.cc index 91cc8db..8940d1f2 100644 --- a/gcc/auto-profile.cc +++ b/gcc/auto-profile.cc @@ -35,6 +35,8 @@ along with GCC; see the file COPYING3. If not see #include "diagnostic-core.h" #include "profile.h" #include "langhooks.h" +#include "context.h" +#include "pass_manager.h" #include "cfgloop.h" #include "tree-cfg.h" #include "tree-cfgcleanup.h" @@ -858,6 +860,9 @@ autofdo_source_profile::read () /* Read in the function/callsite profile, and store it in local data structure. */ unsigned function_num = gcov_read_unsigned (); + int profile_pass_num + = g->get_passes ()->get_pass_auto_profile ()->static_pass_number; + g->get_dumps ()->dump_start (profile_pass_num, NULL); for (unsigned i = 0; i < function_num; i++) { function_instance::function_instance_stack stack; @@ -870,8 +875,21 @@ autofdo_source_profile::read () if (map_.count (fun_id) == 0) map_[fun_id] = s; else - map_[fun_id]->merge (s); + { + /* Since this is invoked very early, before the pass + manager, we need to set up the dumping explicitly. This is + similar to the handling in finish_optimization_passes. */ + if (dump_enabled_p ()) + { + dump_user_location_t loc + = dump_user_location_t::from_location_t (input_location); + dump_printf_loc (MSG_NOTE, loc, "Merging profile for %s\n", + afdo_string_table->get_name (s->name ())); + } + map_[fun_id]->merge (s); + } } + g->get_dumps ()->dump_finish (profile_pass_num); return true; } @@ -1102,7 +1120,8 @@ update_count_by_afdo_count (profile_count *count, gcov_type c) /* In case we have guessed profile which is already zero, preserve quality info. */ else if (count->nonzero_p () - || count->quality () == GUESSED) + || count->quality () == GUESSED + || count->quality () == GUESSED_LOCAL) *count = profile_count::zero ().afdo (); } @@ -1497,8 +1516,21 @@ afdo_calculate_branch_prob (bb_set *annotated_bb) if (num_unknown_succ == 0 && total_count.nonzero_p ()) { FOR_EACH_EDGE (e, ei, bb->succs) - e->probability - = AFDO_EINFO (e)->get_count ().probability_in (total_count); + { + /* If probability is 1, preserve reliable static prediction + (This is, for example the case of single fallthru edge + or single fallthru plus unlikely EH edge.) */ + if (AFDO_EINFO (e)->get_count () == total_count + && e->probability == profile_probability::always ()) + ; + else if (AFDO_EINFO (e)->get_count ().nonzero_p ()) + e->probability + = AFDO_EINFO (e)->get_count ().probability_in (total_count); + /* If probability is zero, preserve reliable static prediction. */ + else if (e->probability.nonzero_p () + || e->probability.quality () == GUESSED) + e->probability = profile_probability::never ().afdo (); + } } } FOR_ALL_BB_FN (bb, cfun) diff --git a/gcc/c-family/ChangeLog b/gcc/c-family/ChangeLog index f543372..cd96e82 100644 --- a/gcc/c-family/ChangeLog +++ b/gcc/c-family/ChangeLog @@ -1,3 +1,8 @@ +2025-06-03 Martin Uecker <uecker@tugraz.at> + + PR c/120078 + * c.opt (Wjump-misses-init): Fix typo. + 2025-05-30 Julian Brown <julian@codesourcery.com> Tobias Burnus <tburnus@baylibre.com> diff --git a/gcc/c-family/c.opt b/gcc/c-family/c.opt index 75b6531..50ba856 100644 --- a/gcc/c-family/c.opt +++ b/gcc/c-family/c.opt @@ -938,7 +938,7 @@ C ObjC C++ ObjC++ CPP(cpp_warn_invalid_utf8) CppReason(CPP_W_INVALID_UTF8) Var(w Warn about invalid UTF-8 characters. Wjump-misses-init -C ObjC Var(warn_jump_misses_init) Warning LangEnabledby(C ObjC,Wc++-compat) +C ObjC Var(warn_jump_misses_init) Warning LangEnabledBy(C ObjC,Wc++-compat) Warn when a jump misses a variable initialization. Enum diff --git a/gcc/c/ChangeLog b/gcc/c/ChangeLog index 92abbf2..7f5b0b8 100644 --- a/gcc/c/ChangeLog +++ b/gcc/c/ChangeLog @@ -1,3 +1,19 @@ +2025-06-03 Martin Uecker <uecker@tugraz.at> + + * c-typeck.cc (composite_type_internal,composite_type): Move + checking assertions. + +2025-06-03 Martin Uecker <uecker@tugraz.at> + + PR c/116892 + * c-decl.cc (finish_enum): Propagate TYPE_PACKED. + +2025-06-02 Sandra Loosemore <sloosemore@baylibre.com> + + * c-parser.cc (c_parser_omp_context_selector): Call + convert_lvalue_to_rvalue and c_objc_common_truthvalue_conversion + on the expression for OMP_TRAIT_PROPERTY_BOOL_EXPR. + 2025-06-01 Martin Uecker <uecker@tugraz.at> PR c/120380 diff --git a/gcc/c/c-decl.cc b/gcc/c/c-decl.cc index 1008bca..2b0bd66 100644 --- a/gcc/c/c-decl.cc +++ b/gcc/c/c-decl.cc @@ -10293,6 +10293,7 @@ finish_enum (tree enumtype, tree values, tree attributes) TYPE_UNSIGNED (tem) = TYPE_UNSIGNED (enumtype); TYPE_LANG_SPECIFIC (tem) = TYPE_LANG_SPECIFIC (enumtype); ENUM_UNDERLYING_TYPE (tem) = ENUM_UNDERLYING_TYPE (enumtype); + TYPE_PACKED (tem) = TYPE_PACKED (enumtype); } /* Finish debugging output for this type. */ diff --git a/gcc/c/c-typeck.cc b/gcc/c/c-typeck.cc index 2f243ca..b59b5c8a 100644 --- a/gcc/c/c-typeck.cc +++ b/gcc/c/c-typeck.cc @@ -846,12 +846,7 @@ composite_type_internal (tree t1, tree t2, struct composite_cache* cache) n = finish_struct (input_location, n, fields, attributes, NULL, &expr); - n = qualify_type (n, t1); - - gcc_checking_assert (!TYPE_NAME (n) || comptypes (n, t1)); - gcc_checking_assert (!TYPE_NAME (n) || comptypes (n, t2)); - - return n; + return qualify_type (n, t1); } /* FALLTHRU */ case ENUMERAL_TYPE: @@ -1004,7 +999,15 @@ tree composite_type (tree t1, tree t2) { struct composite_cache cache = { }; - return composite_type_internal (t1, t2, &cache); + tree n = composite_type_internal (t1, t2, &cache); + /* For function and arrays there are some cases where qualifiers do + not match. See PR120510. */ + if (FUNCTION_TYPE != TREE_CODE (n) && ARRAY_TYPE != TREE_CODE (n)) + { + gcc_checking_assert (comptypes (n, t1)); + gcc_checking_assert (comptypes (n, t2)); + } + return n; } /* Return the type of a conditional expression between pointers to diff --git a/gcc/calls.cc b/gcc/calls.cc index 164f3c5..e16190c 100644 --- a/gcc/calls.cc +++ b/gcc/calls.cc @@ -3736,19 +3736,16 @@ expand_call (tree exp, rtx target, int ignore) next_arg_reg, valreg, old_inhibit_defer_pop, call_fusage, flags, args_so_far); - if (flag_ipa_ra) + rtx_call_insn *last; + rtx datum = NULL_RTX; + if (fndecl != NULL_TREE) { - rtx_call_insn *last; - rtx datum = NULL_RTX; - if (fndecl != NULL_TREE) - { - datum = XEXP (DECL_RTL (fndecl), 0); - gcc_assert (datum != NULL_RTX - && GET_CODE (datum) == SYMBOL_REF); - } - last = last_call_insn (); - add_reg_note (last, REG_CALL_DECL, datum); + datum = XEXP (DECL_RTL (fndecl), 0); + gcc_assert (datum != NULL_RTX + && GET_CODE (datum) == SYMBOL_REF); } + last = last_call_insn (); + add_reg_note (last, REG_CALL_DECL, datum); /* If the call setup or the call itself overlaps with anything of the argument setup we probably clobbered our call address. @@ -4804,13 +4801,10 @@ emit_library_call_value_1 (int retval, rtx orgfun, rtx value, struct_value_size, call_cookie, valreg, old_inhibit_defer_pop + 1, call_fusage, flags, args_so_far); - if (flag_ipa_ra) - { - rtx datum = orgfun; - gcc_assert (GET_CODE (datum) == SYMBOL_REF); - rtx_call_insn *last = last_call_insn (); - add_reg_note (last, REG_CALL_DECL, datum); - } + rtx datum = orgfun; + gcc_assert (GET_CODE (datum) == SYMBOL_REF); + rtx_call_insn *last = last_call_insn (); + add_reg_note (last, REG_CALL_DECL, datum); /* Right-shift returned value if necessary. */ if (!pcc_struct_value diff --git a/gcc/cobol/ChangeLog b/gcc/cobol/ChangeLog index bfa49bd..03243e9 100644 --- a/gcc/cobol/ChangeLog +++ b/gcc/cobol/ChangeLog @@ -1,3 +1,10 @@ +2025-06-02 Robert Dubner <rdubner@symas.com> + + PR cobol/119975 + * genapi.cc (parser_intrinsic_call_0): Use get_time_64() function. + * genutil.cc (get_time_64): Definition created. + * genutil.h (get_time_64): Declaration created. + 2025-06-01 Robert Dubner <rdubner@symas.com> PR cobol/119524 diff --git a/gcc/cobol/genapi.cc b/gcc/cobol/genapi.cc index 5e983ab..bde8151 100644 --- a/gcc/cobol/genapi.cc +++ b/gcc/cobol/genapi.cc @@ -10491,7 +10491,7 @@ parser_intrinsic_call_0(cbl_field_t *tgt, { // Pass __gg__when_compiled() the time from right now. struct timespec tp; - uint64_t now = get_time_64(); + uint64_t now = get_time_nanoseconds(); tp.tv_sec = now / 1000000000; tp.tv_nsec = now % 1000000000; diff --git a/gcc/cobol/genutil.cc b/gcc/cobol/genutil.cc index e971043..f1098f0 100644 --- a/gcc/cobol/genutil.cc +++ b/gcc/cobol/genutil.cc @@ -2121,7 +2121,7 @@ qualified_data_location(cbl_refer_t &refer) } uint64_t -get_time_64() +get_time_nanoseconds() { // This code was unabashedly stolen from gcc/timevar.cc. // It returns the Unix epoch with nine decimal places. diff --git a/gcc/cobol/genutil.h b/gcc/cobol/genutil.h index 43102d7..fb582e5 100644 --- a/gcc/cobol/genutil.h +++ b/gcc/cobol/genutil.h @@ -155,7 +155,7 @@ void build_array_of_fourplets( int ngroup, size_t N, cbl_refer_t *refers); void get_depending_on_value_from_odo(tree retval, cbl_field_t *odo); -uint64_t get_time_64(); +uint64_t get_time_nanoseconds(); #endif diff --git a/gcc/cobol/util.cc b/gcc/cobol/util.cc index 75a0b26..e92f069 100644 --- a/gcc/cobol/util.cc +++ b/gcc/cobol/util.cc @@ -65,6 +65,7 @@ #include "inspect.h" #include "../../libgcobol/io.h" #include "genapi.h" +#include "genutil.h" #pragma GCC diagnostic ignored "-Wunused-result" #pragma GCC diagnostic ignored "-Wmissing-field-initializers" @@ -2141,22 +2142,25 @@ cobol_fileline_set( const char line[] ) { return file.name; } +//#define TIMING_PARSE +#ifdef TIMING_PARSE class cbl_timespec { - struct timespec now; + uint64_t now; // Nanoseconds public: cbl_timespec() { - clock_gettime(CLOCK_MONOTONIC, &now); + now = get_time_nanoseconds(); } double ns() const { - return now.tv_sec * 1000000000 + now.tv_nsec; + return now; } friend double operator-( const cbl_timespec& now, const cbl_timespec& then ); }; double -operator-( const cbl_timespec& then, const cbl_timespec& now ) { +operator-( const cbl_timespec& now, const cbl_timespec& then ) { return (now.ns() - then.ns()) / 1000000000; } +#endif static int parse_file( const char filename[] ) @@ -2172,15 +2176,20 @@ parse_file( const char filename[] ) return 0; } +#ifdef TIMING_PARSE cbl_timespec start; +#endif int erc = yyparse(); +#ifdef TIMING_PARSE cbl_timespec finish; double dt = finish - start; + printf("Overall parse & generate time is %.6f seconds\n", dt); +#endif + parser_leave_file(); - //printf("Overall parse & generate time is %.6f seconds\n", dt); fclose (yyin); diff --git a/gcc/common/config/riscv/riscv-common.cc b/gcc/common/config/riscv/riscv-common.cc index a6d8763..6b54403 100644 --- a/gcc/common/config/riscv/riscv-common.cc +++ b/gcc/common/config/riscv/riscv-common.cc @@ -1129,8 +1129,10 @@ riscv_subset_list::check_implied_ext () void riscv_subset_list::handle_combine_ext () { - for (const auto &[ext_name, ext_info] : riscv_ext_infos) + for (const auto &pair : riscv_ext_infos) { + const std::string &ext_name = pair.first; + auto &ext_info = pair.second; bool is_combined = true; /* Skip if this extension don't need to combine. */ if (!ext_info.need_combine_p ()) @@ -1558,20 +1560,27 @@ riscv_set_arch_by_subset_list (riscv_subset_list *subset_list, if (opts) { /* Clean up target flags before we set. */ - for (const auto &[ext_name, ext_info] : riscv_ext_infos) - ext_info.clean_opts (opts); + for (const auto &pair : riscv_ext_infos) + { + auto &ext_info = pair.second; + ext_info.clean_opts (opts); + } if (subset_list->xlen () == 32) opts->x_riscv_isa_flags &= ~MASK_64BIT; else if (subset_list->xlen () == 64) opts->x_riscv_isa_flags |= MASK_64BIT; - for (const auto &[ext_name, ext_info] : riscv_ext_infos) - if (subset_list->lookup (ext_name.c_str ())) - { - /* Set the extension flag. */ - ext_info.set_opts (opts); - } + for (const auto &pair : riscv_ext_infos) + { + const std::string &ext_name = pair.first; + auto &ext_info = pair.second; + if (subset_list->lookup (ext_name.c_str ())) + { + /* Set the extension flag. */ + ext_info.set_opts (opts); + } + } } } diff --git a/gcc/config.gcc b/gcc/config.gcc index 1e386a4..8365b91 100644 --- a/gcc/config.gcc +++ b/gcc/config.gcc @@ -4611,15 +4611,13 @@ case "${target}" in for which in arch tune; do eval "val=\$with_$which" - case ${val} in - "" | gfx900 | gfx906 | gfx908 | gfx90a | gfx90c | gfx1030 | gfx1036 | gfx1100 | gfx1103) - # OK - ;; - *) + if test x"$val" != x \ + && ! grep -q "GCN_DEVICE($val," \ + "${srcdir}/config/gcn/gcn-devices.def"; + then echo "Unknown cpu used in --with-$which=$val." 1>&2 exit 1 - ;; - esac + fi done [ "x$with_arch" = x ] && with_arch=gfx900 diff --git a/gcc/config/aarch64/aarch64-sve-builtins.cc b/gcc/config/aarch64/aarch64-sve-builtins.cc index 3651926..2b627a9 100644 --- a/gcc/config/aarch64/aarch64-sve-builtins.cc +++ b/gcc/config/aarch64/aarch64-sve-builtins.cc @@ -47,6 +47,8 @@ #include "langhooks.h" #include "stringpool.h" #include "attribs.h" +#include "value-range.h" +#include "tree-ssanames.h" #include "aarch64-sve-builtins.h" #include "aarch64-sve-builtins-base.h" #include "aarch64-sve-builtins-sve2.h" @@ -3664,7 +3666,8 @@ gimple_folder::fold_pfalse () /* Convert the lhs and all non-boolean vector-type operands to TYPE. Pass the converted variables to the callback FP, and finally convert the result back to the original type. Add the necessary conversion statements. - Return the new call. */ + Return the new call. Note the tree argument to the callback FP, can only + be set once; it will always be a SSA_NAME. */ gimple * gimple_folder::convert_and_fold (tree type, gimple *(*fp) (gimple_folder &, @@ -3675,7 +3678,7 @@ gimple_folder::convert_and_fold (tree type, tree old_ty = TREE_TYPE (lhs); gimple_seq stmts = NULL; bool convert_lhs_p = !useless_type_conversion_p (type, old_ty); - tree lhs_conv = convert_lhs_p ? create_tmp_var (type) : lhs; + tree lhs_conv = convert_lhs_p ? make_ssa_name (type) : lhs; unsigned int num_args = gimple_call_num_args (call); auto_vec<tree, 16> args_conv; args_conv.safe_grow (num_args); diff --git a/gcc/config/i386/i386.md b/gcc/config/i386/i386.md index b7a18d5..40b43cf 100644 --- a/gcc/config/i386/i386.md +++ b/gcc/config/i386/i386.md @@ -8719,6 +8719,34 @@ (set (match_dup 1) (minus:SWI (match_dup 1) (match_dup 0)))])]) +;; Under APX NDD, 'sub reg, mem, reg' is valid. +;; New format for +;; mov reg0, mem1 +;; sub reg0, mem2, reg0 +;; mov mem2, reg0 +;; to +;; mov reg0, mem1 +;; sub mem2, reg0 +(define_peephole2 + [(set (match_operand:SWI 0 "general_reg_operand") + (match_operand:SWI 1 "memory_operand")) + (parallel [(set (reg:CC FLAGS_REG) + (compare:CC (match_operand:SWI 2 "memory_operand") + (match_dup 0))) + (set (match_dup 0) + (minus:SWI (match_dup 2) (match_dup 0)))]) + (set (match_dup 2) (match_dup 0))] + "TARGET_APX_NDD + && (TARGET_READ_MODIFY_WRITE || optimize_insn_for_size_p ()) + && peep2_reg_dead_p (3, operands[0]) + && !reg_overlap_mentioned_p (operands[0], operands[1]) + && !reg_overlap_mentioned_p (operands[0], operands[2])" + [(set (match_dup 0) (match_dup 1)) + (parallel [(set (reg:CC FLAGS_REG) + (compare:CC (match_dup 2) (match_dup 0))) + (set (match_dup 2) + (minus:SWI (match_dup 2) (match_dup 0)))])]) + ;; decl %eax; cmpl $-1, %eax; jne .Lxx; can be optimized into ;; subl $1, %eax; jnc .Lxx; (define_peephole2 @@ -9166,6 +9194,118 @@ (match_dup 1)) (match_dup 0)))])]) +;; Under APX NDD, 'adc reg, mem, reg' is valid. +;; +;; New format for +;; mov reg0, mem1 +;; adc reg0, mem2, reg0 +;; mov mem1, reg0 +;; to +;; mov reg0, mem2 +;; adc mem1, reg0 +(define_peephole2 + [(set (match_operand:SWI48 0 "general_reg_operand") + (match_operand:SWI48 1 "memory_operand")) + (parallel [(set (reg:CCC FLAGS_REG) + (compare:CCC + (zero_extend:<DWI> + (plus:SWI48 + (plus:SWI48 + (match_operator:SWI48 5 "ix86_carry_flag_operator" + [(match_operand 3 "flags_reg_operand") + (const_int 0)]) + (match_operand:SWI48 2 "memory_operand")) + (match_dup 0))) + (plus:<DWI> + (match_operator:<DWI> 4 "ix86_carry_flag_operator" + [(match_dup 3) (const_int 0)]) + (zero_extend:<DWI> (match_dup 0))))) + (set (match_dup 0) + (plus:SWI48 (plus:SWI48 (match_op_dup 5 + [(match_dup 3) (const_int 0)]) + (match_dup 2)) + (match_dup 0)))]) + (set (match_dup 1) (match_dup 0))] + "TARGET_APX_NDD + && (TARGET_READ_MODIFY_WRITE || optimize_insn_for_size_p ()) + && peep2_reg_dead_p (3, operands[0]) + && !reg_overlap_mentioned_p (operands[0], operands[1]) + && !reg_overlap_mentioned_p (operands[0], operands[2])" + [(set (match_dup 0) (match_dup 2)) + (parallel [(set (reg:CCC FLAGS_REG) + (compare:CCC + (zero_extend:<DWI> + (plus:SWI48 + (plus:SWI48 + (match_op_dup 5 + [(match_dup 3) (const_int 0)]) + (match_dup 1)) + (match_dup 0))) + (plus:<DWI> + (match_op_dup 4 + [(match_dup 3) (const_int 0)]) + (zero_extend:<DWI> (match_dup 0))))) + (set (match_dup 1) + (plus:SWI48 (plus:SWI48 (match_op_dup 5 + [(match_dup 3) (const_int 0)]) + (match_dup 1)) + (match_dup 0)))])]) + +;; New format for +;; mov reg0, mem1 +;; adc reg0, mem2, reg0 +;; mov mem2, reg0 +;; to +;; mov reg0, mem1 +;; adc mem2, reg0 +(define_peephole2 + [(set (match_operand:SWI48 0 "general_reg_operand") + (match_operand:SWI48 1 "memory_operand")) + (parallel [(set (reg:CCC FLAGS_REG) + (compare:CCC + (zero_extend:<DWI> + (plus:SWI48 + (plus:SWI48 + (match_operator:SWI48 5 "ix86_carry_flag_operator" + [(match_operand 3 "flags_reg_operand") + (const_int 0)]) + (match_operand:SWI48 2 "memory_operand")) + (match_dup 0))) + (plus:<DWI> + (match_operator:<DWI> 4 "ix86_carry_flag_operator" + [(match_dup 3) (const_int 0)]) + (zero_extend:<DWI> (match_dup 0))))) + (set (match_dup 0) + (plus:SWI48 (plus:SWI48 (match_op_dup 5 + [(match_dup 3) (const_int 0)]) + (match_dup 2)) + (match_dup 0)))]) + (set (match_dup 2) (match_dup 0))] + "TARGET_APX_NDD + && (TARGET_READ_MODIFY_WRITE || optimize_insn_for_size_p ()) + && peep2_reg_dead_p (3, operands[0]) + && !reg_overlap_mentioned_p (operands[0], operands[1]) + && !reg_overlap_mentioned_p (operands[0], operands[2])" + [(set (match_dup 0) (match_dup 1)) + (parallel [(set (reg:CCC FLAGS_REG) + (compare:CCC + (zero_extend:<DWI> + (plus:SWI48 + (plus:SWI48 + (match_op_dup 5 + [(match_dup 3) (const_int 0)]) + (match_dup 2)) + (match_dup 0))) + (plus:<DWI> + (match_op_dup 4 + [(match_dup 3) (const_int 0)]) + (zero_extend:<DWI> (match_dup 0))))) + (set (match_dup 2) + (plus:SWI48 (plus:SWI48 (match_op_dup 5 + [(match_dup 3) (const_int 0)]) + (match_dup 2)) + (match_dup 0)))])]) + (define_peephole2 [(parallel [(set (reg:CCC FLAGS_REG) (compare:CCC @@ -9646,6 +9786,52 @@ [(match_dup 3) (const_int 0)])) (match_dup 0)))])]) +;; Under APX NDD, 'sbb reg, mem, reg' is valid. +;; +;; New format for +;; mov reg0, mem1 +;; sbb reg0, mem2, reg0 +;; mov mem2, reg0 +;; to +;; mov reg0, mem1 +;; sbb mem2, reg0 +(define_peephole2 + [(set (match_operand:SWI48 0 "general_reg_operand") + (match_operand:SWI48 1 "memory_operand")) + (parallel [(set (reg:CCC FLAGS_REG) + (compare:CCC + (zero_extend:<DWI> (match_operand:SWI48 2 "memory_operand")) + (plus:<DWI> + (match_operator:<DWI> 4 "ix86_carry_flag_operator" + [(match_operand 3 "flags_reg_operand") (const_int 0)]) + (zero_extend:<DWI> + (match_dup 0))))) + (set (match_dup 0) + (minus:SWI48 + (minus:SWI48 + (match_dup 2) + (match_operator:SWI48 5 "ix86_carry_flag_operator" + [(match_dup 3) (const_int 0)])) + (match_dup 0)))]) + (set (match_dup 2) (match_dup 0))] + "TARGET_APX_NDD + && (TARGET_READ_MODIFY_WRITE || optimize_insn_for_size_p ()) + && peep2_reg_dead_p (3, operands[0]) + && !reg_overlap_mentioned_p (operands[0], operands[1]) + && !reg_overlap_mentioned_p (operands[0], operands[2])" + [(set (match_dup 0) (match_dup 1)) + (parallel [(set (reg:CCC FLAGS_REG) + (compare:CCC + (zero_extend:<DWI> (match_dup 2)) + (plus:<DWI> (match_op_dup 4 + [(match_dup 3) (const_int 0)]) + (zero_extend:<DWI> (match_dup 0))))) + (set (match_dup 2) + (minus:SWI48 (minus:SWI48 (match_dup 2) + (match_op_dup 5 + [(match_dup 3) (const_int 0)])) + (match_dup 0)))])]) + (define_peephole2 [(set (match_operand:SWI48 6 "general_reg_operand") (match_operand:SWI48 7 "memory_operand")) @@ -28212,6 +28398,41 @@ const0_rtx); }) +;; For APX NDD PLUS/MINUS/LOGIC +;; Like cmpelim optimized pattern. +;; Reduce an extra mov instruction like +;; decl (%rdi), %eax +;; mov %eax, (%rdi) +;; to +;; decl (%rdi) +(define_peephole2 + [(parallel [(set (reg FLAGS_REG) + (compare (match_operator:SWI 2 "plusminuslogic_operator" + [(match_operand:SWI 0 "memory_operand") + (match_operand:SWI 1 "<nonmemory_operand>")]) + (const_int 0))) + (set (match_operand:SWI 3 "register_operand") (match_dup 2))]) + (set (match_dup 0) (match_dup 3))] + "TARGET_APX_NDD + && (TARGET_READ_MODIFY_WRITE || optimize_insn_for_size_p ()) + && peep2_reg_dead_p (2, operands[3]) + && !reg_overlap_mentioned_p (operands[3], operands[0]) + && ix86_match_ccmode (peep2_next_insn (0), + (GET_CODE (operands[2]) == PLUS + || GET_CODE (operands[2]) == MINUS) + ? CCGOCmode : CCNOmode)" + [(parallel [(set (match_dup 4) (match_dup 6)) + (set (match_dup 0) (match_dup 5))])] +{ + operands[4] = SET_DEST (XVECEXP (PATTERN (peep2_next_insn (0)), 0, 0)); + operands[5] + = gen_rtx_fmt_ee (GET_CODE (operands[2]), GET_MODE (operands[2]), + copy_rtx (operands[0]), operands[1]); + operands[6] + = gen_rtx_COMPARE (GET_MODE (operands[4]), copy_rtx (operands[5]), + const0_rtx); +}) + ;; Likewise for instances where we have a lea pattern. (define_peephole2 [(set (match_operand:SWI 0 "register_operand") @@ -28305,6 +28526,54 @@ const0_rtx); }) +;; For APX NDD XOR +;; Reduce 2 mov and 1 cmp instruction. +;; from +;; movq (%rdi), %rax +;; xorq %rsi, %rax, %rdx +;; movb %rdx, (%rdi) +;; cmpb %rsi, %rax +;; jne +;; to +;; xorb %rsi, (%rdi) +;; jne +(define_peephole2 + [(set (match_operand:SWI 0 "register_operand") + (match_operand:SWI 1 "memory_operand")) + (parallel [(set (match_operand:SWI 4 "register_operand") + (xor:SWI (match_operand:SWI 3 "register_operand") + (match_operand:SWI 2 "<nonmemory_operand>"))) + (clobber (reg:CC FLAGS_REG))]) + (set (match_dup 1) (match_dup 4)) + (set (reg:CCZ FLAGS_REG) + (compare:CCZ (match_operand:SWI 5 "register_operand") + (match_operand:SWI 6 "<nonmemory_operand>")))] + "TARGET_APX_NDD + && (TARGET_READ_MODIFY_WRITE || optimize_insn_for_size_p ()) + && REGNO (operands[3]) == REGNO (operands[0]) + && (rtx_equal_p (operands[0], operands[5]) + ? rtx_equal_p (operands[2], operands[6]) + : rtx_equal_p (operands[2], operands[5]) + && rtx_equal_p (operands[0], operands[6])) + && peep2_reg_dead_p (3, operands[4]) + && peep2_reg_dead_p (4, operands[0]) + && !reg_overlap_mentioned_p (operands[0], operands[1]) + && !reg_overlap_mentioned_p (operands[0], operands[2]) + && (<MODE>mode != QImode + || immediate_operand (operands[2], QImode) + || any_QIreg_operand (operands[2], QImode))" + [(parallel [(set (match_dup 7) (match_dup 9)) + (set (match_dup 1) (match_dup 8))])] +{ + operands[7] = SET_DEST (PATTERN (peep2_next_insn (3))); + operands[8] = gen_rtx_XOR (<MODE>mode, copy_rtx (operands[1]), + operands[2]); + operands[9] + = gen_rtx_COMPARE (GET_MODE (operands[7]), + copy_rtx (operands[8]), + const0_rtx); +}) + (define_peephole2 [(set (match_operand:SWI12 0 "register_operand") (match_operand:SWI12 1 "memory_operand")) @@ -28548,6 +28817,58 @@ const0_rtx); }) +;; For APX NDD XOR +;; Reduce 2 mov and 1 cmp instruction. +;; from +;; movb (%rdi), %al +;; xorl %esi, %eax, %edx +;; movb %dl, (%rdi) +;; cmpb %sil, %al +;; jne +;; to +;; xorl %sil, (%rdi) +;; jne +(define_peephole2 + [(set (match_operand:SWI12 0 "register_operand") + (match_operand:SWI12 1 "memory_operand")) + (parallel [(set (match_operand:SI 4 "register_operand") + (xor:SI (match_operand:SI 3 "register_operand") + (match_operand:SI 2 "<nonmemory_operand>"))) + (clobber (reg:CC FLAGS_REG))]) + (set (match_dup 1) (match_operand:SWI12 5 "register_operand")) + (set (reg:CCZ FLAGS_REG) + (compare:CCZ (match_operand:SWI12 6 "register_operand") + (match_operand:SWI12 7 "<nonmemory_operand>")))] + "TARGET_APX_NDD + && (TARGET_READ_MODIFY_WRITE || optimize_insn_for_size_p ()) + && REGNO (operands[3]) == REGNO (operands[0]) + && REGNO (operands[5]) == REGNO (operands[4]) + && (rtx_equal_p (operands[0], operands[6]) + ? (REG_P (operands[2]) + ? REG_P (operands[7]) && REGNO (operands[2]) == REGNO (operands[7]) + : rtx_equal_p (operands[2], operands[7])) + : (rtx_equal_p (operands[0], operands[7]) + && REG_P (operands[2]) + && REGNO (operands[2]) == REGNO (operands[6]))) + && peep2_reg_dead_p (3, operands[5]) + && peep2_reg_dead_p (4, operands[0]) + && !reg_overlap_mentioned_p (operands[0], operands[1]) + && !reg_overlap_mentioned_p (operands[0], operands[2]) + && (<MODE>mode != QImode + || immediate_operand (operands[2], SImode) + || any_QIreg_operand (operands[2], SImode))" + [(parallel [(set (match_dup 8) (match_dup 10)) + (set (match_dup 1) (match_dup 9))])] +{ + operands[8] = SET_DEST (PATTERN (peep2_next_insn (3))); + operands[9] = gen_rtx_XOR (<MODE>mode, copy_rtx (operands[1]), + gen_lowpart (<MODE>mode, operands[2])); + operands[10] + = gen_rtx_COMPARE (GET_MODE (operands[8]), + copy_rtx (operands[9]), + const0_rtx); +}) + ;; Attempt to optimize away memory stores of values the memory already ;; has. See PR79593. (define_peephole2 diff --git a/gcc/config/i386/sse.md b/gcc/config/i386/sse.md index aea5e2c..c40b0fd 100644 --- a/gcc/config/i386/sse.md +++ b/gcc/config/i386/sse.md @@ -13418,7 +13418,7 @@ (const_int 6) (const_int 14)])))] "TARGET_AVX512F" "vmovddup\t{%1, %0<mask_operand2>|%0<mask_operand2>, %1}" - [(set_attr "type" "sselog1") + [(set_attr "type" "ssemov") (set_attr "prefix" "evex") (set_attr "mode" "V8DF")]) @@ -13449,7 +13449,7 @@ (const_int 2) (const_int 6)])))] "TARGET_AVX && <mask_avx512vl_condition>" "vmovddup\t{%1, %0<mask_operand2>|%0<mask_operand2>, %1}" - [(set_attr "type" "sselog1") + [(set_attr "type" "ssemov") (set_attr "prefix" "<mask_prefix>") (set_attr "mode" "V4DF")]) @@ -27839,7 +27839,7 @@ %vmovddup\t{%1, %0|%0, %1} movlhps\t%0, %0" [(set_attr "isa" "sse2_noavx,avx,avx512f,sse3,noavx") - (set_attr "type" "sselog1,sselog1,ssemov,sselog1,ssemov") + (set_attr "type" "sselog1,sselog1,ssemov,ssemov,ssemov") (set_attr "prefix" "orig,maybe_evex,evex,maybe_vex,orig") (set (attr "mode") (cond [(and (eq_attr "alternative" "2") diff --git a/gcc/config/nvptx/mkoffload.cc b/gcc/config/nvptx/mkoffload.cc index e7ec0ef..bb3f0fc 100644 --- a/gcc/config/nvptx/mkoffload.cc +++ b/gcc/config/nvptx/mkoffload.cc @@ -260,8 +260,10 @@ process (FILE *in, FILE *out, uint32_t omp_requires) unsigned ix; const char *sm_ver = NULL, *version = NULL; const char *sm_ver2 = NULL, *version2 = NULL; - size_t file_cnt = 0; - size_t *file_idx = XALLOCAVEC (size_t, len); + /* To reduce the number of reallocations for 'file_idx', guess 'file_cnt' + (very roughly...), based on 'len'. */ + const size_t file_cnt_guessed = 13 + len / 27720; + auto_vec<size_t> file_idx (file_cnt_guessed); fprintf (out, "#include <stdint.h>\n\n"); @@ -269,9 +271,10 @@ process (FILE *in, FILE *out, uint32_t omp_requires) terminated by a NUL. */ for (size_t i = 0; i != len;) { + file_idx.safe_push (i); + char c; bool output_fn_ptr = false; - file_idx[file_cnt++] = i; fprintf (out, "static const char ptx_code_%u[] =\n\t\"", obj_count++); while ((c = input[i++])) @@ -349,6 +352,9 @@ process (FILE *in, FILE *out, uint32_t omp_requires) } } + const size_t file_cnt = file_idx.length (); + gcc_checking_assert (file_cnt == obj_count); + /* Create function-pointer array, required for reverse offload function-pointer lookup. */ diff --git a/gcc/config/riscv/autovec-opt.md b/gcc/config/riscv/autovec-opt.md index a972eda..4465eb2 100644 --- a/gcc/config/riscv/autovec-opt.md +++ b/gcc/config/riscv/autovec-opt.md @@ -1682,7 +1682,7 @@ ;; ============================================================================= (define_insn_and_split "*<optab>_vx_<mode>" [(set (match_operand:V_VLSI 0 "register_operand") - (any_int_binop_no_shift_vx:V_VLSI + (any_int_binop_no_shift_vdup_v:V_VLSI (vec_duplicate:V_VLSI (match_operand:<VEL> 1 "register_operand")) (match_operand:V_VLSI 2 "<binop_rhs2_predicate>")))] @@ -1699,7 +1699,7 @@ (define_insn_and_split "*<optab>_vx_<mode>" [(set (match_operand:V_VLSI 0 "register_operand") - (any_int_binop_no_shift_vx:V_VLSI + (any_int_binop_no_shift_v_vdup:V_VLSI (match_operand:V_VLSI 1 "<binop_rhs2_predicate>") (vec_duplicate:V_VLSI (match_operand:<VEL> 2 "register_operand"))))] @@ -1713,3 +1713,55 @@ <MODE>mode); } [(set_attr "type" "vialu")]) + +;; ============================================================================= +;; Combine vec_duplicate + op.vv to op.vf +;; Include +;; - vfmadd.vf +;; - vfmsub.vf +;; ============================================================================= + + +(define_insn_and_split "*<optab>_vf_<mode>" + [(set (match_operand:V_VLSF 0 "register_operand" "=vd") + (plus_minus:V_VLSF + (mult:V_VLSF + (vec_duplicate:V_VLSF + (match_operand:<VEL> 1 "register_operand" " f")) + (match_operand:V_VLSF 2 "register_operand" " 0")) + (match_operand:V_VLSF 3 "register_operand" " vr")))] + "TARGET_VECTOR && can_create_pseudo_p ()" + "#" + "&& 1" + [(const_int 0)] + { + rtx ops[] = {operands[0], operands[1], operands[2], operands[3], + operands[2]}; + riscv_vector::emit_vlmax_insn (code_for_pred_mul_scalar (<CODE>, <MODE>mode), + riscv_vector::TERNARY_OP_FRM_DYN, ops); + DONE; + } + [(set_attr "type" "vfmuladd")] +) + +(define_insn_and_split "*<optab>_vf_<mode>" + [(set (match_operand:V_VLSF 0 "register_operand" "=vd") + (plus_minus:V_VLSF + (match_operand:V_VLSF 3 "register_operand" " vr") + (mult:V_VLSF + (vec_duplicate:V_VLSF + (match_operand:<VEL> 1 "register_operand" " f")) + (match_operand:V_VLSF 2 "register_operand" " 0"))))] + "TARGET_VECTOR && can_create_pseudo_p ()" + "#" + "&& 1" + [(const_int 0)] + { + rtx ops[] = {operands[0], operands[1], operands[2], operands[3], + operands[2]}; + riscv_vector::emit_vlmax_insn (code_for_pred_mul_scalar (<CODE>, <MODE>mode), + riscv_vector::TERNARY_OP_FRM_DYN, ops); + DONE; + } + [(set_attr "type" "vfmuladd")] +) diff --git a/gcc/config/riscv/riscv-ext.def b/gcc/config/riscv/riscv-ext.def index d0adc2b..816acaa 100644 --- a/gcc/config/riscv/riscv-ext.def +++ b/gcc/config/riscv/riscv-ext.def @@ -73,7 +73,7 @@ Format of DEFINE_RISCV_EXT: DEFINE_RISCV_EXT( /* NAME */ e, - /* UPPERCAE_NAME */ RVE, + /* UPPERCASE_NAME */ RVE, /* FULL_NAME */ "Reduced base integer extension", /* DESC */ "", /* URL */ , @@ -86,7 +86,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ i, - /* UPPERCAE_NAME */ RVI, + /* UPPERCASE_NAME */ RVI, /* FULL_NAME */ "Base integer extension", /* DESC */ "", /* URL */ , @@ -101,7 +101,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ m, - /* UPPERCAE_NAME */ MUL, + /* UPPERCASE_NAME */ MUL, /* FULL_NAME */ "Integer multiplication and division extension", /* DESC */ "", /* URL */ , @@ -114,7 +114,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ a, - /* UPPERCAE_NAME */ ATOMIC, + /* UPPERCASE_NAME */ ATOMIC, /* FULL_NAME */ "Atomic extension", /* DESC */ "", /* URL */ , @@ -129,7 +129,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ f, - /* UPPERCAE_NAME */ HARD_FLOAT, + /* UPPERCASE_NAME */ HARD_FLOAT, /* FULL_NAME */ "Single-precision floating-point extension", /* DESC */ "", /* URL */ , @@ -144,7 +144,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ d, - /* UPPERCAE_NAME */ DOUBLE_FLOAT, + /* UPPERCASE_NAME */ DOUBLE_FLOAT, /* FULL_NAME */ "Double-precision floating-point extension", /* DESC */ "", /* URL */ , @@ -159,7 +159,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ c, - /* UPPERCAE_NAME */ RVC, + /* UPPERCASE_NAME */ RVC, /* FULL_NAME */ "Compressed extension", /* DESC */ "", /* URL */ , @@ -183,7 +183,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ b, - /* UPPERCAE_NAME */ RVB, + /* UPPERCASE_NAME */ RVB, /* FULL_NAME */ "b extension", /* DESC */ "", /* URL */ , @@ -196,7 +196,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ v, - /* UPPERCAE_NAME */ RVV, + /* UPPERCASE_NAME */ RVV, /* FULL_NAME */ "Vector extension", /* DESC */ "", /* URL */ , @@ -209,7 +209,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ h, - /* UPPERCAE_NAME */ RVH, + /* UPPERCASE_NAME */ RVH, /* FULL_NAME */ "Hypervisor extension", /* DESC */ "", /* URL */ , @@ -222,7 +222,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zic64b, - /* UPPERCAE_NAME */ ZIC64B, + /* UPPERCASE_NAME */ ZIC64B, /* FULL_NAME */ "Cache block size isf 64 bytes", /* DESC */ "", /* URL */ , @@ -235,7 +235,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zicbom, - /* UPPERCAE_NAME */ ZICBOM, + /* UPPERCASE_NAME */ ZICBOM, /* FULL_NAME */ "Cache-block management extension", /* DESC */ "", /* URL */ , @@ -248,7 +248,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zicbop, - /* UPPERCAE_NAME */ ZICBOP, + /* UPPERCASE_NAME */ ZICBOP, /* FULL_NAME */ "Cache-block prefetch extension", /* DESC */ "", /* URL */ , @@ -261,7 +261,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zicboz, - /* UPPERCAE_NAME */ ZICBOZ, + /* UPPERCASE_NAME */ ZICBOZ, /* FULL_NAME */ "Cache-block zero extension", /* DESC */ "", /* URL */ , @@ -274,7 +274,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ ziccamoa, - /* UPPERCAE_NAME */ ZICCAMOA, + /* UPPERCASE_NAME */ ZICCAMOA, /* FULL_NAME */ "Main memory supports all atomics in A", /* DESC */ "", /* URL */ , @@ -287,7 +287,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ ziccif, - /* UPPERCAE_NAME */ ZICCIF, + /* UPPERCASE_NAME */ ZICCIF, /* FULL_NAME */ "Main memory supports instruction fetch with atomicity requirement", /* DESC */ "", /* URL */ , @@ -300,7 +300,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zicclsm, - /* UPPERCAE_NAME */ ZICCLSM, + /* UPPERCASE_NAME */ ZICCLSM, /* FULL_NAME */ "Main memory supports misaligned loads/stores", /* DESC */ "", /* URL */ , @@ -313,7 +313,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ ziccrse, - /* UPPERCAE_NAME */ ZICCRSE, + /* UPPERCASE_NAME */ ZICCRSE, /* FULL_NAME */ "Main memory supports forward progress on LR/SC sequences", /* DESC */ "", /* URL */ , @@ -326,7 +326,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zicfilp, - /* UPPERCAE_NAME */ ZICFILP, + /* UPPERCASE_NAME */ ZICFILP, /* FULL_NAME */ "zicfilp extension", /* DESC */ "", /* URL */ , @@ -339,7 +339,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zicfiss, - /* UPPERCAE_NAME */ ZICFISS, + /* UPPERCASE_NAME */ ZICFISS, /* FULL_NAME */ "zicfiss extension", /* DESC */ "", /* URL */ , @@ -352,7 +352,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zicntr, - /* UPPERCAE_NAME */ ZICNTR, + /* UPPERCASE_NAME */ ZICNTR, /* FULL_NAME */ "Standard extension for base counters and timers", /* DESC */ "", /* URL */ , @@ -365,7 +365,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zicond, - /* UPPERCAE_NAME */ ZICOND, + /* UPPERCASE_NAME */ ZICOND, /* FULL_NAME */ "Integer conditional operations extension", /* DESC */ "", /* URL */ , @@ -378,7 +378,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zicsr, - /* UPPERCAE_NAME */ ZICSR, + /* UPPERCASE_NAME */ ZICSR, /* FULL_NAME */ "Control and status register access extension", /* DESC */ "", /* URL */ , @@ -391,7 +391,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zifencei, - /* UPPERCAE_NAME */ ZIFENCEI, + /* UPPERCASE_NAME */ ZIFENCEI, /* FULL_NAME */ "Instruction-fetch fence extension", /* DESC */ "", /* URL */ , @@ -404,7 +404,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zihintntl, - /* UPPERCAE_NAME */ ZIHINTNTL, + /* UPPERCASE_NAME */ ZIHINTNTL, /* FULL_NAME */ "Non-temporal locality hints extension", /* DESC */ "", /* URL */ , @@ -417,7 +417,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zihintpause, - /* UPPERCAE_NAME */ ZIHINTPAUSE, + /* UPPERCASE_NAME */ ZIHINTPAUSE, /* FULL_NAME */ "Pause hint extension", /* DESC */ "", /* URL */ , @@ -430,7 +430,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zihpm, - /* UPPERCAE_NAME */ ZIHPM, + /* UPPERCASE_NAME */ ZIHPM, /* FULL_NAME */ "Standard extension for hardware performance counters", /* DESC */ "", /* URL */ , @@ -443,7 +443,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zimop, - /* UPPERCAE_NAME */ ZIMOP, + /* UPPERCASE_NAME */ ZIMOP, /* FULL_NAME */ "zimop extension", /* DESC */ "", /* URL */ , @@ -456,7 +456,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zilsd, - /* UPPERCAE_NAME */ ZILSD, + /* UPPERCASE_NAME */ ZILSD, /* FULL_NAME */ "Load/Store pair instructions extension", /* DESC */ "", /* URL */ , @@ -469,7 +469,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zmmul, - /* UPPERCAE_NAME */ ZMMUL, + /* UPPERCASE_NAME */ ZMMUL, /* FULL_NAME */ "Integer multiplication extension", /* DESC */ "", /* URL */ , @@ -482,7 +482,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ za128rs, - /* UPPERCAE_NAME */ ZA128RS, + /* UPPERCASE_NAME */ ZA128RS, /* FULL_NAME */ "Reservation set size of 128 bytes", /* DESC */ "", /* URL */ , @@ -495,7 +495,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ za64rs, - /* UPPERCAE_NAME */ ZA64RS, + /* UPPERCASE_NAME */ ZA64RS, /* FULL_NAME */ "Reservation set size of 64 bytes", /* DESC */ "", /* URL */ , @@ -508,7 +508,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zaamo, - /* UPPERCAE_NAME */ ZAAMO, + /* UPPERCASE_NAME */ ZAAMO, /* FULL_NAME */ "zaamo extension", /* DESC */ "", /* URL */ , @@ -521,7 +521,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zabha, - /* UPPERCAE_NAME */ ZABHA, + /* UPPERCASE_NAME */ ZABHA, /* FULL_NAME */ "zabha extension", /* DESC */ "", /* URL */ , @@ -534,7 +534,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zacas, - /* UPPERCAE_NAME */ ZACAS, + /* UPPERCASE_NAME */ ZACAS, /* FULL_NAME */ "zacas extension", /* DESC */ "", /* URL */ , @@ -547,7 +547,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zalrsc, - /* UPPERCAE_NAME */ ZALRSC, + /* UPPERCASE_NAME */ ZALRSC, /* FULL_NAME */ "zalrsc extension", /* DESC */ "", /* URL */ , @@ -560,7 +560,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zawrs, - /* UPPERCAE_NAME */ ZAWRS, + /* UPPERCASE_NAME */ ZAWRS, /* FULL_NAME */ "Wait-on-reservation-set extension", /* DESC */ "", /* URL */ , @@ -573,7 +573,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zama16b, - /* UPPERCAE_NAME */ ZAMA16B, + /* UPPERCASE_NAME */ ZAMA16B, /* FULL_NAME */ "Zama16b extension", /* DESC */ "Misaligned loads, stores, and AMOs to main memory regions that do" " not cross a naturally aligned 16-byte boundary are atomic.", @@ -587,7 +587,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zfa, - /* UPPERCAE_NAME */ ZFA, + /* UPPERCASE_NAME */ ZFA, /* FULL_NAME */ "Additional floating-point extension", /* DESC */ "", /* URL */ , @@ -600,7 +600,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zfbfmin, - /* UPPERCAE_NAME */ ZFBFMIN, + /* UPPERCASE_NAME */ ZFBFMIN, /* FULL_NAME */ "zfbfmin extension", /* DESC */ "", /* URL */ , @@ -613,7 +613,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zfh, - /* UPPERCAE_NAME */ ZFH, + /* UPPERCASE_NAME */ ZFH, /* FULL_NAME */ "Half-precision floating-point extension", /* DESC */ "", /* URL */ , @@ -626,7 +626,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zfhmin, - /* UPPERCAE_NAME */ ZFHMIN, + /* UPPERCASE_NAME */ ZFHMIN, /* FULL_NAME */ "Minimal half-precision floating-point extension", /* DESC */ "", /* URL */ , @@ -639,7 +639,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zfinx, - /* UPPERCAE_NAME */ ZFINX, + /* UPPERCASE_NAME */ ZFINX, /* FULL_NAME */ "Single-precision floating-point in integer registers extension", /* DESC */ "", /* URL */ , @@ -652,7 +652,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zdinx, - /* UPPERCAE_NAME */ ZDINX, + /* UPPERCASE_NAME */ ZDINX, /* FULL_NAME */ "Double-precision floating-point in integer registers extension", /* DESC */ "", /* URL */ , @@ -665,7 +665,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zca, - /* UPPERCAE_NAME */ ZCA, + /* UPPERCASE_NAME */ ZCA, /* FULL_NAME */ "Integer compressed instruction extension", /* DESC */ "", /* URL */ , @@ -709,7 +709,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zcb, - /* UPPERCAE_NAME */ ZCB, + /* UPPERCASE_NAME */ ZCB, /* FULL_NAME */ "Simple compressed instruction extension", /* DESC */ "", /* URL */ , @@ -722,7 +722,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zcd, - /* UPPERCAE_NAME */ ZCD, + /* UPPERCASE_NAME */ ZCD, /* FULL_NAME */ "Compressed double-precision floating point loads and stores extension", /* DESC */ "", /* URL */ , @@ -735,7 +735,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zce, - /* UPPERCAE_NAME */ ZCE, + /* UPPERCASE_NAME */ ZCE, /* FULL_NAME */ "Compressed instruction extensions for embedded processors", /* DESC */ "", /* URL */ , @@ -754,7 +754,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zcf, - /* UPPERCAE_NAME */ ZCF, + /* UPPERCASE_NAME */ ZCF, /* FULL_NAME */ "Compressed single-precision floating point loads and stores extension", /* DESC */ "", /* URL */ , @@ -767,7 +767,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zcmop, - /* UPPERCAE_NAME */ ZCMOP, + /* UPPERCASE_NAME */ ZCMOP, /* FULL_NAME */ "zcmop extension", /* DESC */ "", /* URL */ , @@ -780,7 +780,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zcmp, - /* UPPERCAE_NAME */ ZCMP, + /* UPPERCASE_NAME */ ZCMP, /* FULL_NAME */ "Compressed push pop extension", /* DESC */ "", /* URL */ , @@ -793,7 +793,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zcmt, - /* UPPERCAE_NAME */ ZCMT, + /* UPPERCASE_NAME */ ZCMT, /* FULL_NAME */ "Table jump instruction extension", /* DESC */ "", /* URL */ , @@ -806,7 +806,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zclsd, - /* UPPERCAE_NAME */ ZCLSD, + /* UPPERCASE_NAME */ ZCLSD, /* FULL_NAME */ "Compressed load/store pair instructions extension", /* DESC */ "", /* URL */ , @@ -819,7 +819,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zba, - /* UPPERCAE_NAME */ ZBA, + /* UPPERCASE_NAME */ ZBA, /* FULL_NAME */ "Address calculation extension", /* DESC */ "", /* URL */ , @@ -832,7 +832,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zbb, - /* UPPERCAE_NAME */ ZBB, + /* UPPERCASE_NAME */ ZBB, /* FULL_NAME */ "Basic bit manipulation extension", /* DESC */ "", /* URL */ , @@ -845,7 +845,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zbc, - /* UPPERCAE_NAME */ ZBC, + /* UPPERCASE_NAME */ ZBC, /* FULL_NAME */ "Carry-less multiplication extension", /* DESC */ "", /* URL */ , @@ -858,7 +858,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zbkb, - /* UPPERCAE_NAME */ ZBKB, + /* UPPERCASE_NAME */ ZBKB, /* FULL_NAME */ "Cryptography bit-manipulation extension", /* DESC */ "", /* URL */ , @@ -871,7 +871,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zbkc, - /* UPPERCAE_NAME */ ZBKC, + /* UPPERCASE_NAME */ ZBKC, /* FULL_NAME */ "Cryptography carry-less multiply extension", /* DESC */ "", /* URL */ , @@ -884,7 +884,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zbkx, - /* UPPERCAE_NAME */ ZBKX, + /* UPPERCASE_NAME */ ZBKX, /* FULL_NAME */ "Cryptography crossbar permutation extension", /* DESC */ "", /* URL */ , @@ -897,7 +897,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zbs, - /* UPPERCAE_NAME */ ZBS, + /* UPPERCASE_NAME */ ZBS, /* FULL_NAME */ "Single-bit operation extension", /* DESC */ "", /* URL */ , @@ -910,7 +910,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zk, - /* UPPERCAE_NAME */ ZK, + /* UPPERCASE_NAME */ ZK, /* FULL_NAME */ "Standard scalar cryptography extension", /* DESC */ "", /* URL */ , @@ -923,7 +923,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zkn, - /* UPPERCAE_NAME */ ZKN, + /* UPPERCASE_NAME */ ZKN, /* FULL_NAME */ "NIST algorithm suite extension", /* DESC */ "", /* URL */ , @@ -936,7 +936,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zknd, - /* UPPERCAE_NAME */ ZKND, + /* UPPERCASE_NAME */ ZKND, /* FULL_NAME */ "AES Decryption extension", /* DESC */ "", /* URL */ , @@ -949,7 +949,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zkne, - /* UPPERCAE_NAME */ ZKNE, + /* UPPERCASE_NAME */ ZKNE, /* FULL_NAME */ "AES Encryption extension", /* DESC */ "", /* URL */ , @@ -962,7 +962,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zknh, - /* UPPERCAE_NAME */ ZKNH, + /* UPPERCASE_NAME */ ZKNH, /* FULL_NAME */ "Hash function extension", /* DESC */ "", /* URL */ , @@ -975,7 +975,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zkr, - /* UPPERCAE_NAME */ ZKR, + /* UPPERCASE_NAME */ ZKR, /* FULL_NAME */ "Entropy source extension", /* DESC */ "", /* URL */ , @@ -988,7 +988,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zks, - /* UPPERCAE_NAME */ ZKS, + /* UPPERCASE_NAME */ ZKS, /* FULL_NAME */ "ShangMi algorithm suite extension", /* DESC */ "", /* URL */ , @@ -1001,7 +1001,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zksed, - /* UPPERCAE_NAME */ ZKSED, + /* UPPERCASE_NAME */ ZKSED, /* FULL_NAME */ "SM4 block cipher extension", /* DESC */ "", /* URL */ , @@ -1014,7 +1014,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zksh, - /* UPPERCAE_NAME */ ZKSH, + /* UPPERCASE_NAME */ ZKSH, /* FULL_NAME */ "SM3 hash function extension", /* DESC */ "", /* URL */ , @@ -1027,7 +1027,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zkt, - /* UPPERCAE_NAME */ ZKT, + /* UPPERCASE_NAME */ ZKT, /* FULL_NAME */ "Data independent execution latency extension", /* DESC */ "", /* URL */ , @@ -1040,7 +1040,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ ztso, - /* UPPERCAE_NAME */ ZTSO, + /* UPPERCASE_NAME */ ZTSO, /* FULL_NAME */ "Total store ordering extension", /* DESC */ "", /* URL */ , @@ -1053,7 +1053,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zvbb, - /* UPPERCAE_NAME */ ZVBB, + /* UPPERCASE_NAME */ ZVBB, /* FULL_NAME */ "Vector basic bit-manipulation extension", /* DESC */ "", /* URL */ , @@ -1066,7 +1066,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zvbc, - /* UPPERCAE_NAME */ ZVBC, + /* UPPERCASE_NAME */ ZVBC, /* FULL_NAME */ "Vector carryless multiplication extension", /* DESC */ "", /* URL */ , @@ -1079,7 +1079,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zve32f, - /* UPPERCAE_NAME */ ZVE32F, + /* UPPERCASE_NAME */ ZVE32F, /* FULL_NAME */ "Vector extensions for embedded processors", /* DESC */ "", /* URL */ , @@ -1092,7 +1092,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zve32x, - /* UPPERCAE_NAME */ ZVE32X, + /* UPPERCASE_NAME */ ZVE32X, /* FULL_NAME */ "Vector extensions for embedded processors", /* DESC */ "", /* URL */ , @@ -1105,7 +1105,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zve64d, - /* UPPERCAE_NAME */ ZVE64D, + /* UPPERCASE_NAME */ ZVE64D, /* FULL_NAME */ "Vector extensions for embedded processors", /* DESC */ "", /* URL */ , @@ -1118,7 +1118,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zve64f, - /* UPPERCAE_NAME */ ZVE64F, + /* UPPERCASE_NAME */ ZVE64F, /* FULL_NAME */ "Vector extensions for embedded processors", /* DESC */ "", /* URL */ , @@ -1131,7 +1131,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zve64x, - /* UPPERCAE_NAME */ ZVE64X, + /* UPPERCASE_NAME */ ZVE64X, /* FULL_NAME */ "Vector extensions for embedded processors", /* DESC */ "", /* URL */ , @@ -1144,7 +1144,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zvfbfmin, - /* UPPERCAE_NAME */ ZVFBFMIN, + /* UPPERCASE_NAME */ ZVFBFMIN, /* FULL_NAME */ "Vector BF16 converts extension", /* DESC */ "", /* URL */ , @@ -1157,7 +1157,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zvfbfwma, - /* UPPERCAE_NAME */ ZVFBFWMA, + /* UPPERCASE_NAME */ ZVFBFWMA, /* FULL_NAME */ "zvfbfwma extension", /* DESC */ "", /* URL */ , @@ -1170,7 +1170,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zvfh, - /* UPPERCAE_NAME */ ZVFH, + /* UPPERCASE_NAME */ ZVFH, /* FULL_NAME */ "Vector half-precision floating-point extension", /* DESC */ "", /* URL */ , @@ -1183,7 +1183,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zvfhmin, - /* UPPERCAE_NAME */ ZVFHMIN, + /* UPPERCASE_NAME */ ZVFHMIN, /* FULL_NAME */ "Vector minimal half-precision floating-point extension", /* DESC */ "", /* URL */ , @@ -1196,7 +1196,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zvkb, - /* UPPERCAE_NAME */ ZVKB, + /* UPPERCASE_NAME */ ZVKB, /* FULL_NAME */ "Vector cryptography bit-manipulation extension", /* DESC */ "", /* URL */ , @@ -1209,7 +1209,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zvkg, - /* UPPERCAE_NAME */ ZVKG, + /* UPPERCASE_NAME */ ZVKG, /* FULL_NAME */ "Vector GCM/GMAC extension", /* DESC */ "", /* URL */ , @@ -1222,7 +1222,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zvkn, - /* UPPERCAE_NAME */ ZVKN, + /* UPPERCASE_NAME */ ZVKN, /* FULL_NAME */ "Vector NIST Algorithm Suite extension", /* DESC */ "@samp{zvkn} will expand to", /* URL */ , @@ -1235,7 +1235,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zvknc, - /* UPPERCAE_NAME */ ZVKNC, + /* UPPERCASE_NAME */ ZVKNC, /* FULL_NAME */ "Vector NIST Algorithm Suite with carryless multiply extension, @samp{zvknc}", /* DESC */ "", /* URL */ , @@ -1248,7 +1248,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zvkned, - /* UPPERCAE_NAME */ ZVKNED, + /* UPPERCASE_NAME */ ZVKNED, /* FULL_NAME */ "Vector AES block cipher extension", /* DESC */ "", /* URL */ , @@ -1261,7 +1261,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zvkng, - /* UPPERCAE_NAME */ ZVKNG, + /* UPPERCASE_NAME */ ZVKNG, /* FULL_NAME */ "Vector NIST Algorithm Suite with GCM extension, @samp{zvkng} will expand", /* DESC */ "", /* URL */ , @@ -1274,7 +1274,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zvknha, - /* UPPERCAE_NAME */ ZVKNHA, + /* UPPERCASE_NAME */ ZVKNHA, /* FULL_NAME */ "Vector SHA-2 secure hash extension", /* DESC */ "", /* URL */ , @@ -1287,7 +1287,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zvknhb, - /* UPPERCAE_NAME */ ZVKNHB, + /* UPPERCASE_NAME */ ZVKNHB, /* FULL_NAME */ "Vector SHA-2 secure hash extension", /* DESC */ "", /* URL */ , @@ -1300,7 +1300,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zvks, - /* UPPERCAE_NAME */ ZVKS, + /* UPPERCASE_NAME */ ZVKS, /* FULL_NAME */ "Vector ShangMi algorithm suite extension, @samp{zvks} will expand", /* DESC */ "", /* URL */ , @@ -1313,7 +1313,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zvksc, - /* UPPERCAE_NAME */ ZVKSC, + /* UPPERCASE_NAME */ ZVKSC, /* FULL_NAME */ "Vector ShangMi algorithm suite with carryless multiplication extension,", /* DESC */ "", /* URL */ , @@ -1326,7 +1326,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zvksed, - /* UPPERCAE_NAME */ ZVKSED, + /* UPPERCASE_NAME */ ZVKSED, /* FULL_NAME */ "Vector SM4 Block Cipher extension", /* DESC */ "", /* URL */ , @@ -1339,7 +1339,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zvksg, - /* UPPERCAE_NAME */ ZVKSG, + /* UPPERCASE_NAME */ ZVKSG, /* FULL_NAME */ "Vector ShangMi algorithm suite with GCM extension, @samp{zvksg} will expand", /* DESC */ "", /* URL */ , @@ -1352,7 +1352,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zvksh, - /* UPPERCAE_NAME */ ZVKSH, + /* UPPERCASE_NAME */ ZVKSH, /* FULL_NAME */ "Vector SM3 Secure Hash extension", /* DESC */ "", /* URL */ , @@ -1365,7 +1365,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zvkt, - /* UPPERCAE_NAME */ ZVKT, + /* UPPERCASE_NAME */ ZVKT, /* FULL_NAME */ "Vector data independent execution latency extension", /* DESC */ "", /* URL */ , @@ -1378,7 +1378,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zvl1024b, - /* UPPERCAE_NAME */ ZVL1024B, + /* UPPERCASE_NAME */ ZVL1024B, /* FULL_NAME */ "Minimum vector length standard extensions", /* DESC */ "", /* URL */ , @@ -1391,7 +1391,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zvl128b, - /* UPPERCAE_NAME */ ZVL128B, + /* UPPERCASE_NAME */ ZVL128B, /* FULL_NAME */ "Minimum vector length standard extensions", /* DESC */ "", /* URL */ , @@ -1404,7 +1404,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zvl16384b, - /* UPPERCAE_NAME */ ZVL16384B, + /* UPPERCASE_NAME */ ZVL16384B, /* FULL_NAME */ "zvl16384b extension", /* DESC */ "", /* URL */ , @@ -1417,7 +1417,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zvl2048b, - /* UPPERCAE_NAME */ ZVL2048B, + /* UPPERCASE_NAME */ ZVL2048B, /* FULL_NAME */ "Minimum vector length standard extensions", /* DESC */ "", /* URL */ , @@ -1430,7 +1430,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zvl256b, - /* UPPERCAE_NAME */ ZVL256B, + /* UPPERCASE_NAME */ ZVL256B, /* FULL_NAME */ "Minimum vector length standard extensions", /* DESC */ "", /* URL */ , @@ -1443,7 +1443,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zvl32768b, - /* UPPERCAE_NAME */ ZVL32768B, + /* UPPERCASE_NAME */ ZVL32768B, /* FULL_NAME */ "zvl32768b extension", /* DESC */ "", /* URL */ , @@ -1456,7 +1456,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zvl32b, - /* UPPERCAE_NAME */ ZVL32B, + /* UPPERCASE_NAME */ ZVL32B, /* FULL_NAME */ "Minimum vector length standard extensions", /* DESC */ "", /* URL */ , @@ -1469,7 +1469,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zvl4096b, - /* UPPERCAE_NAME */ ZVL4096B, + /* UPPERCASE_NAME */ ZVL4096B, /* FULL_NAME */ "Minimum vector length standard extensions", /* DESC */ "", /* URL */ , @@ -1482,7 +1482,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zvl512b, - /* UPPERCAE_NAME */ ZVL512B, + /* UPPERCASE_NAME */ ZVL512B, /* FULL_NAME */ "Minimum vector length standard extensions", /* DESC */ "", /* URL */ , @@ -1495,7 +1495,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zvl64b, - /* UPPERCAE_NAME */ ZVL64B, + /* UPPERCASE_NAME */ ZVL64B, /* FULL_NAME */ "Minimum vector length standard extensions", /* DESC */ "", /* URL */ , @@ -1508,7 +1508,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zvl65536b, - /* UPPERCAE_NAME */ ZVL65536B, + /* UPPERCASE_NAME */ ZVL65536B, /* FULL_NAME */ "zvl65536b extension", /* DESC */ "", /* URL */ , @@ -1521,7 +1521,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zvl8192b, - /* UPPERCAE_NAME */ ZVL8192B, + /* UPPERCASE_NAME */ ZVL8192B, /* FULL_NAME */ "zvl8192b extension", /* DESC */ "", /* URL */ , @@ -1534,7 +1534,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zhinx, - /* UPPERCAE_NAME */ ZHINX, + /* UPPERCASE_NAME */ ZHINX, /* FULL_NAME */ "Half-precision floating-point in integer registers extension", /* DESC */ "", /* URL */ , @@ -1547,7 +1547,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ zhinxmin, - /* UPPERCAE_NAME */ ZHINXMIN, + /* UPPERCASE_NAME */ ZHINXMIN, /* FULL_NAME */ "Minimal half-precision floating-point in integer registers extension", /* DESC */ "", /* URL */ , @@ -1560,7 +1560,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ sdtrig, - /* UPPERCAE_NAME */ SDTRIG, + /* UPPERCASE_NAME */ SDTRIG, /* FULL_NAME */ "sdtrig extension", /* DESC */ "", /* URL */ , @@ -1573,7 +1573,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ sha, - /* UPPERCAE_NAME */ SHA, + /* UPPERCASE_NAME */ SHA, /* FULL_NAME */ "The augmented hypervisor extension", /* DESC */ "", /* URL */ , @@ -1586,7 +1586,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ shcounterenw, - /* UPPERCAE_NAME */ SHCOUNTERENW, + /* UPPERCASE_NAME */ SHCOUNTERENW, /* FULL_NAME */ "Support writeable enables for any supported counter", /* DESC */ "", /* URL */ , @@ -1599,7 +1599,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ shgatpa, - /* UPPERCAE_NAME */ SHGATPA, + /* UPPERCASE_NAME */ SHGATPA, /* FULL_NAME */ "SvNNx4 mode supported for all modes supported by satp", /* DESC */ "", /* URL */ , @@ -1611,8 +1611,21 @@ DEFINE_RISCV_EXT( /* EXTRA_EXTENSION_FLAGS */ 0) DEFINE_RISCV_EXT( + /* NAME */ shlcofideleg, + /* UPPERCASE_NAME */ SHLCOFIDELEG, + /* FULL_NAME */ "Delegating LCOFI interrupts to VS-mode", + /* DESC */ "", + /* URL */ , + /* DEP_EXTS */ ({"h"}), + /* SUPPORTED_VERSIONS */ ({{1, 0}}), + /* FLAG_GROUP */ sh, + /* BITMASK_GROUP_ID */ BITMASK_NOT_YET_ALLOCATED, + /* BITMASK_BIT_POSITION*/ BITMASK_NOT_YET_ALLOCATED, + /* EXTRA_EXTENSION_FLAGS */ 0) + +DEFINE_RISCV_EXT( /* NAME */ shtvala, - /* UPPERCAE_NAME */ SHTVALA, + /* UPPERCASE_NAME */ SHTVALA, /* FULL_NAME */ "The htval register provides all needed values", /* DESC */ "", /* URL */ , @@ -1625,7 +1638,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ shvstvala, - /* UPPERCAE_NAME */ SHVSTVALA, + /* UPPERCASE_NAME */ SHVSTVALA, /* FULL_NAME */ "The vstval register provides all needed values", /* DESC */ "", /* URL */ , @@ -1638,7 +1651,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ shvstvecd, - /* UPPERCAE_NAME */ SHVSTVECD, + /* UPPERCASE_NAME */ SHVSTVECD, /* FULL_NAME */ "The vstvec register supports Direct mode", /* DESC */ "", /* URL */ , @@ -1651,7 +1664,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ shvsatpa, - /* UPPERCAE_NAME */ SHVSATPA, + /* UPPERCASE_NAME */ SHVSATPA, /* FULL_NAME */ "The vsatp register supports all modes supported by satp", /* DESC */ "", /* URL */ , @@ -1664,7 +1677,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ smaia, - /* UPPERCAE_NAME */ SMAIA, + /* UPPERCASE_NAME */ SMAIA, /* FULL_NAME */ "Advanced interrupt architecture extension", /* DESC */ "", /* URL */ , @@ -1677,7 +1690,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ smcntrpmf, - /* UPPERCAE_NAME */ SMCNTRPMF, + /* UPPERCASE_NAME */ SMCNTRPMF, /* FULL_NAME */ "Cycle and instret privilege mode filtering", /* DESC */ "", /* URL */ , @@ -1689,8 +1702,21 @@ DEFINE_RISCV_EXT( /* EXTRA_EXTENSION_FLAGS */ 0) DEFINE_RISCV_EXT( + /* NAME */ smcsrind, + /* UPPERCASE_NAME */ SMCSRIND, + /* FULL_NAME */ "Machine-Level Indirect CSR Access", + /* DESC */ "", + /* URL */ , + /* DEP_EXTS */ ({"zicsr", "sscsrind"}), + /* SUPPORTED_VERSIONS */ ({{1, 0}}), + /* FLAG_GROUP */ sm, + /* BITMASK_GROUP_ID */ BITMASK_NOT_YET_ALLOCATED, + /* BITMASK_BIT_POSITION*/ BITMASK_NOT_YET_ALLOCATED, + /* EXTRA_EXTENSION_FLAGS */ 0) + +DEFINE_RISCV_EXT( /* NAME */ smepmp, - /* UPPERCAE_NAME */ SMEPMP, + /* UPPERCASE_NAME */ SMEPMP, /* FULL_NAME */ "PMP Enhancements for memory access and execution prevention on Machine mode", /* DESC */ "", /* URL */ , @@ -1703,7 +1729,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ smmpm, - /* UPPERCAE_NAME */ SMMPM, + /* UPPERCASE_NAME */ SMMPM, /* FULL_NAME */ "smmpm extension", /* DESC */ "", /* URL */ , @@ -1716,7 +1742,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ smnpm, - /* UPPERCAE_NAME */ SMNPM, + /* UPPERCASE_NAME */ SMNPM, /* FULL_NAME */ "smnpm extension", /* DESC */ "", /* URL */ , @@ -1728,8 +1754,21 @@ DEFINE_RISCV_EXT( /* EXTRA_EXTENSION_FLAGS */ 0) DEFINE_RISCV_EXT( + /* NAME */ smrnmi, + /* UPPERCASE_NAME */ SMRNMI, + /* FULL_NAME */ "Resumable non-maskable interrupts", + /* DESC */ "", + /* URL */ , + /* DEP_EXTS */ ({"zicsr"}), + /* SUPPORTED_VERSIONS */ ({{1, 0}}), + /* FLAG_GROUP */ sm, + /* BITMASK_GROUP_ID */ BITMASK_NOT_YET_ALLOCATED, + /* BITMASK_BIT_POSITION*/ BITMASK_NOT_YET_ALLOCATED, + /* EXTRA_EXTENSION_FLAGS */ 0) + +DEFINE_RISCV_EXT( /* NAME */ smstateen, - /* UPPERCAE_NAME */ SMSTATEEN, + /* UPPERCASE_NAME */ SMSTATEEN, /* FULL_NAME */ "State enable extension", /* DESC */ "", /* URL */ , @@ -1742,7 +1781,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ smdbltrp, - /* UPPERCAE_NAME */ SMDBLTRP, + /* UPPERCASE_NAME */ SMDBLTRP, /* FULL_NAME */ "Double Trap Extensions", /* DESC */ "", /* URL */ , @@ -1755,7 +1794,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ ssaia, - /* UPPERCAE_NAME */ SSAIA, + /* UPPERCASE_NAME */ SSAIA, /* FULL_NAME */ "Advanced interrupt architecture extension for supervisor-mode", /* DESC */ "", /* URL */ , @@ -1767,8 +1806,21 @@ DEFINE_RISCV_EXT( /* EXTRA_EXTENSION_FLAGS */ 0) DEFINE_RISCV_EXT( + /* NAME */ ssccptr, + /* UPPERCASE_NAME */ SSCCPTR, + /* FULL_NAME */ "Main memory supports page table reads", + /* DESC */ "", + /* URL */ , + /* DEP_EXTS */ ({}), + /* SUPPORTED_VERSIONS */ ({{1, 0}}), + /* FLAG_GROUP */ ss, + /* BITMASK_GROUP_ID */ BITMASK_NOT_YET_ALLOCATED, + /* BITMASK_BIT_POSITION*/ BITMASK_NOT_YET_ALLOCATED, + /* EXTRA_EXTENSION_FLAGS */ 0) + +DEFINE_RISCV_EXT( /* NAME */ sscofpmf, - /* UPPERCAE_NAME */ SSCOFPMF, + /* UPPERCASE_NAME */ SSCOFPMF, /* FULL_NAME */ "Count overflow & filtering extension", /* DESC */ "", /* URL */ , @@ -1780,8 +1832,34 @@ DEFINE_RISCV_EXT( /* EXTRA_EXTENSION_FLAGS */ 0) DEFINE_RISCV_EXT( + /* NAME */ sscounterenw, + /* UPPERCASE_NAME */ SSCOUNTERENW, + /* FULL_NAME */ "Support writeable enables for any supported counter", + /* DESC */ "", + /* URL */ , + /* DEP_EXTS */ ({"zicsr"}), + /* SUPPORTED_VERSIONS */ ({{1, 0}}), + /* FLAG_GROUP */ ss, + /* BITMASK_GROUP_ID */ BITMASK_NOT_YET_ALLOCATED, + /* BITMASK_BIT_POSITION*/ BITMASK_NOT_YET_ALLOCATED, + /* EXTRA_EXTENSION_FLAGS */ 0) + +DEFINE_RISCV_EXT( + /* NAME */ sscsrind, + /* UPPERCASE_NAME */ SSCSRIND, + /* FULL_NAME */ "Supervisor-Level Indirect CSR Access", + /* DESC */ "", + /* URL */ , + /* DEP_EXTS */ ({"zicsr"}), + /* SUPPORTED_VERSIONS */ ({{1, 0}}), + /* FLAG_GROUP */ ss, + /* BITMASK_GROUP_ID */ BITMASK_NOT_YET_ALLOCATED, + /* BITMASK_BIT_POSITION*/ BITMASK_NOT_YET_ALLOCATED, + /* EXTRA_EXTENSION_FLAGS */ 0) + +DEFINE_RISCV_EXT( /* NAME */ ssnpm, - /* UPPERCAE_NAME */ SSNPM, + /* UPPERCASE_NAME */ SSNPM, /* FULL_NAME */ "ssnpm extension", /* DESC */ "", /* URL */ , @@ -1794,7 +1872,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ sspm, - /* UPPERCAE_NAME */ SSPM, + /* UPPERCASE_NAME */ SSPM, /* FULL_NAME */ "sspm extension", /* DESC */ "", /* URL */ , @@ -1807,7 +1885,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ ssstateen, - /* UPPERCAE_NAME */ SSSTATEEN, + /* UPPERCASE_NAME */ SSSTATEEN, /* FULL_NAME */ "State-enable extension for supervisor-mode", /* DESC */ "", /* URL */ , @@ -1820,7 +1898,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ sstc, - /* UPPERCAE_NAME */ SSTC, + /* UPPERCASE_NAME */ SSTC, /* FULL_NAME */ "Supervisor-mode timer interrupts extension", /* DESC */ "", /* URL */ , @@ -1832,8 +1910,34 @@ DEFINE_RISCV_EXT( /* EXTRA_EXTENSION_FLAGS */ 0) DEFINE_RISCV_EXT( + /* NAME */ sstvala, + /* UPPERCASE_NAME */ SSTVALA, + /* FULL_NAME */ "Stval provides all needed values", + /* DESC */ "", + /* URL */ , + /* DEP_EXTS */ ({"zicsr"}), + /* SUPPORTED_VERSIONS */ ({{1, 0}}), + /* FLAG_GROUP */ ss, + /* BITMASK_GROUP_ID */ BITMASK_NOT_YET_ALLOCATED, + /* BITMASK_BIT_POSITION*/ BITMASK_NOT_YET_ALLOCATED, + /* EXTRA_EXTENSION_FLAGS */ 0) + +DEFINE_RISCV_EXT( + /* NAME */ sstvecd, + /* UPPERCASE_NAME */ SSTVECD, + /* FULL_NAME */ "Stvec supports Direct mode", + /* DESC */ "", + /* URL */ , + /* DEP_EXTS */ ({"zicsr"}), + /* SUPPORTED_VERSIONS */ ({{1, 0}}), + /* FLAG_GROUP */ ss, + /* BITMASK_GROUP_ID */ BITMASK_NOT_YET_ALLOCATED, + /* BITMASK_BIT_POSITION*/ BITMASK_NOT_YET_ALLOCATED, + /* EXTRA_EXTENSION_FLAGS */ 0) + +DEFINE_RISCV_EXT( /* NAME */ ssstrict, - /* UPPERCAE_NAME */ SSSTRICT, + /* UPPERCASE_NAME */ SSSTRICT, /* FULL_NAME */ "ssstrict extension", /* DESC */ "", /* URL */ , @@ -1846,7 +1950,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ ssdbltrp, - /* UPPERCAE_NAME */ SSDBLTRP, + /* UPPERCASE_NAME */ SSDBLTRP, /* FULL_NAME */ "Double Trap Extensions", /* DESC */ "", /* URL */ , @@ -1858,8 +1962,21 @@ DEFINE_RISCV_EXT( /* EXTRA_EXTENSION_FLAGS */ 0) DEFINE_RISCV_EXT( + /* NAME */ ssu64xl, + /* UPPERCASE_NAME */ SSU64XL, + /* FULL_NAME */ "UXLEN=64 must be supported", + /* DESC */ "", + /* URL */ , + /* DEP_EXTS */ ({"zicsr"}), + /* SUPPORTED_VERSIONS */ ({{1, 0}}), + /* FLAG_GROUP */ ss, + /* BITMASK_GROUP_ID */ BITMASK_NOT_YET_ALLOCATED, + /* BITMASK_BIT_POSITION*/ BITMASK_NOT_YET_ALLOCATED, + /* EXTRA_EXTENSION_FLAGS */ 0) + +DEFINE_RISCV_EXT( /* NAME */ supm, - /* UPPERCAE_NAME */ SUPM, + /* UPPERCASE_NAME */ SUPM, /* FULL_NAME */ "supm extension", /* DESC */ "", /* URL */ , @@ -1872,7 +1989,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ svinval, - /* UPPERCAE_NAME */ SVINVAL, + /* UPPERCASE_NAME */ SVINVAL, /* FULL_NAME */ "Fine-grained address-translation cache invalidation extension", /* DESC */ "", /* URL */ , @@ -1885,7 +2002,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ svnapot, - /* UPPERCAE_NAME */ SVNAPOT, + /* UPPERCASE_NAME */ SVNAPOT, /* FULL_NAME */ "NAPOT translation contiguity extension", /* DESC */ "", /* URL */ , @@ -1898,7 +2015,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ svpbmt, - /* UPPERCAE_NAME */ SVPBMT, + /* UPPERCASE_NAME */ SVPBMT, /* FULL_NAME */ "Page-based memory types extension", /* DESC */ "", /* URL */ , @@ -1911,7 +2028,7 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ svvptc, - /* UPPERCAE_NAME */ SVVPTC, + /* UPPERCASE_NAME */ SVVPTC, /* FULL_NAME */ "svvptc extension", /* DESC */ "", /* URL */ , @@ -1924,11 +2041,11 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ svadu, - /* UPPERCAE_NAME */ SVADU, + /* UPPERCASE_NAME */ SVADU, /* FULL_NAME */ "Hardware Updating of A/D Bits extension", /* DESC */ "", /* URL */ , - /* DEP_EXTS */ ({}), + /* DEP_EXTS */ ({"zicsr"}), /* SUPPORTED_VERSIONS */ ({{1, 0}}), /* FLAG_GROUP */ sv, /* BITMASK_GROUP_ID */ BITMASK_NOT_YET_ALLOCATED, @@ -1937,11 +2054,24 @@ DEFINE_RISCV_EXT( DEFINE_RISCV_EXT( /* NAME */ svade, - /* UPPERCAE_NAME */ SVADE, + /* UPPERCASE_NAME */ SVADE, /* FULL_NAME */ "Cause exception when hardware updating of A/D bits is disabled", /* DESC */ "", /* URL */ , - /* DEP_EXTS */ ({}), + /* DEP_EXTS */ ({"zicsr"}), + /* SUPPORTED_VERSIONS */ ({{1, 0}}), + /* FLAG_GROUP */ sv, + /* BITMASK_GROUP_ID */ BITMASK_NOT_YET_ALLOCATED, + /* BITMASK_BIT_POSITION*/ BITMASK_NOT_YET_ALLOCATED, + /* EXTRA_EXTENSION_FLAGS */ 0) + +DEFINE_RISCV_EXT( + /* NAME */ svbare, + /* UPPERCASE_NAME */ SVBARE, + /* FULL_NAME */ "Satp mode bare is supported", + /* DESC */ "", + /* URL */ , + /* DEP_EXTS */ ({"zicsr"}), /* SUPPORTED_VERSIONS */ ({{1, 0}}), /* FLAG_GROUP */ sv, /* BITMASK_GROUP_ID */ BITMASK_NOT_YET_ALLOCATED, diff --git a/gcc/config/riscv/riscv-ext.opt b/gcc/config/riscv/riscv-ext.opt index c0dcde6..9f8c545 100644 --- a/gcc/config/riscv/riscv-ext.opt +++ b/gcc/config/riscv/riscv-ext.opt @@ -325,6 +325,8 @@ Mask(SHCOUNTERENW) Var(riscv_sh_subext) Mask(SHGATPA) Var(riscv_sh_subext) +Mask(SHLCOFIDELEG) Var(riscv_sh_subext) + Mask(SHTVALA) Var(riscv_sh_subext) Mask(SHVSTVALA) Var(riscv_sh_subext) @@ -337,20 +339,30 @@ Mask(SMAIA) Var(riscv_sm_subext) Mask(SMCNTRPMF) Var(riscv_sm_subext) +Mask(SMCSRIND) Var(riscv_sm_subext) + Mask(SMEPMP) Var(riscv_sm_subext) Mask(SMMPM) Var(riscv_sm_subext) Mask(SMNPM) Var(riscv_sm_subext) +Mask(SMRNMI) Var(riscv_sm_subext) + Mask(SMSTATEEN) Var(riscv_sm_subext) Mask(SMDBLTRP) Var(riscv_sm_subext) Mask(SSAIA) Var(riscv_ss_subext) +Mask(SSCCPTR) Var(riscv_ss_subext) + Mask(SSCOFPMF) Var(riscv_ss_subext) +Mask(SSCOUNTERENW) Var(riscv_ss_subext) + +Mask(SSCSRIND) Var(riscv_ss_subext) + Mask(SSNPM) Var(riscv_ss_subext) Mask(SSPM) Var(riscv_ss_subext) @@ -359,10 +371,16 @@ Mask(SSSTATEEN) Var(riscv_ss_subext) Mask(SSTC) Var(riscv_ss_subext) +Mask(SSTVALA) Var(riscv_ss_subext) + +Mask(SSTVECD) Var(riscv_ss_subext) + Mask(SSSTRICT) Var(riscv_ss_subext) Mask(SSDBLTRP) Var(riscv_ss_subext) +Mask(SSU64XL) Var(riscv_ss_subext) + Mask(SUPM) Var(riscv_su_subext) Mask(SVINVAL) Var(riscv_sv_subext) @@ -377,6 +395,8 @@ Mask(SVADU) Var(riscv_sv_subext) Mask(SVADE) Var(riscv_sv_subext) +Mask(SVBARE) Var(riscv_sv_subext) + Mask(XCVALU) Var(riscv_xcv_subext) Mask(XCVBI) Var(riscv_xcv_subext) diff --git a/gcc/config/riscv/riscv-opts.h b/gcc/config/riscv/riscv-opts.h index c02c599..e1a820b 100644 --- a/gcc/config/riscv/riscv-opts.h +++ b/gcc/config/riscv/riscv-opts.h @@ -164,6 +164,7 @@ enum riscv_tls_type { (TARGET_VECTOR && riscv_mautovec_segment) #define GPR2VR_COST_UNPROVIDED -1 +#define FPR2VR_COST_UNPROVIDED -1 /* Extra extension flags, used for carry extra info for a RISC-V extension. */ enum diff --git a/gcc/config/riscv/riscv-protos.h b/gcc/config/riscv/riscv-protos.h index d8c8f6b..a033120 100644 --- a/gcc/config/riscv/riscv-protos.h +++ b/gcc/config/riscv/riscv-protos.h @@ -841,6 +841,7 @@ const struct riscv_tune_info * riscv_parse_tune (const char *, bool); const cpu_vector_cost *get_vector_costs (); int get_gr2vr_cost (); +int get_fr2vr_cost (); enum { diff --git a/gcc/config/riscv/riscv-v.cc b/gcc/config/riscv/riscv-v.cc index 6162797..a41317f 100644 --- a/gcc/config/riscv/riscv-v.cc +++ b/gcc/config/riscv/riscv-v.cc @@ -5567,6 +5567,7 @@ expand_vx_binary_vec_vec_dup (rtx op_0, rtx op_1, rtx op_2, case IOR: case XOR: case MULT: + case DIV: icode = code_for_pred_scalar (code, mode); break; default: diff --git a/gcc/config/riscv/riscv-vector-costs.cc b/gcc/config/riscv/riscv-vector-costs.cc index a39b611..4d8170d 100644 --- a/gcc/config/riscv/riscv-vector-costs.cc +++ b/gcc/config/riscv/riscv-vector-costs.cc @@ -1099,8 +1099,8 @@ costs::adjust_stmt_cost (enum vect_cost_for_stmt kind, loop_vec_info loop, switch (kind) { case scalar_to_vec: - stmt_cost += (FLOAT_TYPE_P (vectype) ? costs->regmove->FR2VR - : get_gr2vr_cost ()); + stmt_cost + += (FLOAT_TYPE_P (vectype) ? get_fr2vr_cost () : get_gr2vr_cost ()); break; case vec_to_scalar: stmt_cost += (FLOAT_TYPE_P (vectype) ? costs->regmove->VR2FR diff --git a/gcc/config/riscv/riscv.cc b/gcc/config/riscv/riscv.cc index d3cee96..3254ec9 100644 --- a/gcc/config/riscv/riscv.cc +++ b/gcc/config/riscv/riscv.cc @@ -3891,6 +3891,25 @@ riscv_extend_cost (rtx op, bool unsigned_p) return COSTS_N_INSNS (2); } +/* Return the cost of the vector binary rtx like add, minus, mult. + The cost of scalar2vr_cost will be appended if there one of the + op comes from the VEC_DUPLICATE. */ + +static int +get_vector_binary_rtx_cost (rtx x, int scalar2vr_cost) +{ + gcc_assert (riscv_v_ext_mode_p (GET_MODE (x))); + + rtx op_0 = XEXP (x, 0); + rtx op_1 = XEXP (x, 1); + + if (GET_CODE (op_0) == VEC_DUPLICATE + || GET_CODE (op_1) == VEC_DUPLICATE) + return (scalar2vr_cost + 1) * COSTS_N_INSNS (1); + else + return COSTS_N_INSNS (1); +} + /* Implement TARGET_RTX_COSTS. */ #define SINGLE_SHIFT_COST 1 @@ -3904,6 +3923,9 @@ riscv_rtx_costs (rtx x, machine_mode mode, int outer_code, int opno ATTRIBUTE_UN if (riscv_v_ext_mode_p (mode)) { int gr2vr_cost = get_gr2vr_cost (); + int fr2vr_cost = get_fr2vr_cost (); + int scalar2vr_cost = FLOAT_MODE_P (GET_MODE_INNER (mode)) + ? fr2vr_cost : gr2vr_cost; switch (outer_code) { @@ -3914,6 +3936,21 @@ riscv_rtx_costs (rtx x, machine_mode mode, int outer_code, int opno ATTRIBUTE_UN case VEC_DUPLICATE: *total = gr2vr_cost * COSTS_N_INSNS (1); break; + case IF_THEN_ELSE: + { + rtx op = XEXP (x, 1); + + switch (GET_CODE (op)) + { + case DIV: + *total = get_vector_binary_rtx_cost (op, scalar2vr_cost); + break; + default: + *total = COSTS_N_INSNS (1); + break; + } + } + break; case PLUS: case MINUS: case AND: @@ -3921,14 +3958,15 @@ riscv_rtx_costs (rtx x, machine_mode mode, int outer_code, int opno ATTRIBUTE_UN case XOR: case MULT: { + rtx op; rtx op_0 = XEXP (x, 0); rtx op_1 = XEXP (x, 1); - if (GET_CODE (op_0) == VEC_DUPLICATE - || GET_CODE (op_1) == VEC_DUPLICATE) - *total = (gr2vr_cost + 1) * COSTS_N_INSNS (1); + if (GET_CODE (op = op_0) == MULT + || GET_CODE (op = op_1) == MULT) + *total = get_vector_binary_rtx_cost (op, scalar2vr_cost); else - *total = COSTS_N_INSNS (1); + *total = get_vector_binary_rtx_cost (x, scalar2vr_cost); } break; default: @@ -9781,7 +9819,7 @@ riscv_register_move_cost (machine_mode mode, if (from_is_gpr) return get_gr2vr_cost (); else if (from_is_fpr) - return get_vector_costs ()->regmove->FR2VR; + return get_fr2vr_cost (); } return riscv_secondary_memory_needed (mode, from, to) ? 8 : 2; @@ -12647,6 +12685,21 @@ get_gr2vr_cost () return cost; } +/* Return the cost of moving data from floating-point to vector register. + It will take the value of --param=fpr2vr-cost if it is provided. + Otherwise the default regmove->FR2VR will be returned. */ + +int +get_fr2vr_cost () +{ + int cost = get_vector_costs ()->regmove->FR2VR; + + if (fpr2vr_cost != FPR2VR_COST_UNPROVIDED) + cost = fpr2vr_cost; + + return cost; +} + /* Implement targetm.vectorize.builtin_vectorization_cost. */ static int @@ -12712,8 +12765,7 @@ riscv_builtin_vectorization_cost (enum vect_cost_for_stmt type_of_cost, case vec_construct: { /* TODO: This is too pessimistic in case we can splat. */ - int regmove_cost = fp ? costs->regmove->FR2VR - : get_gr2vr_cost (); + int regmove_cost = fp ? get_fr2vr_cost () : get_gr2vr_cost (); return (regmove_cost + common_costs->scalar_to_vec_cost) * estimated_poly_value (TYPE_VECTOR_SUBPARTS (vectype)); } diff --git a/gcc/config/riscv/riscv.opt b/gcc/config/riscv/riscv.opt index b2b9d33..6543fd1 100644 --- a/gcc/config/riscv/riscv.opt +++ b/gcc/config/riscv/riscv.opt @@ -286,6 +286,10 @@ Max number of bytes to compare as part of inlined strcmp/strncmp routines (defau Target RejectNegative Joined UInteger Var(gpr2vr_cost) Init(GPR2VR_COST_UNPROVIDED) Set the cost value of the rvv instruction when operate from GPR to VR. +-param=fpr2vr-cost= +Target RejectNegative Joined UInteger Var(fpr2vr_cost) Init(FPR2VR_COST_UNPROVIDED) +Set the cost value of the rvv instruction when operate from FPR to VR. + -param=riscv-autovec-mode= Target Undocumented RejectNegative Joined Var(riscv_autovec_mode) Save Set the only autovec mode to try. diff --git a/gcc/config/riscv/vector-iterators.md b/gcc/config/riscv/vector-iterators.md index 2bd99ee..86f31f3 100644 --- a/gcc/config/riscv/vector-iterators.md +++ b/gcc/config/riscv/vector-iterators.md @@ -4041,7 +4041,11 @@ smax umax smin umin mult div udiv mod umod ]) -(define_code_iterator any_int_binop_no_shift_vx [ +(define_code_iterator any_int_binop_no_shift_v_vdup [ + plus minus and ior xor mult div +]) + +(define_code_iterator any_int_binop_no_shift_vdup_v [ plus minus and ior xor mult ]) diff --git a/gcc/config/riscv/zicond.md b/gcc/config/riscv/zicond.md index f87b4f2..d170f6a 100644 --- a/gcc/config/riscv/zicond.md +++ b/gcc/config/riscv/zicond.md @@ -234,5 +234,39 @@ (const_int 0) (match_dup 4)))]) +;; We can splat the sign bit across a GPR with a arithmetic right shift +;; which gives us a 0, -1 result. We then turn on bit #0 unconditionally +;; which results in 1, -1. There's probably other cases that could be +;; handled, this seems particularly important though. +(define_split + [(set (match_operand:X 0 "register_operand") + (plus:X (if_then_else:X (ge:X (match_operand:X 1 "register_operand") + (const_int 0)) + (match_operand 2 "const_int_operand") + (match_operand 3 "const_int_operand")) + (match_operand 4 "const_int_operand")))] + "((TARGET_ZICOND_LIKE || TARGET_XTHEADCONDMOV) + && INTVAL (operands[2]) + INTVAL (operands[4]) == 1 + && INTVAL (operands[3]) + INTVAL (operands[4]) == -1)" + [(set (match_dup 0) (ashiftrt:X (match_dup 1) (match_dup 2))) + (set (match_dup 0) (ior:X (match_dup 0) (const_int 1)))] + { operands[2] = GEN_INT (GET_MODE_BITSIZE (word_mode) - 1); }) - +;; Similarly, but the condition and true/false values are reversed +;; +;; Note the case where the condition is reversed, but not the true/false +;; values. Or vice-versa is not handled because we don't support 4->3 +;; splits. +(define_split + [(set (match_operand:X 0 "register_operand") + (plus:X (if_then_else:X (lt:X (match_operand:X 1 "register_operand") + (const_int 0)) + (match_operand 2 "const_int_operand") + (match_operand 3 "const_int_operand")) + (match_operand 4 "const_int_operand")))] + "((TARGET_ZICOND_LIKE || TARGET_XTHEADCONDMOV) + && INTVAL (operands[2]) + INTVAL (operands[4]) == -1 + && INTVAL (operands[3]) + INTVAL (operands[4]) == 1)" + [(set (match_dup 0) (ashiftrt:X (match_dup 1) (match_dup 2))) + (set (match_dup 0) (ior:X (match_dup 0) (const_int 1)))] + { operands[2] = GEN_INT (GET_MODE_BITSIZE (word_mode) - 1); }) diff --git a/gcc/cp/ChangeLog b/gcc/cp/ChangeLog index 3f05db3..f10cf46 100644 --- a/gcc/cp/ChangeLog +++ b/gcc/cp/ChangeLog @@ -1,3 +1,65 @@ +2025-06-04 Jason Merrill <jason@redhat.com> + + PR c++/120502 + * cp-gimplify.cc (cp_fold_r) [TARGET_EXPR]: Do constexpr evaluation + before genericize. + * constexpr.cc (cxx_eval_store_expression): Add comment. + +2025-06-03 Jason Merrill <jason@redhat.com> + + * name-lookup.h (operator|, operator|=): Define for WMB_Flags. + +2025-06-02 Jason Merrill <jason@redhat.com> + + PR c++/107600 + * method.cc (destructible_expr): Fix refs and arrays of unknown + bound. + +2025-06-02 Jason Merrill <jason@redhat.com> + + PR c++/120506 + * constexpr.cc (cxx_eval_outermost_constant_expr): Always check + CONSTRUCTOR_NO_CLEARING. + +2025-06-02 Iain Sandoe <iain@sandoe.co.uk> + + * coroutines.cc (build_actor_fn): Remove an unused + label, guard the frame deallocation correctly, use + simpler APIs to build if and return statements. + +2025-06-02 Iain Sandoe <iain@sandoe.co.uk> + + PR c++/118903 + * constexpr.cc (potential_constant_expression_1): Emit + an error when co_await et. al. are used in constexpr + contexts. + +2025-06-02 Iain Sandoe <iain@sandoe.co.uk> + + * error.cc (dump_expr): Add co_await, co_yield and co_return. + +2025-06-02 Jason Merrill <jason@redhat.com> + + PR c++/107600 + * method.cc (destructible_expr): Handle non-classes. + (constructible_expr): Check for abstract class here... + (is_xible_helper): ...not here. + +2025-06-02 Jason Merrill <jason@redhat.com> + + PR c++/107600 + * semantics.cc (trait_expr_value) [CPTK_HAS_TRIVIAL_DESTRUCTOR]: + Add cp_unevaluated. + +2025-06-02 Sandra Loosemore <sloosemore@baylibre.com> + + * cp-tree.h (maybe_convert_cond): Declare. + * parser.cc (cp_parser_omp_context_selector): Call + maybe_convert_cond and fold_build_cleanup_point_expr on the + expression for OMP_TRAIT_PROPERTY_BOOL_EXPR. + * pt.cc (tsubst_omp_context_selector): Likewise. + * semantics.cc (maybe_convert_cond): Remove static declaration. + 2025-05-30 Jason Merrill <jason@redhat.com> PR c++/113563 diff --git a/gcc/cp/constexpr.cc b/gcc/cp/constexpr.cc index b9fdc94..7078839 100644 --- a/gcc/cp/constexpr.cc +++ b/gcc/cp/constexpr.cc @@ -6413,7 +6413,8 @@ cxx_eval_store_expression (const constexpr_ctx *ctx, tree t, if (TREE_CLOBBER_P (init) && CLOBBER_KIND (init) < CLOBBER_OBJECT_END) - /* Only handle clobbers ending the lifetime of objects. */ + /* Only handle clobbers ending the lifetime of objects. + ??? We should probably set CONSTRUCTOR_NO_CLEARING. */ return void_node; /* First we figure out where we're storing to. */ @@ -9487,8 +9488,35 @@ tree maybe_constant_value (tree t, tree decl /* = NULL_TREE */, mce_value manifestly_const_eval /* = mce_unknown */) { + tree orig_t = t; tree r; + if (EXPR_P (t) && manifestly_const_eval == mce_unknown) + { + /* Look up each operand in the cv_cache first to see if we've already + reduced it, and reuse that result to avoid quadratic behavior if + we're called when building up a large expression. */ + int n = cp_tree_operand_length (t); + tree *ops = XALLOCAVEC (tree, n); + bool rebuild = false; + for (int i = 0; i < n; ++i) + { + ops[i] = TREE_OPERAND (t, i); + if (tree *cached = hash_map_safe_get (cv_cache, ops[i])) + if (*cached != ops[i]) + { + ops[i] = *cached; + rebuild = true; + } + } + if (rebuild) + { + t = copy_node (t); + for (int i = 0; i < n; ++i) + TREE_OPERAND (t, i) = ops[i]; + } + } + if (!is_nondependent_constant_expression (t)) { if (TREE_OVERFLOW_P (t) @@ -9506,6 +9534,10 @@ maybe_constant_value (tree t, tree decl /* = NULL_TREE */, return fold_to_constant (t); if (manifestly_const_eval != mce_unknown) + /* TODO: Extend the cache to be mce_value aware. And if we have a + previously cached mce_unknown result that's TREE_CONSTANT, it means + the reduced value is independent of mce_value and so we should + be able to reuse it in the mce_true/false case. */ return cxx_eval_outermost_constant_expr (t, true, true, manifestly_const_eval, false, decl); @@ -9535,7 +9567,7 @@ maybe_constant_value (tree t, tree decl /* = NULL_TREE */, || (TREE_CONSTANT (t) && !TREE_CONSTANT (r)) || !cp_tree_equal (r, t)); if (!c.evaluation_restricted_p ()) - cv_cache->put (t, r); + cv_cache->put (orig_t, r); return r; } diff --git a/gcc/cp/coroutines.cc b/gcc/cp/coroutines.cc index 7f5d30c..97eee6e 100644 --- a/gcc/cp/coroutines.cc +++ b/gcc/cp/coroutines.cc @@ -2027,8 +2027,10 @@ expand_one_await_expression (tree *expr, tree *await_expr, void *d) tree awaiter_calls = TREE_OPERAND (saved_co_await, 3); tree source = TREE_OPERAND (saved_co_await, 4); - bool is_final = (source - && TREE_INT_CST_LOW (source) == (int) FINAL_SUSPEND_POINT); + bool is_final + = (source && TREE_INT_CST_LOW (source) == (int) FINAL_SUSPEND_POINT); + bool is_initial + = (source && TREE_INT_CST_LOW (source) == (int) INITIAL_SUSPEND_POINT); /* Build labels for the destinations of the control flow when we are resuming or destroying. */ @@ -2156,6 +2158,13 @@ expand_one_await_expression (tree *expr, tree *await_expr, void *d) /* Resume point. */ add_stmt (build_stmt (loc, LABEL_EXPR, resume_label)); + if (is_initial && data->i_a_r_c) + { + r = cp_build_modify_expr (loc, data->i_a_r_c, NOP_EXPR, boolean_true_node, + tf_warning_or_error); + finish_expr_stmt (r); + } + /* This will produce the value (if one is provided) from the co_await expression. */ tree resume_call = TREE_VEC_ELT (awaiter_calls, 2); /* await_resume(). */ @@ -2654,8 +2663,12 @@ build_actor_fn (location_t loc, tree coro_frame_type, tree actor, tree fnbody, /* We've now rewritten the tree and added the initial and final co_awaits. Now pass over the tree and expand the co_awaits. */ + tree i_a_r_c = NULL_TREE; + if (flag_exceptions) + i_a_r_c = coro_build_frame_access_expr (actor_frame, coro_frame_i_a_r_c_id, + false, tf_warning_or_error); - coro_aw_data data = {actor, actor_fp, resume_idx_var, NULL_TREE, + coro_aw_data data = {actor, actor_fp, resume_idx_var, i_a_r_c, ash, del_promise_label, ret_label, continue_label, restart_dispatch_label, continuation, 2}; cp_walk_tree (&actor_body, await_statement_expander, &data, NULL); @@ -4014,12 +4027,14 @@ rewrite_param_uses (tree *stmt, int *do_subtree ATTRIBUTE_UNUSED, void *d) } /* Build up a set of info that determines how each param copy will be - handled. */ + handled. We store this in a hash map so that we can access it from + a tree walk callback that re-writes the original parameters to their + copies. */ -static void -analyze_fn_parms (tree orig, hash_map<tree, param_info> *param_uses) +void +cp_coroutine_transform::analyze_fn_parms () { - if (!DECL_ARGUMENTS (orig)) + if (!DECL_ARGUMENTS (orig_fn_decl)) return; /* Build a hash map with an entry for each param. @@ -4029,19 +4044,19 @@ analyze_fn_parms (tree orig, hash_map<tree, param_info> *param_uses) Then a tree list of the uses. The second two entries start out empty - and only get populated when we see uses. */ - bool lambda_p = LAMBDA_FUNCTION_P (orig); + bool lambda_p = LAMBDA_FUNCTION_P (orig_fn_decl); /* Count the param copies from 1 as per the std. */ unsigned parm_num = 1; - for (tree arg = DECL_ARGUMENTS (orig); arg != NULL; + for (tree arg = DECL_ARGUMENTS (orig_fn_decl); arg != NULL; ++parm_num, arg = DECL_CHAIN (arg)) { bool existed; - param_info &parm = param_uses->get_or_insert (arg, &existed); + param_info &parm = param_uses.get_or_insert (arg, &existed); gcc_checking_assert (!existed); parm.body_uses = NULL; tree actual_type = TREE_TYPE (arg); - actual_type = complete_type_or_else (actual_type, orig); + actual_type = complete_type_or_else (actual_type, orig_fn_decl); if (actual_type == NULL_TREE) actual_type = error_mark_node; parm.orig_type = actual_type; @@ -4435,30 +4450,6 @@ cp_coroutine_transform::wrap_original_function_body () tree tcb = build_stmt (loc, TRY_BLOCK, NULL_TREE, NULL_TREE); add_stmt (tcb); TRY_STMTS (tcb) = push_stmt_list (); - if (initial_await != error_mark_node) - { - /* Build a compound expression that sets the - initial-await-resume-called variable true and then calls the - initial suspend expression await resume. - In the case that the user decides to make the initial await - await_resume() return a value, we need to discard it and, it is - a reference type, look past the indirection. */ - if (INDIRECT_REF_P (initial_await)) - initial_await = TREE_OPERAND (initial_await, 0); - /* In the case that the initial_await returns a target expression - we might need to look through that to update the await expr. */ - tree iaw = initial_await; - if (TREE_CODE (iaw) == TARGET_EXPR) - iaw = TARGET_EXPR_INITIAL (iaw); - gcc_checking_assert (TREE_CODE (iaw) == CO_AWAIT_EXPR); - tree vec = TREE_OPERAND (iaw, 3); - tree aw_r = TREE_VEC_ELT (vec, 2); - aw_r = convert_to_void (aw_r, ICV_STATEMENT, tf_warning_or_error); - tree update = build2 (MODIFY_EXPR, boolean_type_node, i_a_r_c, - boolean_true_node); - aw_r = cp_build_compound_expr (update, aw_r, tf_warning_or_error); - TREE_VEC_ELT (vec, 2) = aw_r; - } /* Add the initial await to the start of the user-authored function. */ finish_expr_stmt (initial_await); /* Append the original function body. */ @@ -5260,7 +5251,7 @@ cp_coroutine_transform::apply_transforms () /* Collect information on the original function params and their use in the function body. */ - analyze_fn_parms (orig_fn_decl, ¶m_uses); + analyze_fn_parms (); /* Declare the actor and destroyer functions, the following code needs to see these. */ diff --git a/gcc/cp/coroutines.h b/gcc/cp/coroutines.h index 10698cf..55caa6e 100644 --- a/gcc/cp/coroutines.h +++ b/gcc/cp/coroutines.h @@ -126,6 +126,7 @@ private: bool inline_p = false; bool valid_coroutine = false; + void analyze_fn_parms (); void wrap_original_function_body (); bool build_ramp_function (); }; diff --git a/gcc/cp/cp-gimplify.cc b/gcc/cp/cp-gimplify.cc index 16def88..0fcfa16 100644 --- a/gcc/cp/cp-gimplify.cc +++ b/gcc/cp/cp-gimplify.cc @@ -1473,6 +1473,19 @@ cp_fold_r (tree *stmt_p, int *walk_subtrees, void *data_) break; case TARGET_EXPR: + if (!flag_no_inline) + if (tree &init = TARGET_EXPR_INITIAL (stmt)) + { + tree folded = maybe_constant_init (init, TARGET_EXPR_SLOT (stmt), + (data->flags & ff_mce_false + ? mce_false : mce_unknown)); + if (folded != init && TREE_CONSTANT (folded)) + init = folded; + } + + /* This needs to happen between the constexpr evaluation (which wants + pre-generic trees) and fold (which wants the cp_genericize_init + transformations). */ if (data->flags & ff_genericize) cp_genericize_target_expr (stmt_p); @@ -1481,14 +1494,6 @@ cp_fold_r (tree *stmt_p, int *walk_subtrees, void *data_) cp_walk_tree (&init, cp_fold_r, data, NULL); cp_walk_tree (&TARGET_EXPR_CLEANUP (stmt), cp_fold_r, data, NULL); *walk_subtrees = 0; - if (!flag_no_inline) - { - tree folded = maybe_constant_init (init, TARGET_EXPR_SLOT (stmt), - (data->flags & ff_mce_false - ? mce_false : mce_unknown)); - if (folded != init && TREE_CONSTANT (folded)) - init = folded; - } /* Folding might replace e.g. a COND_EXPR with a TARGET_EXPR; in that case, strip it in favor of this one. */ if (TREE_CODE (init) == TARGET_EXPR) diff --git a/gcc/cp/name-lookup.h b/gcc/cp/name-lookup.h index 4216a51..2fa736b 100644 --- a/gcc/cp/name-lookup.h +++ b/gcc/cp/name-lookup.h @@ -501,6 +501,10 @@ enum WMB_Flags WMB_Hidden = 1 << 3, WMB_Purview = 1 << 4, }; +inline WMB_Flags operator|(WMB_Flags x, WMB_Flags y) +{ return WMB_Flags(+x|y); } +inline WMB_Flags& operator|=(WMB_Flags& x, WMB_Flags y) +{ return x = x|y; } extern unsigned walk_module_binding (tree binding, bitmap partitions, bool (*)(tree decl, WMB_Flags, void *data), diff --git a/gcc/cp/pt.cc b/gcc/cp/pt.cc index c5a3abe..b5c877a 100644 --- a/gcc/cp/pt.cc +++ b/gcc/cp/pt.cc @@ -14983,6 +14983,8 @@ tsubst_function_decl (tree t, tree args, tsubst_flags_t complain, if (closure && DECL_IOBJ_MEMBER_FUNCTION_P (t)) parms = DECL_CHAIN (parms); parms = tsubst (parms, args, complain, t); + if (parms == error_mark_node) + return error_mark_node; for (tree parm = parms; parm; parm = DECL_CHAIN (parm)) DECL_CONTEXT (parm) = r; if (closure && DECL_IOBJ_MEMBER_FUNCTION_P (t)) @@ -15555,6 +15557,9 @@ tsubst_decl (tree t, tree args, tsubst_flags_t complain, /* We're dealing with a normal parameter. */ type = tsubst (TREE_TYPE (t), args, complain, in_decl); + if (type == error_mark_node && !(complain & tf_error)) + RETURN (error_mark_node); + type = type_decays_to (type); TREE_TYPE (r) = type; cp_apply_type_quals_to_decl (cp_type_quals (type), r); @@ -15592,8 +15597,13 @@ tsubst_decl (tree t, tree args, tsubst_flags_t complain, /* If cp_unevaluated_operand is set, we're just looking for a single dummy parameter, so don't keep going. */ if (DECL_CHAIN (t) && !cp_unevaluated_operand) - DECL_CHAIN (r) = tsubst (DECL_CHAIN (t), args, - complain, DECL_CHAIN (t)); + { + tree chain = tsubst (DECL_CHAIN (t), args, + complain, DECL_CHAIN (t)); + if (chain == error_mark_node) + RETURN (error_mark_node); + DECL_CHAIN (r) = chain; + } /* FIRST_R contains the start of the chain we've built. */ r = first_r; diff --git a/gcc/doc/install.texi b/gcc/doc/install.texi index ff08336..fb921b3 100644 --- a/gcc/doc/install.texi +++ b/gcc/doc/install.texi @@ -1342,9 +1342,13 @@ default set of libraries is selected based on the value of @item amdgcn*-*-* @var{list} is a comma separated list of ISA names (allowed values: -@code{gfx900}, @code{gfx906}, @code{gfx908}, @code{gfx90a}, @code{gfx90c}, -@code{gfx1030}, @code{gfx1036}, @code{gfx1100}, @code{gfx1103}). -It ought not include the name of the default +@code{gfx900}, @code{gfx902}, @code{gfx904}, @code{gfx906}, @code{gfx908}, +@code{gfx909}, @code{gfx90a}, @code{gfx90c}, @code{gfx9-generic}, +@code{gfx1030}, @code{gfx1031}, @code{gfx1032}, @code{gfx1033}, +@code{gfx1034}, @code{gfx1035}, @code{gfx1036}, @code{gfx10-3-generic}, +@code{gfx1100}, @code{gfx1101}, @code{gfx1102}, @code{gfx1103}, +@code{gfx1150}, @code{gfx1151}, @code{gfx1152}, @code{gfx1153}, +@code{gfx11-generic}). It ought not include the name of the default ISA, specified via @option{--with-arch}. If @var{list} is empty, then there will be no multilibs and only the default run-time library will be built. If @var{list} is @code{default} or @option{--with-multilib-list=} is not diff --git a/gcc/doc/riscv-ext.texi b/gcc/doc/riscv-ext.texi index e64c0d6..e69a2df 100644 --- a/gcc/doc/riscv-ext.texi +++ b/gcc/doc/riscv-ext.texi @@ -474,6 +474,10 @@ @tab 1.0 @tab SvNNx4 mode supported for all modes supported by satp +@item shlcofideleg +@tab 1.0 +@tab Delegating LCOFI interrupts to VS-mode + @item shtvala @tab 1.0 @tab The htval register provides all needed values @@ -498,6 +502,10 @@ @tab 1.0 @tab Cycle and instret privilege mode filtering +@item smcsrind +@tab 1.0 +@tab Machine-Level Indirect CSR Access + @item smepmp @tab 1.0 @tab PMP Enhancements for memory access and execution prevention on Machine mode @@ -510,6 +518,10 @@ @tab 1.0 @tab smnpm extension +@item smrnmi +@tab 1.0 +@tab Resumable Non-Maskable Interrupts + @item smstateen @tab 1.0 @tab State enable extension @@ -522,10 +534,22 @@ @tab 1.0 @tab Advanced interrupt architecture extension for supervisor-mode +@item ssccptr +@tab 1.0 +@tab Main memory supports page table reads + @item sscofpmf @tab 1.0 @tab Count overflow & filtering extension +@item sscounterenw +@tab 1.0 +@tab Support writeable enables for any supported counter + +@item sscsrind +@tab 1.0 +@tab Supervisor-Level Indirect CSR Access + @item ssnpm @tab 1.0 @tab ssnpm extension @@ -542,6 +566,14 @@ @tab 1.0 @tab Supervisor-mode timer interrupts extension +@item sstvala +@tab 1.0 +@tab Stval provides all needed values + +@item sstvecd +@tab 1.0 +@tab Stvec supports Direct mode + @item ssstrict @tab 1.0 @tab ssstrict extension @@ -550,6 +582,10 @@ @tab 1.0 @tab Double Trap Extensions +@item ssu64xl +@tab 1.0 +@tab UXLEN=64 must be supported + @item supm @tab 1.0 @tab supm extension @@ -578,6 +614,10 @@ @tab 1.0 @tab Cause exception when hardware updating of A/D bits is disabled +@item svbare +@tab 1.0 +@tab Satp mode bare is supported + @item xcvalu @tab 1.0 @tab Core-V miscellaneous ALU extension diff --git a/gcc/emit-rtl.cc b/gcc/emit-rtl.cc index 3f453cd..50e3bfc 100644 --- a/gcc/emit-rtl.cc +++ b/gcc/emit-rtl.cc @@ -998,10 +998,11 @@ validate_subreg (machine_mode omode, machine_mode imode, && known_le (osize, isize)) return false; - /* The outer size must be ordered wrt the register size, otherwise - we wouldn't know at compile time how many registers the outer - mode occupies. */ - if (!ordered_p (osize, regsize)) + /* If ISIZE is greater than REGSIZE, the inner value is split into blocks + of size REGSIZE. The outer size must then be ordered wrt REGSIZE, + otherwise we wouldn't know at compile time how many blocks the + outer mode occupies. */ + if (maybe_gt (isize, regsize) && !ordered_p (osize, regsize)) return false; /* For normal pseudo registers, we want most of the same checks. Namely: diff --git a/gcc/ext-dce.cc b/gcc/ext-dce.cc index a034395..aa80c04 100644 --- a/gcc/ext-dce.cc +++ b/gcc/ext-dce.cc @@ -35,6 +35,7 @@ along with GCC; see the file COPYING3. If not see #include "print-rtl.h" #include "dbgcnt.h" #include "diagnostic-core.h" +#include "target.h" /* These should probably move into a C++ class. */ static vec<bitmap_head> livein; @@ -764,13 +765,25 @@ ext_dce_process_uses (rtx_insn *insn, rtx obj, We don't want to mark those bits live unnecessarily as that inhibits extension elimination in important cases such as those in Coremark. So we need that - outer code. */ + outer code. + + But if !TRULY_NOOP_TRUNCATION_MODES_P, the mode + change performed by Y would normally need to be a + TRUNCATE rather than a SUBREG. It is probably the + guarantee provided by SUBREG_PROMOTED_VAR_P that + allows the SUBREG in Y as an exception. We must + therefore preserve that guarantee and treat the + upper bits of the inner register as live + regardless of the outer code. See PR 120050. */ if (!REG_P (SUBREG_REG (y)) || (SUBREG_PROMOTED_VAR_P (y) && ((GET_CODE (SET_SRC (x)) == SIGN_EXTEND && SUBREG_PROMOTED_SIGNED_P (y)) || (GET_CODE (SET_SRC (x)) == ZERO_EXTEND - && SUBREG_PROMOTED_UNSIGNED_P (y))))) + && SUBREG_PROMOTED_UNSIGNED_P (y)) + || !TRULY_NOOP_TRUNCATION_MODES_P ( + GET_MODE (y), + GET_MODE (SUBREG_REG (y)))))) break; bit = subreg_lsb (y).to_constant (); diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index e740ecc..78f6002 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,15 @@ +2025-06-04 Andre Vehreschild <vehre@gcc.gnu.org> + + PR fortran/120483 + * trans-expr.cc (gfc_conv_substring): Use pointer arithmetic on + static allocatable char arrays. + +2025-06-03 Harald Anlauf <anlauf@gmx.de> + + PR fortran/99838 + * data.cc (gfc_assign_data_value): For a new initializer use the + location from the constructor as fallback. + 2025-05-30 Harald Anlauf <anlauf@gmx.de> PR fortran/102599 diff --git a/gcc/fortran/data.cc b/gcc/fortran/data.cc index 5c83f69..a438c26 100644 --- a/gcc/fortran/data.cc +++ b/gcc/fortran/data.cc @@ -593,7 +593,13 @@ gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index, { /* Point the container at the new expression. */ if (last_con == NULL) - symbol->value = expr; + { + symbol->value = expr; + /* For a new initializer use the location from the + constructor as fallback. */ + if (!GFC_LOCUS_IS_SET(expr->where) && con != NULL) + symbol->value->where = con->where; + } else last_con->expr = expr; } diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index 8d9448e..74d4265 100644 --- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -2782,9 +2782,11 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind, start.expr = gfc_evaluate_now (start.expr, &se->pre); /* Change the start of the string. */ - if ((TREE_CODE (TREE_TYPE (se->expr)) == ARRAY_TYPE - || TREE_CODE (TREE_TYPE (se->expr)) == INTEGER_TYPE) - && TYPE_STRING_FLAG (TREE_TYPE (se->expr))) + if (((TREE_CODE (TREE_TYPE (se->expr)) == ARRAY_TYPE + || TREE_CODE (TREE_TYPE (se->expr)) == INTEGER_TYPE) + && TYPE_STRING_FLAG (TREE_TYPE (se->expr))) + || (POINTER_TYPE_P (TREE_TYPE (se->expr)) + && TREE_CODE (TREE_TYPE (TREE_TYPE (se->expr))) != ARRAY_TYPE)) tmp = se->expr; else tmp = build_fold_indirect_ref_loc (input_location, @@ -2795,6 +2797,14 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind, tmp = gfc_build_array_ref (tmp, start.expr, NULL_TREE, true); se->expr = gfc_build_addr_expr (type, tmp); } + else if (POINTER_TYPE_P (TREE_TYPE (tmp))) + { + tree diff; + diff = fold_build2 (MINUS_EXPR, size_type_node, start.expr, + build_one_cst (size_type_node)); + se->expr + = fold_build2 (POINTER_PLUS_EXPR, TREE_TYPE (tmp), tmp, diff); + } } /* Length = end + 1 - start. */ diff --git a/gcc/gimple-fold.cc b/gcc/gimple-fold.cc index 0f43761..185f9db 100644 --- a/gcc/gimple-fold.cc +++ b/gcc/gimple-fold.cc @@ -198,10 +198,7 @@ can_refer_decl_in_current_unit_p (tree decl, tree from_decl) tree create_tmp_reg_or_ssa_name (tree type, gimple *stmt) { - if (gimple_in_ssa_p (cfun)) - return make_ssa_name (type, stmt); - else - return create_tmp_reg (type); + return make_ssa_name (type, stmt); } /* CVAL is value taken from DECL_INITIAL of variable. Try to transform it into diff --git a/gcc/match.pd b/gcc/match.pd index bde9bd6..6565724 100644 --- a/gcc/match.pd +++ b/gcc/match.pd @@ -2177,6 +2177,18 @@ DEFINE_INT_AND_FLOAT_ROUND_FN (RINT) (view_convert (rshift (view_convert:ntype @0) @1)) (convert (rshift (convert:ntype @0) @1)))))) +#if GIMPLE + /* Fold ((x + y) >> 1 into IFN_AVG_FLOOR (x, y) if x and y are vectors in + which each element is known to have at least one leading zero bit. */ +(simplify + (rshift (plus:cs @0 @1) integer_onep) + (if (VECTOR_TYPE_P (type) + && direct_internal_fn_supported_p (IFN_AVG_FLOOR, type, OPTIMIZE_FOR_BOTH) + && wi::clz (get_nonzero_bits (@0)) > 0 + && wi::clz (get_nonzero_bits (@1)) > 0) + (IFN_AVG_FLOOR @0 @1))) +#endif + /* Try to fold (type) X op CST -> (type) (X op ((type-x) CST)) when profitable. For bitwise binary operations apply operand conversions to the diff --git a/gcc/omp-general.cc b/gcc/omp-general.cc index 0b7c3b9..c799b89 100644 --- a/gcc/omp-general.cc +++ b/gcc/omp-general.cc @@ -2659,10 +2659,16 @@ omp_selector_is_dynamic (tree ctx) static tree omp_device_num_check (tree *device_num, bool *is_host) { + /* C++ may wrap the device_num expr in a CLEANUP_POINT_EXPR; we want + to look inside of it for the special cases. */ + tree t = *device_num; + if (TREE_CODE (t) == CLEANUP_POINT_EXPR) + t = TREE_OPERAND (t, 0); + /* First check for some constant values we can treat specially. */ - if (tree_fits_shwi_p (*device_num)) + if (tree_fits_shwi_p (t)) { - HOST_WIDE_INT num = tree_to_shwi (*device_num); + HOST_WIDE_INT num = tree_to_shwi (t); if (num < -1) return integer_zero_node; /* Initial device? */ @@ -2681,9 +2687,9 @@ omp_device_num_check (tree *device_num, bool *is_host) /* Also test for direct calls to OpenMP routines that return valid device numbers. */ - if (TREE_CODE (*device_num) == CALL_EXPR) + if (TREE_CODE (t) == CALL_EXPR) { - tree fndecl = get_callee_fndecl (*device_num); + tree fndecl = get_callee_fndecl (t); if (fndecl && omp_runtime_api_call (fndecl)) { const char *fnname = IDENTIFIER_POINTER (DECL_NAME (fndecl)); diff --git a/gcc/pass_manager.h b/gcc/pass_manager.h index d4f8900..4de4a48 100644 --- a/gcc/pass_manager.h +++ b/gcc/pass_manager.h @@ -74,6 +74,7 @@ public: } opt_pass *get_pass_peephole2 () const { return m_pass_peephole2_1; } opt_pass *get_pass_profile () const { return m_pass_profile_1; } + opt_pass *get_pass_auto_profile () const { return m_pass_ipa_auto_profile_1; } void register_pass_name (opt_pass *pass, const char *name); diff --git a/gcc/range-op-float.cc b/gcc/range-op-float.cc index dafd9c0..32a6cd7 100644 --- a/gcc/range-op-float.cc +++ b/gcc/range-op-float.cc @@ -51,8 +51,8 @@ along with GCC; see the file COPYING3. If not see bool range_operator::fold_range (frange &r, tree type, - const frange &op1, const frange &op2, - relation_trio trio) const + const frange &op1, const frange &op2, + relation_trio trio) const { if (empty_range_varying (r, type, op1, op2)) return true; @@ -112,20 +112,20 @@ range_operator::rv_fold (frange &r, tree type, bool range_operator::fold_range (irange &r ATTRIBUTE_UNUSED, - tree type ATTRIBUTE_UNUSED, - const frange &lh ATTRIBUTE_UNUSED, - const irange &rh ATTRIBUTE_UNUSED, - relation_trio) const + tree type ATTRIBUTE_UNUSED, + const frange &lh ATTRIBUTE_UNUSED, + const irange &rh ATTRIBUTE_UNUSED, + relation_trio) const { return false; } bool range_operator::fold_range (irange &r ATTRIBUTE_UNUSED, - tree type ATTRIBUTE_UNUSED, - const frange &lh ATTRIBUTE_UNUSED, - const frange &rh ATTRIBUTE_UNUSED, - relation_trio) const + tree type ATTRIBUTE_UNUSED, + const frange &lh ATTRIBUTE_UNUSED, + const frange &rh ATTRIBUTE_UNUSED, + relation_trio) const { return false; } @@ -142,10 +142,10 @@ range_operator::fold_range (frange &r ATTRIBUTE_UNUSED, bool range_operator::op1_range (frange &r ATTRIBUTE_UNUSED, - tree type ATTRIBUTE_UNUSED, - const frange &lhs ATTRIBUTE_UNUSED, - const frange &op2 ATTRIBUTE_UNUSED, - relation_trio) const + tree type ATTRIBUTE_UNUSED, + const frange &lhs ATTRIBUTE_UNUSED, + const frange &op2 ATTRIBUTE_UNUSED, + relation_trio) const { return false; } @@ -162,56 +162,56 @@ range_operator::op1_range (frange &r ATTRIBUTE_UNUSED, bool range_operator::op2_range (frange &r ATTRIBUTE_UNUSED, - tree type ATTRIBUTE_UNUSED, - const frange &lhs ATTRIBUTE_UNUSED, - const frange &op1 ATTRIBUTE_UNUSED, - relation_trio) const + tree type ATTRIBUTE_UNUSED, + const frange &lhs ATTRIBUTE_UNUSED, + const frange &op1 ATTRIBUTE_UNUSED, + relation_trio) const { return false; } bool range_operator::op2_range (frange &r ATTRIBUTE_UNUSED, - tree type ATTRIBUTE_UNUSED, - const irange &lhs ATTRIBUTE_UNUSED, - const frange &op1 ATTRIBUTE_UNUSED, - relation_trio) const + tree type ATTRIBUTE_UNUSED, + const irange &lhs ATTRIBUTE_UNUSED, + const frange &op1 ATTRIBUTE_UNUSED, + relation_trio) const { return false; } relation_kind range_operator::lhs_op1_relation (const frange &lhs ATTRIBUTE_UNUSED, - const frange &op1 ATTRIBUTE_UNUSED, - const frange &op2 ATTRIBUTE_UNUSED, - relation_kind) const + const frange &op1 ATTRIBUTE_UNUSED, + const frange &op2 ATTRIBUTE_UNUSED, + relation_kind) const { return VREL_VARYING; } relation_kind range_operator::lhs_op1_relation (const irange &lhs ATTRIBUTE_UNUSED, - const frange &op1 ATTRIBUTE_UNUSED, - const frange &op2 ATTRIBUTE_UNUSED, - relation_kind) const + const frange &op1 ATTRIBUTE_UNUSED, + const frange &op2 ATTRIBUTE_UNUSED, + relation_kind) const { return VREL_VARYING; } relation_kind range_operator::lhs_op2_relation (const irange &lhs ATTRIBUTE_UNUSED, - const frange &op1 ATTRIBUTE_UNUSED, - const frange &op2 ATTRIBUTE_UNUSED, - relation_kind) const + const frange &op1 ATTRIBUTE_UNUSED, + const frange &op2 ATTRIBUTE_UNUSED, + relation_kind) const { return VREL_VARYING; } relation_kind range_operator::lhs_op2_relation (const frange &lhs ATTRIBUTE_UNUSED, - const frange &op1 ATTRIBUTE_UNUSED, - const frange &op2 ATTRIBUTE_UNUSED, - relation_kind) const + const frange &op1 ATTRIBUTE_UNUSED, + const frange &op2 ATTRIBUTE_UNUSED, + relation_kind) const { return VREL_VARYING; } @@ -675,9 +675,9 @@ operator_equal::fold_range (irange &r, tree type, bool operator_equal::op1_range (frange &r, tree type, - const irange &lhs, - const frange &op2, - relation_trio trio) const + const irange &lhs, + const frange &op2, + relation_trio trio) const { relation_kind rel = trio.op1_op2 (); switch (get_bool_state (r, lhs, type)) @@ -1871,10 +1871,10 @@ public: bool foperator_unordered_gt::op1_range (frange &r, - tree type, - const irange &lhs, - const frange &op2, - relation_trio) const + tree type, + const irange &lhs, + const frange &op2, + relation_trio) const { switch (get_bool_state (r, lhs, type)) { @@ -2899,36 +2899,296 @@ private: } } fop_div; +bool +operator_cast::fold_range (frange &r, tree type, const frange &op1, + const frange &, relation_trio) const +{ + REAL_VALUE_TYPE lb, ub; + enum machine_mode mode = TYPE_MODE (type); + bool mode_composite = MODE_COMPOSITE_P (mode); + + if (empty_range_varying (r, type, op1, op1)) + return true; + if (!MODE_HAS_NANS (mode) && op1.maybe_isnan ()) + { + r.set_varying (type); + return true; + } + if (op1.known_isnan ()) + { + r.set_nan (type); + return true; + } + + const REAL_VALUE_TYPE &lh_lb = op1.lower_bound (); + const REAL_VALUE_TYPE &lh_ub = op1.upper_bound (); + real_convert (&lb, mode, &lh_lb); + real_convert (&ub, mode, &lh_ub); + + if (flag_rounding_math) + { + if (real_less (&lh_lb, &lb)) + { + if (mode_composite + && (real_isdenormal (&lb, mode) || real_iszero (&lb))) + { + // IBM extended denormals only have DFmode precision. + REAL_VALUE_TYPE tmp, tmp2; + real_convert (&tmp2, DFmode, &lh_lb); + real_nextafter (&tmp, REAL_MODE_FORMAT (DFmode), &tmp2, + &dconstninf); + real_convert (&lb, mode, &tmp); + } + else + frange_nextafter (mode, lb, dconstninf); + } + if (real_less (&ub, &lh_ub)) + { + if (mode_composite + && (real_isdenormal (&ub, mode) || real_iszero (&ub))) + { + // IBM extended denormals only have DFmode precision. + REAL_VALUE_TYPE tmp, tmp2; + real_convert (&tmp2, DFmode, &lh_ub); + real_nextafter (&tmp, REAL_MODE_FORMAT (DFmode), &tmp2, + &dconstinf); + real_convert (&ub, mode, &tmp); + } + else + frange_nextafter (mode, ub, dconstinf); + } + } + + r.set (type, lb, ub, op1.get_nan_state ()); + + if (flag_trapping_math + && MODE_HAS_INFINITIES (TYPE_MODE (type)) + && r.known_isinf () + && !op1.known_isinf ()) + { + REAL_VALUE_TYPE inf = r.lower_bound (); + if (real_isneg (&inf)) + { + REAL_VALUE_TYPE min = real_min_representable (type); + r.set (type, inf, min); + } + else + { + REAL_VALUE_TYPE max = real_max_representable (type); + r.set (type, max, inf); + } + } + + r.flush_denormals_to_zero (); + return true; +} + +// Implement fold for a cast from float to another float. +bool +operator_cast::op1_range (frange &r, tree type, const frange &lhs, + const frange &op2, relation_trio) const +{ + if (lhs.undefined_p ()) + return false; + tree lhs_type = lhs.type (); + enum machine_mode mode = TYPE_MODE (type); + enum machine_mode lhs_mode = TYPE_MODE (lhs_type); + frange wlhs; + bool rm; + if (REAL_MODE_FORMAT (mode)->ieee_bits + && REAL_MODE_FORMAT (lhs_mode)->ieee_bits + && (REAL_MODE_FORMAT (lhs_mode)->ieee_bits + >= REAL_MODE_FORMAT (mode)->ieee_bits) + && pow2p_hwi (REAL_MODE_FORMAT (mode)->ieee_bits)) + { + /* If the cast is widening from IEEE exchange mode to + wider exchange mode or extended mode, no need to extend + the range on reverse operation. */ + rm = false; + wlhs = lhs; + } + else + { + rm = true; + wlhs = float_widen_lhs_range (lhs_type, lhs); + } + auto save_flag_rounding_math = flag_rounding_math; + flag_rounding_math = rm; + bool ret = float_binary_op_range_finish (fold_range (r, type, wlhs, op2), + r, type, lhs); + flag_rounding_math = save_flag_rounding_math; + return ret; +} + // Implement fold for a cast from float to an int. bool -operator_cast::fold_range (irange &, tree, const frange &, +operator_cast::fold_range (irange &r, tree type, const frange &op1, const irange &, relation_trio) const { - return false; + if (empty_range_varying (r, type, op1, op1)) + return true; + if (op1.maybe_isnan () || op1.maybe_isinf ()) + { + r.set_varying (type); + return true; + } + REAL_VALUE_TYPE lb, ub; + real_trunc (&lb, VOIDmode, &op1.lower_bound ()); + real_trunc (&ub, VOIDmode, &op1.upper_bound ()); + REAL_VALUE_TYPE l, u; + l = real_value_from_int_cst (NULL_TREE, TYPE_MIN_VALUE (type)); + if (real_less (&lb, &l)) + { + r.set_varying (type); + return true; + } + u = real_value_from_int_cst (NULL_TREE, TYPE_MAX_VALUE (type)); + if (real_less (&u, &ub)) + { + r.set_varying (type); + return true; + } + bool fail = false; + wide_int wlb = real_to_integer (&lb, &fail, TYPE_PRECISION (type)); + wide_int wub = real_to_integer (&ub, &fail, TYPE_PRECISION (type)); + if (fail) + { + r.set_varying (type); + return true; + } + r.set (type, wlb, wub); + return true; } // Implement op1_range for a cast from float to an int. bool -operator_cast::op1_range (frange &, tree, const irange &, - const irange &, relation_trio) const +operator_cast::op1_range (frange &r, tree type, const irange &lhs, + const frange &, relation_trio) const { - return false; + if (lhs.undefined_p ()) + return false; + REAL_VALUE_TYPE lb, lbo, ub, ubo; + wide_int lhs_lb = lhs.lower_bound (); + wide_int lhs_ub = lhs.upper_bound (); + tree lhs_type = lhs.type (); + enum machine_mode mode = TYPE_MODE (type); + real_from_integer (&lbo, VOIDmode, lhs_lb, TYPE_SIGN (lhs_type)); + real_from_integer (&ubo, VOIDmode, lhs_ub, TYPE_SIGN (lhs_type)); + real_convert (&lb, mode, &lbo); + real_convert (&ub, mode, &ubo); + if (real_identical (&lb, &lbo)) + { + /* If low bound is exactly representable in type, + use nextafter (lb - 1., +inf). */ + real_arithmetic (&lb, PLUS_EXPR, &lbo, &dconstm1); + real_convert (&lb, mode, &lb); + if (!real_identical (&lb, &lbo)) + frange_nextafter (mode, lb, dconstinf); + if (real_identical (&lb, &lbo)) + frange_nextafter (mode, lb, dconstninf); + } + else if (real_less (&lbo, &lb)) + frange_nextafter (mode, lb, dconstninf); + if (real_identical (&ub, &ubo)) + { + /* If upper bound is exactly representable in type, + use nextafter (ub + 1., -inf). */ + real_arithmetic (&ub, PLUS_EXPR, &ubo, &dconst1); + real_convert (&ub, mode, &ub); + if (!real_identical (&ub, &ubo)) + frange_nextafter (mode, ub, dconstninf); + if (real_identical (&ub, &ubo)) + frange_nextafter (mode, ub, dconstinf); + } + else if (real_less (&ub, &ubo)) + frange_nextafter (mode, ub, dconstinf); + r.set (type, lb, ub, nan_state (false)); + return true; } // Implement fold for a cast from int to a float. bool -operator_cast::fold_range (frange &, tree, const irange &, +operator_cast::fold_range (frange &r, tree type, const irange &op1, const frange &, relation_trio) const { - return false; + if (empty_range_varying (r, type, op1, op1)) + return true; + REAL_VALUE_TYPE lb, ub; + wide_int op1_lb = op1.lower_bound (); + wide_int op1_ub = op1.upper_bound (); + tree op1_type = op1.type (); + enum machine_mode mode = flag_rounding_math ? VOIDmode : TYPE_MODE (type); + real_from_integer (&lb, mode, op1_lb, TYPE_SIGN (op1_type)); + real_from_integer (&ub, mode, op1_ub, TYPE_SIGN (op1_type)); + if (flag_rounding_math) + { + REAL_VALUE_TYPE lbo = lb, ubo = ub; + mode = TYPE_MODE (type); + real_convert (&lb, mode, &lb); + real_convert (&ub, mode, &ub); + if (real_less (&lbo, &lb)) + frange_nextafter (mode, lb, dconstninf); + if (real_less (&ub, &ubo)) + frange_nextafter (mode, ub, dconstinf); + } + r.set (type, lb, ub, nan_state (false)); + frange_drop_infs (r, type); + if (r.undefined_p ()) + r.set_varying (type); + return true; } // Implement op1_range for a cast from int to a float. bool -operator_cast::op1_range (irange &, tree, const frange &, - const frange &, relation_trio) const +operator_cast::op1_range (irange &r, tree type, const frange &lhs, + const irange &, relation_trio) const { - return false; + if (lhs.undefined_p ()) + return false; + if (lhs.known_isnan ()) + { + r.set_varying (type); + return true; + } + REAL_VALUE_TYPE lb = lhs.lower_bound (); + REAL_VALUE_TYPE ub = lhs.upper_bound (); + enum machine_mode mode = TYPE_MODE (lhs.type ()); + frange_nextafter (mode, lb, dconstninf); + frange_nextafter (mode, ub, dconstinf); + if (flag_rounding_math) + { + real_floor (&lb, mode, &lb); + real_ceil (&ub, mode, &ub); + } + else + { + real_trunc (&lb, mode, &lb); + real_trunc (&ub, mode, &ub); + } + REAL_VALUE_TYPE l, u; + wide_int wlb, wub; + l = real_value_from_int_cst (NULL_TREE, TYPE_MIN_VALUE (type)); + if (real_less (&lb, &l)) + wlb = wi::min_value (TYPE_PRECISION (type), TYPE_SIGN (type)); + else + { + bool fail = false; + wlb = real_to_integer (&lb, &fail, TYPE_PRECISION (type)); + if (fail) + wlb = wi::min_value (TYPE_PRECISION (type), TYPE_SIGN (type)); + } + u = real_value_from_int_cst (NULL_TREE, TYPE_MAX_VALUE (type)); + if (real_less (&u, &ub)) + wub = wi::max_value (TYPE_PRECISION (type), TYPE_SIGN (type)); + else + { + bool fail = false; + wub = real_to_integer (&ub, &fail, TYPE_PRECISION (type)); + if (fail) + wub = wi::max_value (TYPE_PRECISION (type), TYPE_SIGN (type)); + } + r.set (type, wlb, wub); + return true; } // Initialize any float operators to the primary table diff --git a/gcc/range-op-mixed.h b/gcc/range-op-mixed.h index 3fb7bff..f8f1830 100644 --- a/gcc/range-op-mixed.h +++ b/gcc/range-op-mixed.h @@ -473,14 +473,15 @@ public: bool fold_range (prange &r, tree type, const irange &op1, const prange &op2, relation_trio rel = TRIO_VARYING) const final override; + bool fold_range (frange &r, tree type, + const frange &op1, const frange &op2, + relation_trio = TRIO_VARYING) const final override; bool fold_range (irange &r, tree type, - const frange &lh, - const irange &rh, - relation_trio = TRIO_VARYING) const; + const frange &op1, const irange &op2, + relation_trio = TRIO_VARYING) const final override; bool fold_range (frange &r, tree type, - const irange &lh, - const frange &rh, - relation_trio = TRIO_VARYING) const; + const irange &op1, const frange &op2, + relation_trio = TRIO_VARYING) const final override; bool op1_range (irange &r, tree type, const irange &lhs, const irange &op2, @@ -495,13 +496,14 @@ public: const irange &lhs, const prange &op2, relation_trio rel = TRIO_VARYING) const final override; bool op1_range (frange &r, tree type, - const irange &lhs, - const irange &op2, - relation_trio = TRIO_VARYING) const; + const frange &lhs, const frange &op2, + relation_trio = TRIO_VARYING) const final override; + bool op1_range (frange &r, tree type, + const irange &lhs, const frange &op2, + relation_trio = TRIO_VARYING) const final override; bool op1_range (irange &r, tree type, - const frange &lhs, - const frange &op2, - relation_trio = TRIO_VARYING) const; + const frange &lhs, const irange &op2, + relation_trio = TRIO_VARYING) const final override; relation_kind lhs_op1_relation (const irange &lhs, const irange &op1, const irange &op2, diff --git a/gcc/range-op.cc b/gcc/range-op.cc index e2b9c82..0a3f0b6 100644 --- a/gcc/range-op.cc +++ b/gcc/range-op.cc @@ -97,6 +97,8 @@ range_op_table::range_op_table () set (INTEGER_CST, op_cst); set (NOP_EXPR, op_cast); set (CONVERT_EXPR, op_cast); + set (FLOAT_EXPR, op_cast); + set (FIX_TRUNC_EXPR, op_cast); set (PLUS_EXPR, op_plus); set (ABS_EXPR, op_abs); set (MINUS_EXPR, op_minus); @@ -165,7 +167,7 @@ dispatch_trio (unsigned lhs, unsigned op1, unsigned op2) // of the routines in range_operator. Note the last 3 characters are // shorthand for the LHS, OP1, and OP2 range discriminator class. // Reminder, single operand instructions use the LHS type for op2, even if -// unused. so FLOAT = INT would be RO_FIF. +// unused. So FLOAT = INT would be RO_FIF. const unsigned RO_III = dispatch_trio (VR_IRANGE, VR_IRANGE, VR_IRANGE); const unsigned RO_IFI = dispatch_trio (VR_IRANGE, VR_FRANGE, VR_IRANGE); @@ -298,10 +300,10 @@ range_op_handler::op1_range (vrange &r, tree type, return m_operator->op1_range (as_a <irange> (r), type, as_a <irange> (lhs), as_a <irange> (op2), rel); - case RO_IFF: + case RO_IFI: return m_operator->op1_range (as_a <irange> (r), type, as_a <frange> (lhs), - as_a <frange> (op2), rel); + as_a <irange> (op2), rel); case RO_PPP: return m_operator->op1_range (as_a <prange> (r), type, as_a <prange> (lhs), @@ -322,10 +324,6 @@ range_op_handler::op1_range (vrange &r, tree type, return m_operator->op1_range (as_a <frange> (r), type, as_a <irange> (lhs), as_a <frange> (op2), rel); - case RO_FII: - return m_operator->op1_range (as_a <frange> (r), type, - as_a <irange> (lhs), - as_a <irange> (op2), rel); case RO_FFF: return m_operator->op1_range (as_a <frange> (r), type, as_a <frange> (lhs), @@ -778,21 +776,14 @@ range_operator::fold_range (irange &r, tree type, bool range_operator::fold_range (frange &, tree, const irange &, - const frange &, relation_trio) const + const frange &, relation_trio) const { return false; } bool range_operator::op1_range (irange &, tree, const frange &, - const frange &, relation_trio) const -{ - return false; -} - -bool -range_operator::op1_range (frange &, tree, const irange &, - const irange &, relation_trio) const + const irange &, relation_trio) const { return false; } @@ -855,10 +846,13 @@ range_operator::op1_op2_relation (const irange &lhs ATTRIBUTE_UNUSED, bool range_operator::op1_op2_relation_effect (irange &lhs_range ATTRIBUTE_UNUSED, - tree type ATTRIBUTE_UNUSED, - const irange &op1_range ATTRIBUTE_UNUSED, - const irange &op2_range ATTRIBUTE_UNUSED, - relation_kind rel ATTRIBUTE_UNUSED) const + tree type ATTRIBUTE_UNUSED, + const irange &op1_range + ATTRIBUTE_UNUSED, + const irange &op2_range + ATTRIBUTE_UNUSED, + relation_kind rel + ATTRIBUTE_UNUSED) const { return false; } @@ -874,7 +868,7 @@ range_operator::overflow_free_p (const irange &, const irange &, void range_operator::update_bitmask (irange &, const irange &, - const irange &) const + const irange &) const { } @@ -1815,7 +1809,7 @@ operator_plus::wi_fold (irange &r, tree type, static relation_kind plus_minus_ranges (irange &r_ov, irange &r_normal, const irange &offset, - bool add_p) + bool add_p) { relation_kind kind = VREL_VARYING; // For now, only deal with constant adds. This could be extended to ranges @@ -3349,9 +3343,9 @@ wi_optimize_signed_bitwise_op (irange &r, tree type, relation_kind operator_bitwise_and::lhs_op1_relation (const irange &lhs, - const irange &op1, - const irange &op2, - relation_kind) const + const irange &op1, + const irange &op2, + relation_kind) const { if (lhs.undefined_p () || op1.undefined_p () || op2.undefined_p ()) return VREL_VARYING; diff --git a/gcc/range-op.h b/gcc/range-op.h index 1075786..9e0e651 100644 --- a/gcc/range-op.h +++ b/gcc/range-op.h @@ -152,10 +152,6 @@ public: relation_trio = TRIO_VARYING) const; virtual bool op1_range (irange &r, tree type, const frange &lhs, - const frange &op2, - relation_trio = TRIO_VARYING) const; - virtual bool op1_range (frange &r, tree type, - const irange &lhs, const irange &op2, relation_trio = TRIO_VARYING) const; diff --git a/gcc/real.cc b/gcc/real.cc index b64bad0..95a9332 100644 --- a/gcc/real.cc +++ b/gcc/real.cc @@ -2230,7 +2230,6 @@ real_from_integer (REAL_VALUE_TYPE *r, format_helper fmt, { unsigned int len = val_in.get_precision (); int i, j, e = 0; - int maxbitlen = MAX_BITSIZE_MODE_ANY_INT + HOST_BITS_PER_WIDE_INT; const unsigned int realmax = (SIGNIFICAND_BITS / HOST_BITS_PER_WIDE_INT * HOST_BITS_PER_WIDE_INT); @@ -2238,12 +2237,6 @@ real_from_integer (REAL_VALUE_TYPE *r, format_helper fmt, r->cl = rvc_normal; r->sign = wi::neg_p (val_in, sgn); - /* We have to ensure we can negate the largest negative number. */ - wide_int val = wide_int::from (val_in, maxbitlen, sgn); - - if (r->sign) - val = -val; - /* Ensure a multiple of HOST_BITS_PER_WIDE_INT, ceiling, as elt won't work with precisions that are not a multiple of HOST_BITS_PER_WIDE_INT. */ @@ -2252,7 +2245,13 @@ real_from_integer (REAL_VALUE_TYPE *r, format_helper fmt, /* Ensure we can represent the largest negative number. */ len += 1; - len = len/HOST_BITS_PER_WIDE_INT * HOST_BITS_PER_WIDE_INT; + len = len / HOST_BITS_PER_WIDE_INT * HOST_BITS_PER_WIDE_INT; + + /* We have to ensure we can negate the largest negative number. */ + wide_int val = wide_int::from (val_in, len, sgn); + + if (r->sign) + val = -val; /* Cap the size to the size allowed by real.h. */ if (len > realmax) @@ -2260,14 +2259,18 @@ real_from_integer (REAL_VALUE_TYPE *r, format_helper fmt, HOST_WIDE_INT cnt_l_z; cnt_l_z = wi::clz (val); - if (maxbitlen - cnt_l_z > realmax) + if (len - cnt_l_z > realmax) { - e = maxbitlen - cnt_l_z - realmax; + e = len - cnt_l_z - realmax; /* This value is too large, we must shift it right to preserve all the bits we can, and then bump the - exponent up by that amount. */ - val = wi::lrshift (val, e); + exponent up by that amount, but or in 1 if any of + the shifted out bits are non-zero. */ + if (wide_int::from (val, e, UNSIGNED) != 0) + val = wi::set_bit (wi::lrshift (val, e), 0); + else + val = wi::lrshift (val, e); } len = realmax; } diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 905bbb0..bd49936 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,250 @@ +2025-06-04 Kugan Vivekanandarajah <kvivekananda@nvidia.com> + + * gcc.dg/tree-prof/clone-merge-1.c: New test. + +2025-06-04 Jason Merrill <jason@redhat.com> + + PR c++/120502 + * g++.dg/cpp2a/constexpr-prvalue2.C: New test. + +2025-06-04 Andrew Pinski <quic_apinski@quicinc.com> + + PR tree-optimization/14295 + PR tree-optimization/108358 + PR tree-optimization/114169 + * gcc.dg/tree-ssa/20031106-6.c: Un-xfail. Add scan for forwprop1. + * g++.dg/opt/pr66119.C: Disable forwprop since that does + the copy prop now. + * gcc.dg/tree-ssa/pr108358-a.c: New test. + * gcc.dg/tree-ssa/pr114169-1.c: New test. + * gcc.c-torture/execute/builtins/pr22237-1-lib.c: New test. + * gcc.c-torture/execute/builtins/pr22237-1.c: New test. + * gcc.dg/tree-ssa/pr57361.c: Disable forwprop1. + * gcc.dg/tree-ssa/pr57361-1.c: New test. + +2025-06-04 Pengfei Li <Pengfei.Li2@arm.com> + + * gcc.target/aarch64/acle/uhadd_1.c: New test. + +2025-06-04 Jakub Jelinek <jakub@redhat.com> + + PR tree-optimization/120231 + * gcc.dg/tree-ssa/pr120231-1.c: New test. + +2025-06-04 Dongyan Chen <chendongyan@isrc.iscas.ac.cn> + + * gcc.target/riscv/arch-60.c: New test. + +2025-06-04 Richard Sandiford <richard.sandiford@arm.com> + + PR rtl-optimization/120447 + * gcc.dg/pr120447.c: New test. + +2025-06-04 H.J. Lu <hjl.tools@gmail.com> + + PR debug/120525 + * gcc.dg/pr120525.c: New test. + +2025-06-04 Andre Vehreschild <vehre@gcc.gnu.org> + + PR fortran/120483 + * gfortran.dg/save_8.f90: New test. + +2025-06-04 Jiawei <jiawei@iscas.ac.cn> + + * gcc.target/riscv/arch-shlocofideleg.c: New test. + +2025-06-04 Hu, Lin1 <lin1.hu@intel.com> + + * gcc.target/i386/pr49095-2.c: New test. + +2025-06-04 Hu, Lin1 <lin1.hu@intel.com> + + * gcc.target/i386/pr79173-13.c: New test. + * gcc.target/i386/pr79173-14.c: Ditto. + * gcc.target/i386/pr79173-15.c: Ditto. + * gcc.target/i386/pr79173-16.c: Ditto. + * gcc.target/i386/pr79173-17.c: Ditto. + * gcc.target/i386/pr79173-18.c: Ditto. + +2025-06-03 Harald Anlauf <anlauf@gmx.de> + + PR fortran/99838 + * gfortran.dg/coarray_data_2.f90: New test. + +2025-06-03 Martin Uecker <uecker@tugraz.at> + + PR c/120078 + * gcc.dg/Wjump-misses-init-3.c: New test. + +2025-06-03 Martin Uecker <uecker@tugraz.at> + + * gcc.dg/gnu23-tag-composite-6.c: Update. + +2025-06-03 Martin Uecker <uecker@tugraz.at> + + PR c/116892 + * gcc.dg/pr116892.c: New test. + +2025-06-03 Jason Merrill <jason@redhat.com> + + * g++.dg/modules/cpp-1.C + * g++.dg/modules/cpp-3.C + * g++.dg/modules/cpp-4.C: Specify -fno-modules. + +2025-06-03 Pan Li <pan2.li@intel.com> + + * gcc.target/riscv/rvv/autovec/binop/vdiv-rv32gcv-nofm.c: Adjust + the asm check for vdiv. + * gcc.target/riscv/rvv/autovec/binop/vdiv-rv32gcv.c: Ditto. + * gcc.target/riscv/rvv/autovec/binop/vdiv-rv64gcv-nofm.c: Ditto. + * gcc.target/riscv/rvv/autovec/binop/vdiv-rv64gcv.c: Ditto. + +2025-06-03 Pan Li <pan2.li@intel.com> + + * gcc.target/riscv/rvv/autovec/vx_vf/vx-4-i16.c: Add asm check + check for vdiv.vx combine. + * gcc.target/riscv/rvv/autovec/vx_vf/vx-4-i32.c: Ditto. + * gcc.target/riscv/rvv/autovec/vx_vf/vx-4-i64.c: Ditto. + * gcc.target/riscv/rvv/autovec/vx_vf/vx-4-i8.c: Ditto. + * gcc.target/riscv/rvv/autovec/vx_vf/vx-5-i16.c: Ditto. + * gcc.target/riscv/rvv/autovec/vx_vf/vx-5-i32.c: Ditto. + * gcc.target/riscv/rvv/autovec/vx_vf/vx-5-i64.c: Ditto. + * gcc.target/riscv/rvv/autovec/vx_vf/vx-5-i8.c: Ditto. + * gcc.target/riscv/rvv/autovec/vx_vf/vx-6-i16.c: Ditto. + * gcc.target/riscv/rvv/autovec/vx_vf/vx-6-i32.c: Ditto. + * gcc.target/riscv/rvv/autovec/vx_vf/vx-6-i64.c: Ditto. + * gcc.target/riscv/rvv/autovec/vx_vf/vx-6-i8.c: Ditto. + +2025-06-03 Pan Li <pan2.li@intel.com> + + * gcc.target/riscv/rvv/autovec/vx_vf/vx-1-i16.c: Add asm check + for vdiv.vx combine. + * gcc.target/riscv/rvv/autovec/vx_vf/vx-1-i32.c: Ditto. + * gcc.target/riscv/rvv/autovec/vx_vf/vx-1-i64.c: Ditto. + * gcc.target/riscv/rvv/autovec/vx_vf/vx-1-i8.c: Ditto. + * gcc.target/riscv/rvv/autovec/vx_vf/vx-2-i16.c: Ditto. + * gcc.target/riscv/rvv/autovec/vx_vf/vx-2-i32.c: Ditto. + * gcc.target/riscv/rvv/autovec/vx_vf/vx-2-i64.c: Ditto. + * gcc.target/riscv/rvv/autovec/vx_vf/vx-2-i8.c: Ditto. + * gcc.target/riscv/rvv/autovec/vx_vf/vx-3-i16.c: Ditto. + * gcc.target/riscv/rvv/autovec/vx_vf/vx-3-i32.c: Ditto. + * gcc.target/riscv/rvv/autovec/vx_vf/vx-3-i64.c: Ditto. + * gcc.target/riscv/rvv/autovec/vx_vf/vx-3-i8.c: Ditto. + * gcc.target/riscv/rvv/autovec/vx_vf/vx_binary_data.h: Add test + data for vdiv run test. + * gcc.target/riscv/rvv/autovec/vx_vf/vx_vdiv-run-1-i16.c: New test. + * gcc.target/riscv/rvv/autovec/vx_vf/vx_vdiv-run-1-i32.c: New test. + * gcc.target/riscv/rvv/autovec/vx_vf/vx_vdiv-run-1-i64.c: New test. + * gcc.target/riscv/rvv/autovec/vx_vf/vx_vdiv-run-1-i8.c: New test. + +2025-06-03 Paul-Antoine Arras <parras@baylibre.com> + + PR target/119100 + * gcc.target/riscv/rvv/autovec/vx_vf/vf-1-f16.c: New test. + * gcc.target/riscv/rvv/autovec/vx_vf/vf-1-f32.c: New test. + * gcc.target/riscv/rvv/autovec/vx_vf/vf-1-f64.c: New test. + * gcc.target/riscv/rvv/autovec/vx_vf/vf-2-f16.c: New test. + * gcc.target/riscv/rvv/autovec/vx_vf/vf-2-f32.c: New test. + * gcc.target/riscv/rvv/autovec/vx_vf/vf-2-f64.c: New test. + * gcc.target/riscv/rvv/autovec/vx_vf/vf-3-f16.c: New test. + * gcc.target/riscv/rvv/autovec/vx_vf/vf-3-f32.c: New test. + * gcc.target/riscv/rvv/autovec/vx_vf/vf-3-f64.c: New test. + * gcc.target/riscv/rvv/autovec/vx_vf/vf-4-f16.c: New test. + * gcc.target/riscv/rvv/autovec/vx_vf/vf-4-f32.c: New test. + * gcc.target/riscv/rvv/autovec/vx_vf/vf-4-f64.c: New test. + * gcc.target/riscv/rvv/autovec/vx_vf/vf_mulop.h: New test. + * gcc.target/riscv/rvv/autovec/vx_vf/vf_mulop_data.h: New test. + * gcc.target/riscv/rvv/autovec/vx_vf/vf_mulop_run.h: New test. + * gcc.target/riscv/rvv/autovec/vx_vf/vf_vfmadd-run-1-f16.c: New test. + * gcc.target/riscv/rvv/autovec/vx_vf/vf_vfmadd-run-1-f32.c: New test. + * gcc.target/riscv/rvv/autovec/vx_vf/vf_vfmadd-run-1-f64.c: New test. + * gcc.target/riscv/rvv/autovec/vx_vf/vf_vfmsub-run-1-f16.c: New test. + * gcc.target/riscv/rvv/autovec/vx_vf/vf_vfmsub-run-1-f32.c: New test. + * gcc.target/riscv/rvv/autovec/vx_vf/vf_vfmsub-run-1-f64.c: New test. + +2025-06-03 H.J. Lu <hjl.tools@gmail.com> + + PR target/103750 + * g++.target/i386/pr103750.C: New test. + +2025-06-03 Andrew Pinski <quic_apinski@quicinc.com> + + PR tree-optimization/116824 + * gcc.dg/tree-ssa/phiprop-2.c: New test. + +2025-06-03 Andrew Pinski <quic_apinski@quicinc.com> + + PR tree-optimization/120451 + * gcc.dg/tree-ssa/cswtch-6.c: New test. + +2025-06-02 Alexandre Oliva <oliva@adacore.com> + + PR rtl-optimization/120424 + PR middle-end/118939 + * g++.target/arm/pr120424.C: New. + * gnat.dg/controlled9.adb: New. + * gnat.dg/controlled9_pkg.ads: New. + +2025-06-02 Jason Merrill <jason@redhat.com> + + PR c++/107600 + * g++.dg/ext/is_destructible2.C: Add more cases. + +2025-06-02 Dongyan Chen <chendongyan@isrc.iscas.ac.cn> + + * gcc.target/riscv/arch-59.c: New test. + +2025-06-02 Jason Merrill <jason@redhat.com> + + PR c++/120506 + * g++.dg/cpp2a/constinit21.C: New test. + +2025-06-02 Iain Sandoe <iain@sandoe.co.uk> + + PR c++/118903 + * g++.dg/coroutines/pr118903.C: New test. + +2025-06-02 Jason Merrill <jason@redhat.com> + + PR c++/107600 + * g++.dg/ext/is_destructible2.C: New test. + +2025-06-02 Jason Merrill <jason@redhat.com> + + PR c++/107600 + * g++.dg/ext/has_trivial_destructor-3.C: New test. + +2025-06-02 Stafford Horne <shorne@gmail.com> + + * gcc.target/or1k/return-2.c: Fix test. + +2025-06-02 Stafford Horne <shorne@gmail.com> + + * gcc.target/or1k/call-1.c: New test. + * gcc.target/or1k/got-1.c: New test. + +2025-06-02 Christophe Lyon <christophe.lyon@linaro.org> + + * lib/target-supports.exp (check_effective_target_tls_link): New. + * g++.dg/tls/pr102496-1.C: Require tls_link. + * g++.dg/tls/pr77285-1.C: Likewise. + +2025-06-02 Sandra Loosemore <sloosemore@baylibre.com> + + * c-c++-common/gomp/declare-variant-2.c: Update expected output. + * c-c++-common/gomp/metadirective-condition-constexpr.c: New. + * c-c++-common/gomp/metadirective-condition.c: New. + * c-c++-common/gomp/metadirective-error-recovery.c: Update expected + output. + * g++.dg/gomp/metadirective-condition-class.C: New. + * g++.dg/gomp/metadirective-condition-template.C: New. + +2025-06-02 Liao Shihua <shihua@iscas.ac.cn> + + * gcc.target/riscv/rvv/autovec/param-autovec-mode.c: Change + `autovec-mode` to `riscv-autovec-mode` in dg-options. + 2025-06-01 Jerry DeLisle <jvdelisle@gcc.gnu.org> PR libfortran/119856 diff --git a/gcc/testsuite/g++.dg/cpp0x/alias-decl-80.C b/gcc/testsuite/g++.dg/cpp0x/alias-decl-80.C new file mode 100644 index 0000000..9c0eadc --- /dev/null +++ b/gcc/testsuite/g++.dg/cpp0x/alias-decl-80.C @@ -0,0 +1,21 @@ +// PR c++/120224 +// { dg-do compile { target c++11 } } + +template<class> using void_t = void; + +template<class T> +void f(void*); // #1 + +template<class T> +void f(void_t<typename T::type>*) { } // { dg-error "not a class" } defn of #1 + +template<class T> +void g(int, void*); // #2 + +template<class T> +void g(int, void_t<typename T::type>*) { } // { dg-error "not a class" } defn of #2 + +int main() { + f<int>(0); // { dg-error "no match" } + g<int>(0, 0); // { dg-error "no match" } +} diff --git a/gcc/testsuite/g++.dg/cpp2a/constexpr-prvalue2.C b/gcc/testsuite/g++.dg/cpp2a/constexpr-prvalue2.C new file mode 100644 index 0000000..c2dc7cd --- /dev/null +++ b/gcc/testsuite/g++.dg/cpp2a/constexpr-prvalue2.C @@ -0,0 +1,26 @@ +// PR c++/120502 +// { dg-do compile { target c++20 } } +// { dg-additional-options -O } + +struct non_trivial_if { + constexpr non_trivial_if() {} +}; +struct allocator : non_trivial_if {}; +struct padding {}; +struct __short { + [[no_unique_address]] padding p; +}; +struct basic_string { + union { + __short s; + int l; + }; + [[no_unique_address]] allocator a; + constexpr basic_string() {} + ~basic_string() {} +}; +struct time_zone { + basic_string __abbrev; + long __offset; +}; +time_zone convert_to_time_zone() { return {}; } diff --git a/gcc/testsuite/g++.dg/modules/cpp-1.C b/gcc/testsuite/g++.dg/modules/cpp-1.C index 2ad9637..56ef05fe 100644 --- a/gcc/testsuite/g++.dg/modules/cpp-1.C +++ b/gcc/testsuite/g++.dg/modules/cpp-1.C @@ -1,4 +1,5 @@ // { dg-do preprocess } +// { dg-additional-options -fno-modules } module bob; #if 1 @@ -11,4 +12,4 @@ import gru; EXPORT import mabel; int i; -// { dg-final { scan-file cpp-1.i "cpp-1.C\"\n\n\nmodule bob;\n\nexport import stuart;\n\n\n\nimport gru;\n\n import mabel;\n" } } +// { dg-final { scan-file cpp-1.i "cpp-1.C\"\n\n\n\nmodule bob;\n\nexport import stuart;\n\n\n\nimport gru;\n\n import mabel;\n" } } diff --git a/gcc/testsuite/g++.dg/modules/cpp-3.C b/gcc/testsuite/g++.dg/modules/cpp-3.C index 3aa0c6e..cd776ae 100644 --- a/gcc/testsuite/g++.dg/modules/cpp-3.C +++ b/gcc/testsuite/g++.dg/modules/cpp-3.C @@ -1,4 +1,5 @@ // { dg-do preprocess } +// { dg-additional-options -fno-modules } #define NAME(X) X; diff --git a/gcc/testsuite/g++.dg/modules/cpp-4.C b/gcc/testsuite/g++.dg/modules/cpp-4.C index 6c19431..c423de2 100644 --- a/gcc/testsuite/g++.dg/modules/cpp-4.C +++ b/gcc/testsuite/g++.dg/modules/cpp-4.C @@ -1,3 +1,4 @@ +// { dg-additional-options -fno-modules } // { dg-do preprocess } #if 1 diff --git a/gcc/testsuite/g++.dg/opt/pr66119.C b/gcc/testsuite/g++.dg/opt/pr66119.C index d1b1845..52362e4 100644 --- a/gcc/testsuite/g++.dg/opt/pr66119.C +++ b/gcc/testsuite/g++.dg/opt/pr66119.C @@ -3,7 +3,7 @@ the value of MOVE_RATIO now is. */ /* { dg-do compile { target { { i?86-*-* x86_64-*-* } && c++11 } } } */ -/* { dg-options "-O3 -mavx -fdump-tree-sra -march=slm -mtune=slm -fno-early-inlining" } */ +/* { dg-options "-O3 -mavx -fdump-tree-sra -fno-tree-forwprop -march=slm -mtune=slm -fno-early-inlining" } */ // { dg-skip-if "requires hosted libstdc++ for cstdlib malloc" { ! hostedlib } } #include <immintrin.h> diff --git a/gcc/testsuite/g++.dg/tree-ssa/loop-split-1.C b/gcc/testsuite/g++.dg/tree-ssa/loop-split-1.C index 8981006..4df85f5 100644 --- a/gcc/testsuite/g++.dg/tree-ssa/loop-split-1.C +++ b/gcc/testsuite/g++.dg/tree-ssa/loop-split-1.C @@ -6,6 +6,7 @@ #include <cmath> constexpr unsigned s = 100000000; +double d = 0.0; int main() { @@ -19,7 +20,7 @@ int main() if(i == 0) a[i] = b[i] * c[i]; else - a[i] = (b[i] + c[i]) * c[i-1] * std::log(i); + a[i] = (b[i] + c[i]) * c[i-1] * std::log(i + d); } } /* { dg-final { scan-tree-dump-times "loop split" 1 "lsplit" } } */ diff --git a/gcc/testsuite/g++.target/i386/pr103750.C b/gcc/testsuite/g++.target/i386/pr103750.C new file mode 100644 index 0000000..c82c10a --- /dev/null +++ b/gcc/testsuite/g++.target/i386/pr103750.C @@ -0,0 +1,39 @@ +/* { dg-do compile } */ +/* { dg-options "-O3 -march=x86-64-v4 -std=c++17" } */ +/* Keep labels and directives ('.cfi_startproc', '.cfi_endproc'). */ +/* { dg-final { check-function-bodies "**" "" "" { target "*-*-*" } {^\t?\.} } } */ + +#include <x86intrin.h> + +/* +**_Z8qustrchrPDsS_Ds: +**... +**.L[0-9]+: +** vpcmpeqw \(%[a-x]+\), %ymm0, %k1 +** vpcmpeqw 32\(%[a-x]+\), %ymm0, %k0 +** kortestw %k0, %k1 +** je .L[0-9]+ +**... +*/ + +const char16_t * +qustrchr(char16_t *n, char16_t *e, char16_t c) noexcept +{ + __m256i mch256 = _mm256_set1_epi16(c); + for ( ; n < e; n += 32) { + __m256i data1 = _mm256_loadu_si256(reinterpret_cast<const __m256i *>(n)); + __m256i data2 = _mm256_loadu_si256(reinterpret_cast<const __m256i *>(n) + 1); + __mmask16 mask1 = _mm256_cmpeq_epu16_mask(data1, mch256); + __mmask16 mask2 = _mm256_cmpeq_epu16_mask(data2, mch256); + if (_kortestz_mask16_u8(mask1, mask2)) + continue; + + unsigned idx = _tzcnt_u32(mask1); + if (mask1 == 0) { + idx = __tzcnt_u16(mask2); + n += 16; + } + return n + idx; + } + return e; +} diff --git a/gcc/testsuite/g++.target/i386/pr112824-2.C b/gcc/testsuite/g++.target/i386/pr112824-2.C new file mode 100644 index 0000000..036a47b --- /dev/null +++ b/gcc/testsuite/g++.target/i386/pr112824-2.C @@ -0,0 +1,10 @@ +/* PR target/112824 */ +/* { dg-do compile } */ +/* { dg-options "-std=c++23 -O3 -march=skylake-avx512 -mprefer-vector-width=512" } */ +/* { dg-final { scan-assembler-not "vmov.*\[ \\t\]+\[^\n\]*%rsp" } } */ + +#include "pr112824-1.C" + +void prod(Dual<Dual<double,8>,2> &c, const Dual<Dual<double,8>,2> &a, const Dual<Dual<double,8>,2>&b){ + c = a*b; +} diff --git a/gcc/testsuite/gcc.c-torture/execute/builtins/pr22237-1-lib.c b/gcc/testsuite/gcc.c-torture/execute/builtins/pr22237-1-lib.c new file mode 100644 index 0000000..4403235 --- /dev/null +++ b/gcc/testsuite/gcc.c-torture/execute/builtins/pr22237-1-lib.c @@ -0,0 +1,27 @@ +extern void abort (void); + +void * +memcpy (void *dst, const void *src, __SIZE_TYPE__ n) +{ + const char *srcp; + char *dstp; + + srcp = src; + dstp = dst; + + if (dst < src) + { + if (dst + n > src) + abort (); + } + else + { + if (src + n > dst) + abort (); + } + + while (n-- != 0) + *dstp++ = *srcp++; + + return dst; +} diff --git a/gcc/testsuite/gcc.c-torture/execute/builtins/pr22237-1.c b/gcc/testsuite/gcc.c-torture/execute/builtins/pr22237-1.c new file mode 100644 index 0000000..0a12b0f --- /dev/null +++ b/gcc/testsuite/gcc.c-torture/execute/builtins/pr22237-1.c @@ -0,0 +1,57 @@ +extern void abort (void); +extern void exit (int); +struct s { unsigned char a[256]; }; +union u { struct { struct s b; int c; } d; struct { int c; struct s b; } e; }; +static union u v; +static union u v0; +static struct s *p = &v.d.b; +static struct s *q = &v.e.b; + +struct outers +{ + struct s inner; +}; + +static inline struct s rp (void) { return *p; } +static inline struct s rq (void) { return *q; } +static void pq (void) +{ + struct outers o = {rq () }; + *p = o.inner; +} +static void qp (void) +{ + struct outers o = {rp () }; + *q = o.inner; +} + +static void +init (struct s *sp) +{ + int i; + for (i = 0; i < 256; i++) + sp->a[i] = i; +} + +static void +check (struct s *sp) +{ + int i; + for (i = 0; i < 256; i++) + if (sp->a[i] != i) + abort (); +} + +void +main_test (void) +{ + v = v0; + init (p); + qp (); + check (q); + v = v0; + init (q); + pq (); + check (p); + exit (0); +} diff --git a/gcc/testsuite/gcc.dg/Wjump-misses-init-3.c b/gcc/testsuite/gcc.dg/Wjump-misses-init-3.c new file mode 100644 index 0000000..c3110c4 --- /dev/null +++ b/gcc/testsuite/gcc.dg/Wjump-misses-init-3.c @@ -0,0 +1,10 @@ +/* { dg-do compile } */ +/* { dg-options "-Wc++-compat" } */ + +void f() +{ + goto skip; /* { dg-warning "jump skips variable initialization" } */ + int i = 1; +skip: ; +} + diff --git a/gcc/testsuite/gcc.dg/bitint-123.c b/gcc/testsuite/gcc.dg/bitint-123.c new file mode 100644 index 0000000..4d019a9 --- /dev/null +++ b/gcc/testsuite/gcc.dg/bitint-123.c @@ -0,0 +1,26 @@ +/* PR middle-end/120547 */ +/* { dg-do run { target bitint } } */ +/* { dg-options "-O2" } */ +/* { dg-add-options float64 } */ +/* { dg-require-effective-target float64 } */ + +#define CHECK(x, y) \ + if ((_Float64) x != (_Float64) y \ + || (_Float64) (x + 1) != (_Float64) (y + 1)) \ + __builtin_abort () + +int +main () +{ + unsigned long long a = 0x20000000000001ULL << 7; + volatile unsigned long long b = a; + CHECK (a, b); +#if __BITINT_MAXWIDTH__ >= 4096 + unsigned _BitInt(4096) c = ((unsigned _BitInt(4096)) 0x20000000000001ULL) << 253; + volatile unsigned _BitInt(4096) d = c; + CHECK (c, d); + unsigned _BitInt(4096) e = ((unsigned _BitInt(4096)) 0x20000000000001ULL) << 931; + volatile unsigned _BitInt(4096) f = e; + CHECK (e, f); +#endif +} diff --git a/gcc/testsuite/gcc.dg/gnu23-tag-composite-6.c b/gcc/testsuite/gcc.dg/gnu23-tag-composite-6.c index 2411b04..076c066 100644 --- a/gcc/testsuite/gcc.dg/gnu23-tag-composite-6.c +++ b/gcc/testsuite/gcc.dg/gnu23-tag-composite-6.c @@ -1,11 +1,31 @@ /* { dg-do compile } */ /* { dg-options "-std=gnu23" } */ +#define NEST(...) typeof(({ (__VA_ARGS__){ }; })) + int f() { typedef struct foo bar; - struct foo { typeof(({ (struct foo { bar * x; }){ }; })) * x; } *q; - typeof(q->x) p; - 1 ? p : q; + struct foo { NEST(struct foo { bar *x; }) *x; } *q; + typeof(q->x) p0; + typeof(q->x) p1; + 1 ? p0 : q; + 1 ? p1 : q; + 1 ? p0 : p1; +} + +int g() +{ + typedef struct fo2 bar; + struct fo2 { NEST(struct fo2 { NEST(struct fo2 { bar *x; }) * x; }) *x; } *q; + typeof(q->x) p0; + typeof(q->x->x) p1; + typeof(q->x->x->x) p2; + 1 ? p0 : q; + 1 ? p1 : q; + 1 ? p2 : q; + 1 ? p0 : p1; + 1 ? p2 : p1; + 1 ? p0 : p2; } diff --git a/gcc/testsuite/gcc.dg/pr116892.c b/gcc/testsuite/gcc.dg/pr116892.c new file mode 100644 index 0000000..7eb431b --- /dev/null +++ b/gcc/testsuite/gcc.dg/pr116892.c @@ -0,0 +1,11 @@ +/* { dg-do compile } */ +/* { dg-options "-g -std=gnu23" } */ + +enum fmt_type; + +void foo(const enum fmt_type a); + +enum [[gnu::packed]] fmt_type { + A +} const a; + diff --git a/gcc/testsuite/gcc.dg/pr120447.c b/gcc/testsuite/gcc.dg/pr120447.c new file mode 100644 index 0000000..bd51f9b --- /dev/null +++ b/gcc/testsuite/gcc.dg/pr120447.c @@ -0,0 +1,24 @@ +/* { dg-options "-Ofast" } */ +/* { dg-additional-options "-mcpu=neoverse-v2" { target aarch64*-*-* } } */ + +char g; +long h; +typedef struct { + void *data; +} i; +i* a; +void b(i *j, char *p2); +void c(char *d) { + d = d ? " and " : " or "; + b(a, d); +} +void b(i *j, char *p2) { + h = __builtin_strlen(p2); + while (g) + ; + int *k = j->data; + char *l = p2, *m = p2 + h; + l += 4; + while (l < m) + *k++ = *l++; +} diff --git a/gcc/testsuite/gcc.dg/pr120525.c b/gcc/testsuite/gcc.dg/pr120525.c new file mode 100644 index 0000000..5ab7a22 --- /dev/null +++ b/gcc/testsuite/gcc.dg/pr120525.c @@ -0,0 +1,22 @@ +/* { dg-do compile { target fpic } } */ +/* { dg-options "-O2 -fpic -g" } */ +/* { dg-additional-options "-m31" { target s390x-*-* } } */ + +typedef __SIZE_TYPE__ uintptr_t; +static __thread uintptr_t start_sp; +static inline uintptr_t +__thread_stack_pointer (void) +{ + return (uintptr_t) __builtin_frame_address (0); +} + +void +update_data (void) +{ + if (__builtin_expect ((!start_sp), 0)) + start_sp = __thread_stack_pointer (); + + uintptr_t sp = __thread_stack_pointer (); + if (__builtin_expect ((sp > start_sp), 0)) + start_sp = sp; +} diff --git a/gcc/testsuite/gcc.dg/tree-prof/clone-merge-1.c b/gcc/testsuite/gcc.dg/tree-prof/clone-merge-1.c new file mode 100644 index 0000000..40aab9f --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-prof/clone-merge-1.c @@ -0,0 +1,32 @@ +/* { dg-options "-O3 -fno-early-inlining -fdump-ipa-afdo-all" } */ +__attribute__ ((used)) +int a[1000]; + +__attribute__ ((noinline)) +void +test2(int sz) +{ + a[sz]++; + asm volatile (""::"m"(a)); +} + +__attribute__ ((noinline)) +void +test1 (int sz) +{ + for (int i = 0; i < 1000; i++) + if (i % 2) + test2 (sz); + else + test2 (i); + +} +int main() +{ + for (int i = 0; i < 1000; i++) + test1 (1000); + return 0; +} +/* We will have profiles for test2 and test2.constprop.0 that will have to be + merged, */ +/* { dg-final-use-autofdo { scan-ipa-dump "note: Merging profile for test2" "afdo"} } */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa/20031106-6.c b/gcc/testsuite/gcc.dg/tree-ssa/20031106-6.c index 56d1887b..c7e0088 100644 --- a/gcc/testsuite/gcc.dg/tree-ssa/20031106-6.c +++ b/gcc/testsuite/gcc.dg/tree-ssa/20031106-6.c @@ -1,5 +1,7 @@ /* { dg-do compile } */ -/* { dg-options "-O1 -fno-tree-sra -fdump-tree-optimized" } */ +/* { dg-options "-O1 -fno-tree-sra -fdump-tree-optimized -fdump-tree-forwprop1-details" } */ + +/* PR tree-optimization/14295 */ extern void link_error (void); @@ -25,4 +27,6 @@ struct s foo (struct s r) /* There should be no references to any of "temp_struct*" temporaries. */ -/* { dg-final { scan-tree-dump-times "temp_struct" 0 "optimized" { xfail *-*-* } } } */ +/* { dg-final { scan-tree-dump-times "temp_struct" 0 "optimized" } } */ +/* Also check that forwprop pass did the copy prop. */ +/* { dg-final { scan-tree-dump-times "after previous" 3 "forwprop1" } } */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa/cswtch-6.c b/gcc/testsuite/gcc.dg/tree-ssa/cswtch-6.c new file mode 100644 index 0000000..d765a03 --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa/cswtch-6.c @@ -0,0 +1,43 @@ +/* PR tree-optimization/120451 */ +/* { dg-do compile { target elf } } */ +/* { dg-options "-O2" } */ + +void foo (int, int); + +__attribute__((noinline, noclone)) void +f1 (int v, int w) +{ + int i, j; + if (w) + { + i = 129; + j = i - 1; + goto lab; + } + switch (v) + { + case 170: + j = 7; + i = 27; + break; + case 171: + i = 8; + j = 122; + break; + case 172: + i = 21; + j = -19; + break; + case 173: + i = 18; + j = 17; + break; + default: + __builtin_abort (); + } + + lab: + foo (i, j); +} + +/* { dg-final { scan-assembler ".rodata.cst16" } } */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa/ifcvt-fix-trunc-1.c b/gcc/testsuite/gcc.dg/tree-ssa/ifcvt-fix-trunc-1.c new file mode 100644 index 0000000..801a53f --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa/ifcvt-fix-trunc-1.c @@ -0,0 +1,19 @@ + /* { dg-do compile } */ + /* { dg-options "-O2 -ftree-vectorize -fdump-tree-ifcvt-stats" } */ + +void +test (int *dst, float *arr, int *pred, int n) +{ + for (int i = 0; i < n; i++) + { + int pred_i = pred[i]; + float arr_i = arr[i]; + + dst[i] = pred_i ? (int)arr_i : 5; + } +} + +/* We expect this to fail if_convertible_loop_p so long as we have no + conditional IFN for FIX_TRUNC_EXPR. */ + +/* { dg-final { scan-tree-dump-times "Applying if-conversion" 0 "ifcvt" } } */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa/ifcvt-fix-trunc-2.c b/gcc/testsuite/gcc.dg/tree-ssa/ifcvt-fix-trunc-2.c new file mode 100644 index 0000000..628b754 --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa/ifcvt-fix-trunc-2.c @@ -0,0 +1,6 @@ +/* { dg-do compile } */ +/* { dg-options "-O2 -ftree-vectorize -fno-trapping-math -fdump-tree-ifcvt-stats" } */ + +#include "ifcvt-fix-trunc-1.c" + +/* { dg-final { scan-tree-dump-times "Applying if-conversion" 1 "ifcvt" } } */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa/phiprop-2.c b/gcc/testsuite/gcc.dg/tree-ssa/phiprop-2.c new file mode 100644 index 0000000..7181787 --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa/phiprop-2.c @@ -0,0 +1,28 @@ +/* { dg-do compile } */ +/* { dg-options "-O1 -fdump-tree-phiopt2 -fdump-tree-phiprop1-details" } */ + +/* PR tree-optimization/116824 */ + +int g(int i, int *tt) +{ + const int t = 10; + const int *a; + { + if (t < i) + { + *tt = 1; + a = &t; + } + else + { + *tt = 1; + a = &i; + } + } + return *a; +} + +/* Check that phiprop1 can do the insert of the loads. */ +/* { dg-final { scan-tree-dump-times "Inserting PHI for result of load" 1 "phiprop1"} } */ +/* Should be able to get MIN_EXPR in phiopt2 after cselim and phiprop. */ +/* { dg-final { scan-tree-dump-times "MIN_EXPR " 1 "phiopt2" } } */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa/pr108358-a.c b/gcc/testsuite/gcc.dg/tree-ssa/pr108358-a.c new file mode 100644 index 0000000..342e1c1 --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa/pr108358-a.c @@ -0,0 +1,33 @@ +/* { dg-do compile } */ +/* { dg-options "-Os -fdump-tree-optimized" } */ + +/* PR tree-optimization/108358 */ + +struct a { + int b; + int c; + short d; + int e; + int f; +}; +struct g { + struct a f; + struct a h; +}; +int i; +void foo(); +void bar31_(void); +int main() { + struct g j, l = {2, 1, 6, 1, 1, 7, 5, 1, 0, 1}; + for (; i; ++i) + bar31_(); + j = l; + struct g m = j; + struct g k = m; + if (k.h.b) + ; + else + foo(); +} +/* The call to foo should be optimized away. */ +/* { dg-final { scan-tree-dump-not "foo " "optimized" } } */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa/pr114169-1.c b/gcc/testsuite/gcc.dg/tree-ssa/pr114169-1.c new file mode 100644 index 0000000..37766fb --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa/pr114169-1.c @@ -0,0 +1,39 @@ +/* { dg-do compile } */ +/* { dg-options "-O2 -fdump-tree-forwprop-details -fdump-tree-optimized" } */ + + +/* PR tree-optimization/114169 */ + +#include <stdint.h> + +struct S1 { + uint32_t f0; + uint8_t f1; + uint64_t f2; + uint64_t f3; + int32_t f4; +}; + +union U8 { + struct S1 f0; + int32_t f1; + int64_t f2; + uint8_t f3; + const int64_t f4; +}; + +/* --- GLOBAL VARIABLES --- */ +struct S1 g_16 = {4294967293UL,1UL,1UL,0xA9C1C73B017290B1LL,0x5ADF851FL}; +union U8 g_37 = {{1UL,1UL,0x2361AE7D51263067LL,0xEEFD7F9B64A47447LL,0L}}; +struct S1 g_50 = {0x0CFC2012L,1UL,0x43E1243B3BE7B8BBLL,0x03C5CEC10C1A6FE1LL,1L}; + + +/* --- FORWARD DECLARATIONS --- */ + +void func_32(union U8 e) { + e.f3 = e.f0.f4; + g_16 = e.f0 = g_50; +} +/* The union e should not make a difference here. */ +/* { dg-final { scan-tree-dump-times "after previous" 1 "forwprop1" } } */ +/* { dg-final { scan-tree-dump "g_16 = g_50;" "optimized" } } */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa/pr120231-1.c b/gcc/testsuite/gcc.dg/tree-ssa/pr120231-1.c new file mode 100644 index 0000000..c1ce44f --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa/pr120231-1.c @@ -0,0 +1,67 @@ +/* PR tree-optimization/120231 */ +/* { dg-do compile } */ +/* { dg-options "-O2 -fdump-tree-optimized" } */ +/* { dg-add-options float32 } */ +/* { dg-add-options float64 } */ +/* { dg-add-options float128 } */ +/* { dg-require-effective-target float32 } */ +/* { dg-require-effective-target float64 } */ +/* { dg-require-effective-target float128 } */ +/* { dg-final { scan-tree-dump-not "link_failure \\\(\\\);" "optimized" } } */ + +void link_failure (void); + +void +foo (_Float64 x) +{ + if (x >= -64.0f64 && x <= 0x1.p+140f64) + { + _Float32 z = x; + _Float128 w = z; + _Float128 v = x; + if (__builtin_isnan (z) + || __builtin_isnan (w) + || __builtin_isnan (v) + || z < -64.0f32 + || w < -64.0f128 + || __builtin_isinf (v) + || v < -64.0f128 + || v > 0x1.p+140f128) + link_failure (); + } +} + +void +bar (_Float64 x) +{ + _Float32 z = x; + if (z >= -64.0f32 && z <= 0x1.p+38f32) + { + if (__builtin_isnan (x) + || __builtin_isinf (x) + || x < -0x1.000001p+6f64 + || x > 0x1.000001p+38f64) + link_failure (); + } +} + +void +baz (_Float64 x) +{ + _Float128 w = x; + if (w >= -64.0f128 && w <= 0x1.p+1026f128) + { + if (__builtin_isnan (x) + || __builtin_isinf (x) + || x < -64.0f64) + link_failure (); + } + if (w >= 128.25f128 && w <= 0x1.p+1020f128) + { + if (__builtin_isnan (x) + || __builtin_isinf (x) + || x < 128.25f64 + || x > 0x1.p+1020f64) + link_failure (); + } +} diff --git a/gcc/testsuite/gcc.dg/tree-ssa/pr120231-2.c b/gcc/testsuite/gcc.dg/tree-ssa/pr120231-2.c new file mode 100644 index 0000000..d2b41ba --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa/pr120231-2.c @@ -0,0 +1,107 @@ +/* PR tree-optimization/120231 */ +/* { dg-do compile } */ +/* { dg-options "-O2 -fdump-tree-optimized" } */ +/* { dg-add-options float64 } */ +/* { dg-require-effective-target float64 } */ +/* { dg-final { scan-tree-dump-not "link_failure \\\(\\\);" "optimized" } } */ + +void link_failure (void); + +static _Float64 __attribute__((noinline)) +f1 (signed char x) +{ + return x; +} + +static _Float64 __attribute__((noinline)) +f2 (signed char x) +{ + if (x >= -37 && x <= 42) + return x; + return 0.0f64; +} + +void +f3 (signed char x) +{ + _Float64 y = f1 (x); + if (y < (_Float64) (-__SCHAR_MAX__ - 1) || y > (_Float64) __SCHAR_MAX__) + link_failure (); + y = f2 (x); + if (y < -37.0f64 || y > 42.0f64) + link_failure (); +} + +static _Float64 __attribute__((noinline)) +f4 (long long x) +{ + return x; +} + +static _Float64 __attribute__((noinline)) +f5 (long long x) +{ + if (x >= -0x3ffffffffffffffeLL && x <= 0x3ffffffffffffffeLL) + return x; + return 0.0f64; +} + +void +f6 (long long x) +{ + _Float64 y = f4 (x); + if (y < (_Float64) (-__LONG_LONG_MAX__ - 1) || y > (_Float64) __LONG_LONG_MAX__) + link_failure (); + y = f5 (x); + if (y < (_Float64) -0x3ffffffffffffffeLL || y > (_Float64) 0x3ffffffffffffffeLL) + link_failure (); +} + +static signed char __attribute__((noinline)) +f7 (_Float64 x) +{ + if (x >= -78.5f64 && x <= 98.25f64) + return x; + return 0; +} + +static unsigned char __attribute__((noinline)) +f8 (_Float64 x) +{ + if (x >= -0.75f64 && x <= 231.625f64) + return x; + return 31; +} + +static long long __attribute__((noinline)) +f9 (_Float64 x) +{ + if (x >= -3372587051122780362.75f64 && x <= 3955322825938799366.25f64) + return x; + return 0; +} + +static unsigned long long __attribute__((noinline)) +f10 (_Float64 x) +{ + if (x >= 31.25f64 && x <= 16751991430751148048.125f64) + return x; + return 4700; +} + +void +f11 (_Float64 x) +{ + signed char a = f7 (x); + if (a < -78 || a > 98) + link_failure (); + unsigned char b = f8 (x); + if (b > 231) + link_failure (); + long long c = f9 (x); + if (c < -3372587051122780160LL || c > 3955322825938799616LL) + link_failure (); + unsigned long long d = f10 (x); + if (d < 31 || d > 16751991430751148032ULL) + link_failure (); +} diff --git a/gcc/testsuite/gcc.dg/tree-ssa/pr120231-3.c b/gcc/testsuite/gcc.dg/tree-ssa/pr120231-3.c new file mode 100644 index 0000000..d578c5b --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa/pr120231-3.c @@ -0,0 +1,40 @@ +/* PR tree-optimization/120231 */ +/* { dg-do compile } */ +/* { dg-options "-O2 -fdump-tree-optimized" } */ +/* { dg-add-options float64 } */ +/* { dg-require-effective-target float64 } */ +/* { dg-final { scan-tree-dump-not "link_failure \\\(\\\);" "optimized" } } */ + +void link_failure (void); + +void +foo (long long x) +{ + _Float64 y = x; + if (y >= -8577328745032543176.25f64 && y <= 699563045341050951.75f64) + { + if (x < -8577328745032544256LL || x > 699563045341051136LL) + link_failure (); + } + if (y >= -49919160463252.125f64 && y <= 757060336735329.625f64) + { + if (x < -49919160463252LL || x > 757060336735329LL) + link_failure (); + } +} + +void +bar (_Float64 x) +{ + long long y = x; + if (y >= -6923230004751524066LL && y <= 2202103129706786704LL) + { + if (x < -6923230004751524864.0f64 || x > 2202103129706786816.0f64) + link_failure (); + } + if (y >= -171621738469699LL && y <= 45962470357748LL) + { + if (x <= -1716217384696970.f64 || x >= 45962470357749.0f64) + link_failure (); + } +} diff --git a/gcc/testsuite/gcc.dg/tree-ssa/pr57361-1.c b/gcc/testsuite/gcc.dg/tree-ssa/pr57361-1.c new file mode 100644 index 0000000..dc4fadb --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa/pr57361-1.c @@ -0,0 +1,10 @@ +/* { dg-do compile } */ +/* { dg-options "-O -fdump-tree-forwprop1-details" } */ + +struct A { int x; double y; }; +void f (struct A *a) { + *a = *a; +} + +/* xfailed until figuring out the best way to handle aliasing barriers. */ +/* { dg-final { scan-tree-dump "into a NOP" "forwprop1" { xfail *-*-* } } } */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa/pr57361.c b/gcc/testsuite/gcc.dg/tree-ssa/pr57361.c index 81f27b3..7e273db 100644 --- a/gcc/testsuite/gcc.dg/tree-ssa/pr57361.c +++ b/gcc/testsuite/gcc.dg/tree-ssa/pr57361.c @@ -1,5 +1,5 @@ /* { dg-do compile } */ -/* { dg-options "-O -fdump-tree-dse1-details" } */ +/* { dg-options "-O -fdump-tree-dse1-details -fno-tree-forwprop" } */ struct A { int x; double y; }; void f (struct A *a) { diff --git a/gcc/testsuite/gcc.target/aarch64/acle/uhadd_1.c b/gcc/testsuite/gcc.target/aarch64/acle/uhadd_1.c new file mode 100644 index 0000000..f1748a1 --- /dev/null +++ b/gcc/testsuite/gcc.target/aarch64/acle/uhadd_1.c @@ -0,0 +1,34 @@ +/* Test if SIMD fused unsigned halving adds are generated */ +/* { dg-do compile } */ +/* { dg-options "-O2" } */ + +#include <arm_neon.h> + +#define FUSED_SIMD_UHADD(vectype, q, ts, mask) \ + vectype simd_uhadd ## q ## _ ## ts ## _1 (vectype a) \ + { \ + vectype v1 = vand ## q ## _ ## ts (a, vdup ## q ## _n_ ## ts (mask)); \ + vectype v2 = vdup ## q ## _n_ ## ts (mask); \ + return vshr ## q ## _n_ ## ts (vadd ## q ## _ ## ts (v1, v2), 1); \ + } \ + \ + vectype simd_uhadd ## q ## _ ## ts ## _2 (vectype a, vectype b) \ + { \ + vectype v1 = vand ## q ## _ ## ts (a, vdup ## q ## _n_ ## ts (mask)); \ + vectype v2 = vand ## q ## _ ## ts (b, vdup ## q ## _n_ ## ts (mask)); \ + return vshr ## q ## _n_ ## ts (vadd ## q ## _ ## ts (v1, v2), 1); \ + } + +FUSED_SIMD_UHADD (uint8x8_t, , u8, 0x7f) +FUSED_SIMD_UHADD (uint8x16_t, q, u8, 0x7f) +FUSED_SIMD_UHADD (uint16x4_t, , u16, 0x7fff) +FUSED_SIMD_UHADD (uint16x8_t, q, u16, 0x7fff) +FUSED_SIMD_UHADD (uint32x2_t, , u32, 0x7fffffff) +FUSED_SIMD_UHADD (uint32x4_t, q, u32, 0x7fffffff) + +/* { dg-final { scan-assembler-times {\tuhadd\tv[0-9]+\.8b,} 2 } } */ +/* { dg-final { scan-assembler-times {\tuhadd\tv[0-9]+\.16b,} 2 } } */ +/* { dg-final { scan-assembler-times {\tuhadd\tv[0-9]+\.4h,} 2 } } */ +/* { dg-final { scan-assembler-times {\tuhadd\tv[0-9]+\.8h,} 2 } } */ +/* { dg-final { scan-assembler-times {\tuhadd\tv[0-9]+\.2s,} 2 } } */ +/* { dg-final { scan-assembler-times {\tuhadd\tv[0-9]+\.4s,} 2 } } */ diff --git a/gcc/testsuite/gcc.target/aarch64/sve/pr96357.c b/gcc/testsuite/gcc.target/aarch64/sve/pr96357.c index 9a7f912..6dd0409 100644 --- a/gcc/testsuite/gcc.target/aarch64/sve/pr96357.c +++ b/gcc/testsuite/gcc.target/aarch64/sve/pr96357.c @@ -5,10 +5,10 @@ int d; void f1(char f, char *g, char *h, char *l, char *n) { - double i = d, j = 1.0 - f, k = j ? d : j; - if (k == 1.0) - i = 0.0; - *l = *n = *g = *h = i * 0.5; + double j = 1.0 - f, k = j ? d : j; + + char i = (k == 1.0) ? 10 : 50; + *l = *n = *g = *h = i; } void diff --git a/gcc/testsuite/gcc.target/aarch64/vld2-1.c b/gcc/testsuite/gcc.target/aarch64/vld2-1.c new file mode 100644 index 0000000..8a26767 --- /dev/null +++ b/gcc/testsuite/gcc.target/aarch64/vld2-1.c @@ -0,0 +1,45 @@ +/* { dg-do compile } */ +/* { dg-options "-O2 -fdump-tree-forwprop1-details" } */ +/* { dg-final { check-function-bodies "**" "" "" } } */ +/* PR tree-optimization/89606 */ + +#include <arm_neon.h> + +/* +**func1: +** ld2 {v0.2d - v1.2d}, \[x0\] +** ld2 {v0.d - v1.d}\[1\], \[x1\] +** ret +*/ +float64x2x2_t func1(const double *p1, const double *p2) +{ + float64x2x2_t v = vld2q_f64(p1); + return vld2q_lane_f64(p2, v, 1); +} + +/* +**func2: +** ld2 {v0.2s - v1.2s}, \[x0\] +** ld2 {v0.s - v1.s}\[1\], \[x1\] +** ret +*/ +float32x2x2_t func2(const float *p1, const float *p2) +{ + float32x2x2_t v = vld2_f32(p1); + return vld2_lane_f32(p2, v, 1); +} + +/* +**func3: +** ld2 {v([0-9]+).2s - v([0-9]+).2s}, \[x1\] +** ld2 {v\1.s - v\2.s}\[1\], \[x2\] +** stp d\1, d\2, \[x0\] +** ret +*/ +void func3(float32x2x2_t *p, const float *p1, const float *p2) +{ + float32x2x2_t v = vld2_f32(p1); + *p = vld2_lane_f32(p2, v, 1); +} + +/* { dg-final { scan-tree-dump-times "after previous" 3 "forwprop1" } } */ diff --git a/gcc/testsuite/gcc.target/i386/pr49095-2.c b/gcc/testsuite/gcc.target/i386/pr49095-2.c new file mode 100644 index 0000000..25bc6b7 --- /dev/null +++ b/gcc/testsuite/gcc.target/i386/pr49095-2.c @@ -0,0 +1,73 @@ +/* PR rtl-optimization/49095 */ +/* { dg-do compile { target { ! ia32 } } } */ +/* { dg-options "-Os -fno-shrink-wrap -masm=att -mapxf" } */ + +void foo (void *); + +int * +f1 (int *x) +{ + if (!--*x) + foo (x); + return x; +} + +int +g1 (int x) +{ + if (!--x) + foo ((void *) 0); + return x; +} + +#define F(T, OP, OPN) \ +T * \ +f##T##OPN (T *x, T y) \ +{ \ + *x OP y; \ + if (!*x) \ + foo (x); \ + return x; \ +} \ + \ +T \ +g##T##OPN (T x, T y) \ +{ \ + x OP y; \ + if (!x) \ + foo ((void *) 0); \ + return x; \ +} \ + \ +T * \ +h##T##OPN (T *x) \ +{ \ + *x OP 24; \ + if (!*x) \ + foo (x); \ + return x; \ +} \ + \ +T \ +i##T##OPN (T x, T y) \ +{ \ + x OP 24; \ + if (!x) \ + foo ((void *) 0); \ + return x; \ +} + +#define G(T) \ +F (T, +=, plus) \ +F (T, -=, minus) \ +F (T, &=, and) \ +F (T, |=, or) \ +F (T, ^=, xor) + +G (char) +G (short) +G (int) +G (long) + +/* { dg-final { scan-assembler-not "test\[lq\]" } } */ +/* { dg-final { scan-assembler-not "\\(%\[re\]di\\), %" } } */ diff --git a/gcc/testsuite/gcc.target/i386/pr79173-13.c b/gcc/testsuite/gcc.target/i386/pr79173-13.c new file mode 100644 index 0000000..7d5818b --- /dev/null +++ b/gcc/testsuite/gcc.target/i386/pr79173-13.c @@ -0,0 +1,59 @@ +/* PR middle-end/79173 */ +/* { dg-do compile { target { ! ia32 } } } */ +/* { dg-options "-O2 -fno-stack-protector -masm=att -mapxf" } */ +/* { dg-final { scan-assembler-times "addq\t%r\[^\n\r]*, \\\(%rdi\\\)" 1 { target lp64 } } } */ +/* { dg-final { scan-assembler-times "adcq\t%r\[^\n\r]*, 8\\\(%rdi\\\)" 1 { target lp64 } } } */ +/* { dg-final { scan-assembler-times "adcq\t%r\[^\n\r]*, 16\\\(%rdi\\\)" 1 { target lp64 } } } */ +/* { dg-final { scan-assembler-times "adcq\t%r\[^\n\r]*, 24\\\(%rdi\\\)" 1 { target lp64 } } } */ +/* { dg-final { scan-assembler-times "subq\t%r\[^\n\r]*, \\\(%rdi\\\)" 1 { target lp64 } } } */ +/* { dg-final { scan-assembler-times "sbbq\t%r\[^\n\r]*, 8\\\(%rdi\\\)" 1 { target lp64 } } } */ +/* { dg-final { scan-assembler-times "sbbq\t%r\[^\n\r]*, 16\\\(%rdi\\\)" 1 { target lp64 } } } */ +/* { dg-final { scan-assembler-times "sbbq\t%r\[^\n\r]*, 24\\\(%rdi\\\)" 1 { target lp64 } } } */ +/* { dg-final { scan-assembler-times "addl\t%e\[^\n\r]*, \\\(%e\[^\n\r]*\\\)" 1 { target ia32 } } } */ +/* { dg-final { scan-assembler-times "adcl\t%e\[^\n\r]*, 4\\\(%e\[^\n\r]*\\\)" 1 { target ia32 } } } */ +/* { dg-final { scan-assembler-times "adcl\t%e\[^\n\r]*, 8\\\(%e\[^\n\r]*\\\)" 1 { target ia32 } } } */ +/* { dg-final { scan-assembler-times "adcl\t%e\[^\n\r]*, 12\\\(%e\[^\n\r]*\\\)" 1 { target ia32 } } } */ +/* { dg-final { scan-assembler-times "subl\t%e\[^\n\r]*, \\\(%e\[^\n\r]*\\\)" 1 { target ia32 } } } */ +/* { dg-final { scan-assembler-times "sbbl\t%e\[^\n\r]*, 4\\\(%e\[^\n\r]*\\\)" 1 { target ia32 } } } */ +/* { dg-final { scan-assembler-times "sbbl\t%e\[^\n\r]*, 8\\\(%e\[^\n\r]*\\\)" 1 { target ia32 } } } */ +/* { dg-final { scan-assembler-times "sbbl\t%e\[^\n\r]*, 12\\\(%e\[^\n\r]*\\\)" 1 { target ia32 } } } */ + +static unsigned long +uaddc (unsigned long x, unsigned long y, unsigned long carry_in, unsigned long *carry_out) +{ + unsigned long r; + unsigned long c1 = __builtin_add_overflow (x, y, &r); + unsigned long c2 = __builtin_add_overflow (r, carry_in, &r); + *carry_out = c1 + c2; + return r; +} + +static unsigned long +usubc (unsigned long x, unsigned long y, unsigned long carry_in, unsigned long *carry_out) +{ + unsigned long r; + unsigned long c1 = __builtin_sub_overflow (x, y, &r); + unsigned long c2 = __builtin_sub_overflow (r, carry_in, &r); + *carry_out = c1 + c2; + return r; +} + +void +foo (unsigned long *p, unsigned long *q) +{ + unsigned long c; + p[0] = uaddc (p[0], q[0], 0, &c); + p[1] = uaddc (p[1], q[1], c, &c); + p[2] = uaddc (p[2], q[2], c, &c); + p[3] = uaddc (p[3], q[3], c, &c); +} + +void +bar (unsigned long *p, unsigned long *q) +{ + unsigned long c; + p[0] = usubc (p[0], q[0], 0, &c); + p[1] = usubc (p[1], q[1], c, &c); + p[2] = usubc (p[2], q[2], c, &c); + p[3] = usubc (p[3], q[3], c, &c); +} diff --git a/gcc/testsuite/gcc.target/i386/pr79173-14.c b/gcc/testsuite/gcc.target/i386/pr79173-14.c new file mode 100644 index 0000000..de85051 --- /dev/null +++ b/gcc/testsuite/gcc.target/i386/pr79173-14.c @@ -0,0 +1,59 @@ +/* PR middle-end/79173 */ +/* { dg-do compile { target { ! ia32 } } } */ +/* { dg-options "-O2 -fno-stack-protector -masm=att -mapxf" } */ +/* { dg-final { scan-assembler-times "addq\t%r\[^\n\r]*, \\\(%rdi\\\)" 1 { target lp64 } } } */ +/* { dg-final { scan-assembler-times "adcq\t%r\[^\n\r]*, 8\\\(%rdi\\\)" 1 { target lp64 } } } */ +/* { dg-final { scan-assembler-times "adcq\t%r\[^\n\r]*, 16\\\(%rdi\\\)" 1 { target lp64 } } } */ +/* { dg-final { scan-assembler-times "adcq\t%r\[^\n\r]*, 24\\\(%rdi\\\)" 1 { target lp64 } } } */ +/* { dg-final { scan-assembler-times "subq\t%r\[^\n\r]*, \\\(%rdi\\\)" 1 { target lp64 } } } */ +/* { dg-final { scan-assembler-times "sbbq\t%r\[^\n\r]*, 8\\\(%rdi\\\)" 1 { target lp64 } } } */ +/* { dg-final { scan-assembler-times "sbbq\t%r\[^\n\r]*, 16\\\(%rdi\\\)" 1 { target lp64 } } } */ +/* { dg-final { scan-assembler-times "sbbq\t%r\[^\n\r]*, 24\\\(%rdi\\\)" 1 { target lp64 } } } */ +/* { dg-final { scan-assembler-times "addl\t%e\[^\n\r]*, \\\(%e\[^\n\r]*\\\)" 1 { target ia32 } } } */ +/* { dg-final { scan-assembler-times "adcl\t%e\[^\n\r]*, 4\\\(%e\[^\n\r]*\\\)" 1 { target ia32 } } } */ +/* { dg-final { scan-assembler-times "adcl\t%e\[^\n\r]*, 8\\\(%e\[^\n\r]*\\\)" 1 { target ia32 } } } */ +/* { dg-final { scan-assembler-times "adcl\t%e\[^\n\r]*, 12\\\(%e\[^\n\r]*\\\)" 1 { target ia32 } } } */ +/* { dg-final { scan-assembler-times "subl\t%e\[^\n\r]*, \\\(%e\[^\n\r]*\\\)" 1 { target ia32 } } } */ +/* { dg-final { scan-assembler-times "sbbl\t%e\[^\n\r]*, 4\\\(%e\[^\n\r]*\\\)" 1 { target ia32 } } } */ +/* { dg-final { scan-assembler-times "sbbl\t%e\[^\n\r]*, 8\\\(%e\[^\n\r]*\\\)" 1 { target ia32 } } } */ +/* { dg-final { scan-assembler-times "sbbl\t%e\[^\n\r]*, 12\\\(%e\[^\n\r]*\\\)" 1 { target ia32 } } } */ + +static unsigned long +uaddc (unsigned long x, unsigned long y, _Bool carry_in, _Bool *carry_out) +{ + unsigned long r; + _Bool c1 = __builtin_add_overflow (x, y, &r); + _Bool c2 = __builtin_add_overflow (r, carry_in, &r); + *carry_out = c1 | c2; + return r; +} + +static unsigned long +usubc (unsigned long x, unsigned long y, _Bool carry_in, _Bool *carry_out) +{ + unsigned long r; + _Bool c1 = __builtin_sub_overflow (x, y, &r); + _Bool c2 = __builtin_sub_overflow (r, carry_in, &r); + *carry_out = c1 | c2; + return r; +} + +void +foo (unsigned long *p, unsigned long *q) +{ + _Bool c; + p[0] = uaddc (p[0], q[0], 0, &c); + p[1] = uaddc (p[1], q[1], c, &c); + p[2] = uaddc (p[2], q[2], c, &c); + p[3] = uaddc (p[3], q[3], c, &c); +} + +void +bar (unsigned long *p, unsigned long *q) +{ + _Bool c; + p[0] = usubc (p[0], q[0], 0, &c); + p[1] = usubc (p[1], q[1], c, &c); + p[2] = usubc (p[2], q[2], c, &c); + p[3] = usubc (p[3], q[3], c, &c); +} diff --git a/gcc/testsuite/gcc.target/i386/pr79173-15.c b/gcc/testsuite/gcc.target/i386/pr79173-15.c new file mode 100644 index 0000000..c3017f7 --- /dev/null +++ b/gcc/testsuite/gcc.target/i386/pr79173-15.c @@ -0,0 +1,61 @@ +/* PR middle-end/79173 */ +/* { dg-do compile { target { ! ia32 } } } */ +/* { dg-options "-O2 -fno-stack-protector -masm=att -mapxf" } */ +/* { dg-final { scan-assembler-times "addq\t%r\[^\n\r]*, \\\(%rdi\\\)" 1 { target lp64 } } } */ +/* { dg-final { scan-assembler-times "adcq\t%r\[^\n\r]*, 8\\\(%rdi\\\)" 1 { target lp64 } } } */ +/* { dg-final { scan-assembler-times "adcq\t%r\[^\n\r]*, 16\\\(%rdi\\\)" 1 { target lp64 } } } */ +/* { dg-final { scan-assembler-times "adcq\t%r\[^\n\r]*, 24\\\(%rdi\\\)" 1 { target lp64 } } } */ +/* { dg-final { scan-assembler-times "subq\t%r\[^\n\r]*, \\\(%rdi\\\)" 1 { target lp64 } } } */ +/* { dg-final { scan-assembler-times "sbbq\t%r\[^\n\r]*, 8\\\(%rdi\\\)" 1 { target lp64 } } } */ +/* { dg-final { scan-assembler-times "sbbq\t%r\[^\n\r]*, 16\\\(%rdi\\\)" 1 { target lp64 } } } */ +/* { dg-final { scan-assembler-times "sbbq\t%r\[^\n\r]*, 24\\\(%rdi\\\)" 1 { target lp64 } } } */ +/* { dg-final { scan-assembler-times "addl\t%e\[^\n\r]*, \\\(%e\[^\n\r]*\\\)" 1 { target ia32 } } } */ +/* { dg-final { scan-assembler-times "adcl\t%e\[^\n\r]*, 4\\\(%e\[^\n\r]*\\\)" 1 { target ia32 } } } */ +/* { dg-final { scan-assembler-times "adcl\t%e\[^\n\r]*, 8\\\(%e\[^\n\r]*\\\)" 1 { target ia32 } } } */ +/* { dg-final { scan-assembler-times "adcl\t%e\[^\n\r]*, 12\\\(%e\[^\n\r]*\\\)" 1 { target ia32 } } } */ +/* { dg-final { scan-assembler-times "subl\t%e\[^\n\r]*, \\\(%e\[^\n\r]*\\\)" 1 { target ia32 } } } */ +/* { dg-final { scan-assembler-times "sbbl\t%e\[^\n\r]*, 4\\\(%e\[^\n\r]*\\\)" 1 { target ia32 } } } */ +/* { dg-final { scan-assembler-times "sbbl\t%e\[^\n\r]*, 8\\\(%e\[^\n\r]*\\\)" 1 { target ia32 } } } */ +/* { dg-final { scan-assembler-times "sbbl\t%e\[^\n\r]*, 12\\\(%e\[^\n\r]*\\\)" 1 { target ia32 } } } */ + +static unsigned long +uaddc (unsigned long x, unsigned long y, unsigned long carry_in, unsigned long *carry_out) +{ + unsigned long r; + unsigned long c1 = __builtin_add_overflow (x, y, &r); + unsigned long c2 = __builtin_add_overflow (r, carry_in, &r); + *carry_out = c1 + c2; + return r; +} + +static unsigned long +usubc (unsigned long x, unsigned long y, unsigned long carry_in, unsigned long *carry_out) +{ + unsigned long r; + unsigned long c1 = __builtin_sub_overflow (x, y, &r); + unsigned long c2 = __builtin_sub_overflow (r, carry_in, &r); + *carry_out = c1 + c2; + return r; +} + +unsigned long +foo (unsigned long *p, unsigned long *q) +{ + unsigned long c; + p[0] = uaddc (p[0], q[0], 0, &c); + p[1] = uaddc (p[1], q[1], c, &c); + p[2] = uaddc (p[2], q[2], c, &c); + p[3] = uaddc (p[3], q[3], c, &c); + return c; +} + +unsigned long +bar (unsigned long *p, unsigned long *q) +{ + unsigned long c; + p[0] = usubc (p[0], q[0], 0, &c); + p[1] = usubc (p[1], q[1], c, &c); + p[2] = usubc (p[2], q[2], c, &c); + p[3] = usubc (p[3], q[3], c, &c); + return c; +} diff --git a/gcc/testsuite/gcc.target/i386/pr79173-16.c b/gcc/testsuite/gcc.target/i386/pr79173-16.c new file mode 100644 index 0000000..91062fb --- /dev/null +++ b/gcc/testsuite/gcc.target/i386/pr79173-16.c @@ -0,0 +1,61 @@ +/* PR middle-end/79173 */ +/* { dg-do compile { target { ! ia32 } } } */ +/* { dg-options "-O2 -fno-stack-protector -masm=att -mapxf" } */ +/* { dg-final { scan-assembler-times "addq\t%r\[^\n\r]*, \\\(%rdi\\\)" 1 { target lp64 } } } */ +/* { dg-final { scan-assembler-times "adcq\t%r\[^\n\r]*, 8\\\(%rdi\\\)" 1 { target lp64 } } } */ +/* { dg-final { scan-assembler-times "adcq\t%r\[^\n\r]*, 16\\\(%rdi\\\)" 1 { target lp64 } } } */ +/* { dg-final { scan-assembler-times "adcq\t%r\[^\n\r]*, 24\\\(%rdi\\\)" 1 { target lp64 } } } */ +/* { dg-final { scan-assembler-times "subq\t%r\[^\n\r]*, \\\(%rdi\\\)" 1 { target lp64 } } } */ +/* { dg-final { scan-assembler-times "sbbq\t%r\[^\n\r]*, 8\\\(%rdi\\\)" 1 { target lp64 } } } */ +/* { dg-final { scan-assembler-times "sbbq\t%r\[^\n\r]*, 16\\\(%rdi\\\)" 1 { target lp64 } } } */ +/* { dg-final { scan-assembler-times "sbbq\t%r\[^\n\r]*, 24\\\(%rdi\\\)" 1 { target lp64 } } } */ +/* { dg-final { scan-assembler-times "addl\t%e\[^\n\r]*, \\\(%e\[^\n\r]*\\\)" 1 { target ia32 } } } */ +/* { dg-final { scan-assembler-times "adcl\t%e\[^\n\r]*, 4\\\(%e\[^\n\r]*\\\)" 1 { target ia32 } } } */ +/* { dg-final { scan-assembler-times "adcl\t%e\[^\n\r]*, 8\\\(%e\[^\n\r]*\\\)" 1 { target ia32 } } } */ +/* { dg-final { scan-assembler-times "adcl\t%e\[^\n\r]*, 12\\\(%e\[^\n\r]*\\\)" 1 { target ia32 } } } */ +/* { dg-final { scan-assembler-times "subl\t%e\[^\n\r]*, \\\(%e\[^\n\r]*\\\)" 1 { target ia32 } } } */ +/* { dg-final { scan-assembler-times "sbbl\t%e\[^\n\r]*, 4\\\(%e\[^\n\r]*\\\)" 1 { target ia32 } } } */ +/* { dg-final { scan-assembler-times "sbbl\t%e\[^\n\r]*, 8\\\(%e\[^\n\r]*\\\)" 1 { target ia32 } } } */ +/* { dg-final { scan-assembler-times "sbbl\t%e\[^\n\r]*, 12\\\(%e\[^\n\r]*\\\)" 1 { target ia32 } } } */ + +static unsigned long +uaddc (unsigned long x, unsigned long y, _Bool carry_in, _Bool *carry_out) +{ + unsigned long r; + _Bool c1 = __builtin_add_overflow (x, y, &r); + _Bool c2 = __builtin_add_overflow (r, carry_in, &r); + *carry_out = c1 ^ c2; + return r; +} + +static unsigned long +usubc (unsigned long x, unsigned long y, _Bool carry_in, _Bool *carry_out) +{ + unsigned long r; + _Bool c1 = __builtin_sub_overflow (x, y, &r); + _Bool c2 = __builtin_sub_overflow (r, carry_in, &r); + *carry_out = c1 ^ c2; + return r; +} + +_Bool +foo (unsigned long *p, unsigned long *q) +{ + _Bool c; + p[0] = uaddc (p[0], q[0], 0, &c); + p[1] = uaddc (p[1], q[1], c, &c); + p[2] = uaddc (p[2], q[2], c, &c); + p[3] = uaddc (p[3], q[3], c, &c); + return c; +} + +_Bool +bar (unsigned long *p, unsigned long *q) +{ + _Bool c; + p[0] = usubc (p[0], q[0], 0, &c); + p[1] = usubc (p[1], q[1], c, &c); + p[2] = usubc (p[2], q[2], c, &c); + p[3] = usubc (p[3], q[3], c, &c); + return c; +} diff --git a/gcc/testsuite/gcc.target/i386/pr79173-17.c b/gcc/testsuite/gcc.target/i386/pr79173-17.c new file mode 100644 index 0000000..e27f4b9 --- /dev/null +++ b/gcc/testsuite/gcc.target/i386/pr79173-17.c @@ -0,0 +1,32 @@ +/* PR middle-end/79173 */ +/* { dg-do compile { target { ! ia32 } } } */ +/* { dg-options "-O2 -fno-stack-protector -masm=att -mapxf" } */ +/* { dg-final { scan-assembler-times "addq\t%r\[^\n\r]*, \\\(%rdi\\\)" 1 { target lp64 } } } */ +/* { dg-final { scan-assembler-times "adcq\t%r\[^\n\r]*, 8\\\(%rdi\\\)" 1 { target lp64 } } } */ +/* { dg-final { scan-assembler-times "adcq\t%r\[^\n\r]*, 16\\\(%rdi\\\)" 1 { target lp64 } } } */ +/* { dg-final { scan-assembler-times "adcq\t%r\[^\n\r]*, 24\\\(%rdi\\\)" 1 { target lp64 } } } */ +/* { dg-final { scan-assembler-times "addl\t%e\[^\n\r]*, \\\(%e\[^\n\r]*\\\)" 1 { target ia32 } } } */ +/* { dg-final { scan-assembler-times "adcl\t%e\[^\n\r]*, 4\\\(%e\[^\n\r]*\\\)" 1 { target ia32 } } } */ +/* { dg-final { scan-assembler-times "adcl\t%e\[^\n\r]*, 8\\\(%e\[^\n\r]*\\\)" 1 { target ia32 } } } */ +/* { dg-final { scan-assembler-times "adcl\t%e\[^\n\r]*, 12\\\(%e\[^\n\r]*\\\)" 1 { target ia32 } } } */ + +static unsigned long +uaddc (unsigned long x, unsigned long y, unsigned long carry_in, unsigned long *carry_out) +{ + unsigned long r = x + y; + unsigned long c1 = r < x; + r += carry_in; + unsigned long c2 = r < carry_in; + *carry_out = c1 + c2; + return r; +} + +void +foo (unsigned long *p, unsigned long *q) +{ + unsigned long c; + p[0] = uaddc (p[0], q[0], 0, &c); + p[1] = uaddc (p[1], q[1], c, &c); + p[2] = uaddc (p[2], q[2], c, &c); + p[3] = uaddc (p[3], q[3], c, &c); +} diff --git a/gcc/testsuite/gcc.target/i386/pr79173-18.c b/gcc/testsuite/gcc.target/i386/pr79173-18.c new file mode 100644 index 0000000..2728ae7 --- /dev/null +++ b/gcc/testsuite/gcc.target/i386/pr79173-18.c @@ -0,0 +1,33 @@ +/* PR middle-end/79173 */ +/* { dg-do compile { target { ! ia32 } } } */ +/* { dg-options "-O2 -fno-stack-protector -masm=att -mapxf" } */ +/* { dg-final { scan-assembler-times "addq\t%r\[^\n\r]*, \\\(%rdi\\\)" 1 { target lp64 } } } */ +/* { dg-final { scan-assembler-times "adcq\t%r\[^\n\r]*, 8\\\(%rdi\\\)" 1 { target lp64 } } } */ +/* { dg-final { scan-assembler-times "adcq\t%r\[^\n\r]*, 16\\\(%rdi\\\)" 1 { target lp64 } } } */ +/* { dg-final { scan-assembler-times "adcq\t%r\[^\n\r]*, 24\\\(%rdi\\\)" 1 { target lp64 } } } */ +/* { dg-final { scan-assembler-times "addl\t%e\[^\n\r]*, \\\(%e\[^\n\r]*\\\)" 1 { target ia32 } } } */ +/* { dg-final { scan-assembler-times "adcl\t%e\[^\n\r]*, 4\\\(%e\[^\n\r]*\\\)" 1 { target ia32 } } } */ +/* { dg-final { scan-assembler-times "adcl\t%e\[^\n\r]*, 8\\\(%e\[^\n\r]*\\\)" 1 { target ia32 } } } */ +/* { dg-final { scan-assembler-times "adcl\t%e\[^\n\r]*, 12\\\(%e\[^\n\r]*\\\)" 1 { target ia32 } } } */ + +static unsigned long +uaddc (unsigned long x, unsigned long y, unsigned long carry_in, unsigned long *carry_out) +{ + unsigned long r = x + y; + unsigned long c1 = r < x; + r += carry_in; + unsigned long c2 = r < carry_in; + *carry_out = c1 + c2; + return r; +} + +unsigned long +foo (unsigned long *p, unsigned long *q) +{ + unsigned long c; + p[0] = uaddc (p[0], q[0], 0, &c); + p[1] = uaddc (p[1], q[1], c, &c); + p[2] = uaddc (p[2], q[2], c, &c); + p[3] = uaddc (p[3], q[3], c, &c); + return c; +} diff --git a/gcc/testsuite/gcc.target/riscv/arch-60.c b/gcc/testsuite/gcc.target/riscv/arch-60.c new file mode 100644 index 0000000..ea599f2 --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/arch-60.c @@ -0,0 +1,5 @@ +/* { dg-do compile } */ +/* { dg-options "-march=rv64i_svbare -mabi=lp64" } */ +int foo() +{ +} diff --git a/gcc/testsuite/gcc.target/riscv/arch-shlocofideleg.c b/gcc/testsuite/gcc.target/riscv/arch-shlocofideleg.c new file mode 100644 index 0000000..de9f9fc --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/arch-shlocofideleg.c @@ -0,0 +1,5 @@ +/* { dg-do compile } */ +/* { dg-options "-march=rv64i_shlcofideleg -mabi=lp64" } */ +int foo() +{ +} diff --git a/gcc/testsuite/gcc.target/riscv/arch-smcsrind.c b/gcc/testsuite/gcc.target/riscv/arch-smcsrind.c new file mode 100644 index 0000000..4d1c104 --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/arch-smcsrind.c @@ -0,0 +1,5 @@ +/* { dg-do compile } */ +/* { dg-options "-march=rv64i_smcsrind -mabi=lp64" } */ +int foo() +{ +} diff --git a/gcc/testsuite/gcc.target/riscv/arch-smrnmi.c b/gcc/testsuite/gcc.target/riscv/arch-smrnmi.c new file mode 100644 index 0000000..8e62540 --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/arch-smrnmi.c @@ -0,0 +1,5 @@ +/* { dg-do compile } */ +/* { dg-options "-march=rv64i_smrnmi -mabi=lp64" } */ +int foo() +{ +} diff --git a/gcc/testsuite/gcc.target/riscv/arch-ssccptr.c b/gcc/testsuite/gcc.target/riscv/arch-ssccptr.c new file mode 100644 index 0000000..902155a --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/arch-ssccptr.c @@ -0,0 +1,5 @@ +/* { dg-do compile } */ +/* { dg-options "-march=rv64i_ssccptr -mabi=lp64" } */ +int foo() +{ +} diff --git a/gcc/testsuite/gcc.target/riscv/arch-sscounterenw.c b/gcc/testsuite/gcc.target/riscv/arch-sscounterenw.c new file mode 100644 index 0000000..901b6bc --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/arch-sscounterenw.c @@ -0,0 +1,5 @@ +/* { dg-do compile } */ +/* { dg-options "-march=rv64i_sscounterenw -mabi=lp64" } */ +int foo() +{ +} diff --git a/gcc/testsuite/gcc.target/riscv/arch-sstvala.c b/gcc/testsuite/gcc.target/riscv/arch-sstvala.c new file mode 100644 index 0000000..21ea8a6 --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/arch-sstvala.c @@ -0,0 +1,5 @@ +/* { dg-do compile } */ +/* { dg-options "-march=rv64i_sstvala -mabi=lp64" } */ +int foo() +{ +} diff --git a/gcc/testsuite/gcc.target/riscv/arch-sstvecd.c b/gcc/testsuite/gcc.target/riscv/arch-sstvecd.c new file mode 100644 index 0000000..e76f7881 --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/arch-sstvecd.c @@ -0,0 +1,5 @@ +/* { dg-do compile } */ +/* { dg-options "-march=rv64i_sstvecd -mabi=lp64" } */ +int foo() +{ +} diff --git a/gcc/testsuite/gcc.target/riscv/arch-ssu64xl.c b/gcc/testsuite/gcc.target/riscv/arch-ssu64xl.c new file mode 100644 index 0000000..6e151c1 --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/arch-ssu64xl.c @@ -0,0 +1,5 @@ +/* { dg-do compile } */ +/* { dg-options "-march=rv64i_ssu64xl -mabi=lp64" } */ +int foo() +{ +} diff --git a/gcc/testsuite/gcc.target/riscv/nozicond-1.c b/gcc/testsuite/gcc.target/riscv/nozicond-1.c new file mode 100644 index 0000000..35ab6fe --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/nozicond-1.c @@ -0,0 +1,11 @@ +/* { dg-do compile { target { rv64 } } } */ +/* { dg-additional-options "-march=rv64gc_zicond -mabi=lp64d -mbranch-cost=4" } */ +/* { dg-skip-if "" { *-*-* } { "-O0" "-O1" "-Og" } } */ + + +long foo1 (long c) { return c >= 0 ? 1 : -1; } +long foo2 (long c) { return c < 0 ? -1 : 1; } + +/* { dg-final { scan-assembler-times {srai\t} 2 } } */ +/* { dg-final { scan-assembler-times {ori\t} 2 } } */ + diff --git a/gcc/testsuite/gcc.target/riscv/nozicond-2.c b/gcc/testsuite/gcc.target/riscv/nozicond-2.c new file mode 100644 index 0000000..f705253 --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/nozicond-2.c @@ -0,0 +1,15 @@ +/* { dg-do compile { target { rv64 } } } */ +/* { dg-additional-options "-march=rv64gc_zicond -mabi=lp64d -mbranch-cost=4" } */ +/* { dg-skip-if "" { *-*-* } { "-O0" "-O1" "-Og" } } */ + + +long foo1 (long c) { return c < 0 ? 1 : -1; } +long foo2 (long c) { return c >= 0 ? -1 : 1; } + +/* We don't support 4->3 splitters, so this fails. We could perhaps + try to catch it in the expander as a special case rather than waiting + for combine. */ +/* { dg-final { scan-assembler-times {srai\t} 2 { xfail *-*-* } } } */ +/* { dg-final { scan-assembler-times {ori\t} 2 { xfail *-*-* } } } */ +/* { dg-final { scan-assembler-times {not\t} 2 { xfail *-*-* } } } */ + diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/binop/vdiv-rv32gcv-nofm.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/binop/vdiv-rv32gcv-nofm.c index 0750d8e..4685ed2 100644 --- a/gcc/testsuite/gcc.target/riscv/rvv/autovec/binop/vdiv-rv32gcv-nofm.c +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/binop/vdiv-rv32gcv-nofm.c @@ -3,13 +3,13 @@ #include "vdiv-template.h" -/* { dg-final { scan-assembler-times {\tvdiv\.vv} 5 } } */ -/* { dg-final { scan-assembler-times {\tvdiv\.vx} 3 } } */ +/* { dg-final { scan-assembler-times {\tvdiv\.vv} 8 } } */ +/* { dg-final { scan-assembler-not {\tvdiv\.vx} } } */ /* { dg-final { scan-assembler-times {\tvdivu\.vv} 5 } } */ /* { dg-final { scan-assembler-times {\tvdivu\.vx} 3 } } */ -/* { dg-final { scan-assembler-times {\tvfdiv\.vv} 3 } } */ -/* { dg-final { scan-assembler-times {\tvfdiv\.vf} 3 } } */ +/* { dg-final { scan-assembler-times {\tvfdiv\.vv} 6 } } */ +/* { dg-final { scan-assembler-not {\tvfdiv\.vf} } } */ /* { dg-final { scan-tree-dump-times "\.COND_LEN_DIV" 16 "optimized" } } */ /* { dg-final { scan-tree-dump-times "\.COND_LEN_RDIV" 6 "optimized" } } */ diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/binop/vdiv-rv32gcv.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/binop/vdiv-rv32gcv.c index 31b2284..59c48d2 100644 --- a/gcc/testsuite/gcc.target/riscv/rvv/autovec/binop/vdiv-rv32gcv.c +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/binop/vdiv-rv32gcv.c @@ -3,8 +3,8 @@ #include "vdiv-template.h" -/* { dg-final { scan-assembler-times {\tvdiv\.vv} 5 } } */ -/* { dg-final { scan-assembler-times {\tvdiv\.vx} 3 } } */ +/* { dg-final { scan-assembler-times {\tvdiv\.vv} 8 } } */ +/* { dg-final { scan-assembler-not {\tvdiv\.vx} } } */ /* { dg-final { scan-assembler-times {\tvdivu\.vv} 5 } } */ /* { dg-final { scan-assembler-times {\tvdivu\.vx} 3 } } */ diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/binop/vdiv-rv64gcv-nofm.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/binop/vdiv-rv64gcv-nofm.c index 6015af9..b574dc4 100644 --- a/gcc/testsuite/gcc.target/riscv/rvv/autovec/binop/vdiv-rv64gcv-nofm.c +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/binop/vdiv-rv64gcv-nofm.c @@ -3,13 +3,13 @@ #include "vdiv-template.h" -/* { dg-final { scan-assembler-times {\tvdiv\.vv} 4 } } */ -/* { dg-final { scan-assembler-times {\tvdiv\.vx} 4 } } */ +/* { dg-final { scan-assembler-times {\tvdiv\.vv} 8 } } */ +/* { dg-final { scan-assembler-not {\tvdiv\.vx} } } */ /* { dg-final { scan-assembler-times {\tvdivu\.vv} 4 } } */ /* { dg-final { scan-assembler-times {\tvdivu\.vx} 4 } } */ -/* { dg-final { scan-assembler-times {\tvfdiv\.vv} 3 } } */ -/* { dg-final { scan-assembler-times {\tvfdiv\.vf} 3 } } */ +/* { dg-final { scan-assembler-times {\tvfdiv\.vv} 6 } } */ +/* { dg-final { scan-assembler-not {\tvfdiv\.vf} } } */ /* { dg-final { scan-tree-dump-times "\.COND_LEN_DIV" 16 "optimized" } } */ /* { dg-final { scan-tree-dump-times "\.COND_LEN_RDIV" 6 "optimized" } } */ diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/binop/vdiv-rv64gcv.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/binop/vdiv-rv64gcv.c index ccaa2f8..9b46c6b 100644 --- a/gcc/testsuite/gcc.target/riscv/rvv/autovec/binop/vdiv-rv64gcv.c +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/binop/vdiv-rv64gcv.c @@ -3,8 +3,8 @@ #include "vdiv-template.h" -/* { dg-final { scan-assembler-times {\tvdiv\.vv} 4 } } */ -/* { dg-final { scan-assembler-times {\tvdiv\.vx} 4 } } */ +/* { dg-final { scan-assembler-times {\tvdiv\.vv} 8 } } */ +/* { dg-final { scan-assembler-not {\tvdiv\.vx} } } */ /* { dg-final { scan-assembler-times {\tvdivu\.vv} 4 } } */ /* { dg-final { scan-assembler-times {\tvdivu\.vx} 4 } } */ diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf-1-f16.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf-1-f16.c new file mode 100644 index 0000000..821e5c5 --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf-1-f16.c @@ -0,0 +1,10 @@ +/* { dg-do compile } */ +/* { dg-options "-march=rv64gcv_zvfh -mabi=lp64d --param=fpr2vr-cost=0" } */ + +#include "vf_mulop.h" + +DEF_VF_MULOP_CASE_0(_Float16, +, add) +DEF_VF_MULOP_CASE_0(_Float16, -, sub) + +/* { dg-final { scan-assembler-times {vfmadd.vf} 1 } } */ +/* { dg-final { scan-assembler-times {vfmsub.vf} 1 } } */ diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf-1-f32.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf-1-f32.c new file mode 100644 index 0000000..49b4287 --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf-1-f32.c @@ -0,0 +1,10 @@ +/* { dg-do compile } */ +/* { dg-options "-march=rv64gcv -mabi=lp64d --param=fpr2vr-cost=0" } */ + +#include "vf_mulop.h" + +DEF_VF_MULOP_CASE_0(float, +, add) +DEF_VF_MULOP_CASE_0(float, -, sub) + +/* { dg-final { scan-assembler-times {vfmadd.vf} 1 } } */ +/* { dg-final { scan-assembler-times {vfmsub.vf} 1 } } */ diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf-1-f64.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf-1-f64.c new file mode 100644 index 0000000..2bb5d89 --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf-1-f64.c @@ -0,0 +1,10 @@ +/* { dg-do compile } */ +/* { dg-options "-march=rv64gcv -mabi=lp64d --param=fpr2vr-cost=0" } */ + +#include "vf_mulop.h" + +DEF_VF_MULOP_CASE_0(double, +, add) +DEF_VF_MULOP_CASE_0(double, -, sub) + +/* { dg-final { scan-assembler-times {vfmadd.vf} 1 } } */ +/* { dg-final { scan-assembler-times {vfmsub.vf} 1 } } */ diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf-2-f16.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf-2-f16.c new file mode 100644 index 0000000..cbb43ca --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf-2-f16.c @@ -0,0 +1,10 @@ +/* { dg-do compile } */ +/* { dg-options "-march=rv64gcv_zvfh -mabi=lp64d --param=fpr2vr-cost=1" } */ + +#include "vf_mulop.h" + +DEF_VF_MULOP_CASE_0(_Float16, +, add) +DEF_VF_MULOP_CASE_0(_Float16, -, sub) + +/* { dg-final { scan-assembler-not {vfmadd.vf} } } */ +/* { dg-final { scan-assembler-not {vfmsub.vf} } } */ diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf-2-f32.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf-2-f32.c new file mode 100644 index 0000000..66ff9b8 --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf-2-f32.c @@ -0,0 +1,10 @@ +/* { dg-do compile } */ +/* { dg-options "-march=rv64gcv -mabi=lp64d --param=fpr2vr-cost=1" } */ + +#include "vf_mulop.h" + +DEF_VF_MULOP_CASE_0(float, +, add) +DEF_VF_MULOP_CASE_0(float, -, sub) + +/* { dg-final { scan-assembler-not {vfmadd.vf} } } */ +/* { dg-final { scan-assembler-not {vfmsub.vf} } } */ diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf-2-f64.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf-2-f64.c new file mode 100644 index 0000000..66ff9b8 --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf-2-f64.c @@ -0,0 +1,10 @@ +/* { dg-do compile } */ +/* { dg-options "-march=rv64gcv -mabi=lp64d --param=fpr2vr-cost=1" } */ + +#include "vf_mulop.h" + +DEF_VF_MULOP_CASE_0(float, +, add) +DEF_VF_MULOP_CASE_0(float, -, sub) + +/* { dg-final { scan-assembler-not {vfmadd.vf} } } */ +/* { dg-final { scan-assembler-not {vfmsub.vf} } } */ diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf-3-f16.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf-3-f16.c new file mode 100644 index 0000000..45980f4 --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf-3-f16.c @@ -0,0 +1,10 @@ +/* { dg-do compile } */ +/* { dg-options "-march=rv64gcv_zvfh -mabi=lp64d --param=fpr2vr-cost=0" } */ + +#include "vf_mulop.h" + +DEF_VF_MULOP_CASE_1(_Float16, +, add, VF_MULOP_BODY_X16) +DEF_VF_MULOP_CASE_1(_Float16, -, sub, VF_MULOP_BODY_X16) + +/* { dg-final { scan-assembler {vfmadd.vf} } } */ +/* { dg-final { scan-assembler {vfmsub.vf} } } */ diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf-3-f32.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf-3-f32.c new file mode 100644 index 0000000..c853620 --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf-3-f32.c @@ -0,0 +1,10 @@ +/* { dg-do compile } */ +/* { dg-options "-march=rv64gcv -mabi=lp64d --param=fpr2vr-cost=0" } */ + +#include "vf_mulop.h" + +DEF_VF_MULOP_CASE_1(float, +, add, VF_MULOP_BODY_X16) +DEF_VF_MULOP_CASE_1(float, -, sub, VF_MULOP_BODY_X16) + +/* { dg-final { scan-assembler {vfmadd.vf} } } */ +/* { dg-final { scan-assembler {vfmsub.vf} } } */ diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf-3-f64.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf-3-f64.c new file mode 100644 index 0000000..d38ae8b --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf-3-f64.c @@ -0,0 +1,10 @@ +/* { dg-do compile } */ +/* { dg-options "-march=rv64gcv -mabi=lp64d --param=fpr2vr-cost=0" } */ + +#include "vf_mulop.h" + +DEF_VF_MULOP_CASE_1(double, +, add, VF_MULOP_BODY_X16) +DEF_VF_MULOP_CASE_1(double, -, sub, VF_MULOP_BODY_X16) + +/* { dg-final { scan-assembler {vfmadd.vf} } } */ +/* { dg-final { scan-assembler {vfmsub.vf} } } */ diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf-4-f16.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf-4-f16.c new file mode 100644 index 0000000..f1ca34e --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf-4-f16.c @@ -0,0 +1,10 @@ +/* { dg-do compile } */ +/* { dg-options "-march=rv64gcv_zvfh -mabi=lp64d --param=fpr2vr-cost=4" } */ + +#include "vf_mulop.h" + +DEF_VF_MULOP_CASE_1(_Float16, +, add, VF_MULOP_BODY_X16) +DEF_VF_MULOP_CASE_1(_Float16, -, sub, VF_MULOP_BODY_X16) + +/* { dg-final { scan-assembler-not {vfmadd.vf} } } */ +/* { dg-final { scan-assembler-not {vfmsub.vf} } } */ diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf-4-f32.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf-4-f32.c new file mode 100644 index 0000000..6730d4b --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf-4-f32.c @@ -0,0 +1,10 @@ +/* { dg-do compile } */ +/* { dg-options "-march=rv64gcv -mabi=lp64d --param=fpr2vr-cost=4" } */ + +#include "vf_mulop.h" + +DEF_VF_MULOP_CASE_1(float, +, add, VF_MULOP_BODY_X16) +DEF_VF_MULOP_CASE_1(float, -, sub, VF_MULOP_BODY_X16) + +/* { dg-final { scan-assembler-not {vfmadd.vf} } } */ +/* { dg-final { scan-assembler-not {vfmsub.vf} } } */ diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf-4-f64.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf-4-f64.c new file mode 100644 index 0000000..bcb6a6e --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf-4-f64.c @@ -0,0 +1,10 @@ +/* { dg-do compile } */ +/* { dg-options "-march=rv64gcv -mabi=lp64d --param=fpr2vr-cost=4" } */ + +#include "vf_mulop.h" + +DEF_VF_MULOP_CASE_1(double, +, add, VF_MULOP_BODY_X16) +DEF_VF_MULOP_CASE_1(double, -, sub, VF_MULOP_BODY_X16) + +/* { dg-final { scan-assembler-not {vfmadd.vf} } } */ +/* { dg-final { scan-assembler-not {vfmsub.vf} } } */ diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf_mulop.h b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf_mulop.h new file mode 100644 index 0000000..5253978 --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf_mulop.h @@ -0,0 +1,61 @@ +#ifndef HAVE_DEFINED_VF_MULOP_H +#define HAVE_DEFINED_VF_MULOP_H + +#include <stdint.h> + +#define DEF_VF_MULOP_CASE_0(T, OP, NAME) \ + void test_vf_mulop_##NAME##_##T##_case_0(T *restrict out, T *restrict in, \ + T x, unsigned n) { \ + for (unsigned i = 0; i < n; i++) \ + out[i] = in[i] OP out[i] * x; \ + } +#define DEF_VF_MULOP_CASE_0_WRAP(T, OP, NAME) DEF_VF_MULOP_CASE_0(T, OP, NAME) +#define RUN_VF_MULOP_CASE_0(T, NAME, out, in, x, n) \ + test_vf_mulop_##NAME##_##T##_case_0(out, in, x, n) +#define RUN_VF_MULOP_CASE_0_WRAP(T, NAME, out, in, x, n) \ + RUN_VF_MULOP_CASE_0(T, NAME, out, in, x, n) + +#define VF_MULOP_BODY(op) \ + out[k + 0] = in[k + 0] op tmp * out[k + 0]; \ + out[k + 1] = in[k + 1] op tmp * out[k + 1]; \ + k += 2; + +#define VF_MULOP_BODY_X4(op) \ + VF_MULOP_BODY(op) \ + VF_MULOP_BODY(op) + +#define VF_MULOP_BODY_X8(op) \ + VF_MULOP_BODY_X4(op) \ + VF_MULOP_BODY_X4(op) + +#define VF_MULOP_BODY_X16(op) \ + VF_MULOP_BODY_X8(op) \ + VF_MULOP_BODY_X8(op) + +#define VF_MULOP_BODY_X32(op) \ + VF_MULOP_BODY_X16(op) \ + VF_MULOP_BODY_X16(op) + +#define VF_MULOP_BODY_X64(op) \ + VF_MULOP_BODY_X32(op) \ + VF_MULOP_BODY_X32(op) + +#define VF_MULOP_BODY_X128(op) \ + VF_MULOP_BODY_X64(op) \ + VF_MULOP_BODY_X64(op) + +#define DEF_VF_MULOP_CASE_1(T, OP, NAME, BODY) \ + void test_vf_mulop_##NAME##_##T##_case_1(T *restrict out, T *restrict in, \ + T x, unsigned n) { \ + unsigned k = 0; \ + T tmp = x + 3; \ + \ + while (k < n) { \ + tmp = tmp * 0x3f; \ + BODY(OP) \ + } \ + } +#define DEF_VF_MULOP_CASE_1_WRAP(T, OP, NAME, BODY) \ + DEF_VF_MULOP_CASE_1(T, OP, NAME, BODY) + +#endif diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf_mulop_data.h b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf_mulop_data.h new file mode 100644 index 0000000..c16c1a9 --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf_mulop_data.h @@ -0,0 +1,413 @@ +#ifndef HAVE_DEFINED_VF_MULOP_DATA_H +#define HAVE_DEFINED_VF_MULOP_DATA_H + +#define N 16 + +#define TEST_MULOP_DATA(T, NAME) test_##T##_##NAME##_data +#define TEST_MULOP_DATA_WRAP(T, NAME) TEST_MULOP_DATA(T, NAME) + + +_Float16 TEST_MULOP_DATA(_Float16, add)[][4][N] = +{ + { + { 0.30f16 }, + { + 1.48f16, 1.48f16, 1.48f16, 1.48f16, + 0.80f16, 0.80f16, 0.80f16, 0.80f16, + 0.62f16, 0.62f16, 0.62f16, 0.62f16, + 1.18f16, 1.18f16, 1.18f16, 1.18f16, + }, + { + 1.25f16, 1.25f16, 1.25f16, 1.25f16, + 1.89f16, 1.89f16, 1.89f16, 1.89f16, + 1.57f16, 1.57f16, 1.57f16, 1.57f16, + 1.21f16, 1.21f16, 1.21f16, 1.21f16, + }, + { + 1.85f16, 1.85f16, 1.85f16, 1.85f16, + 1.37f16, 1.37f16, 1.37f16, 1.37f16, + 1.09f16, 1.09f16, 1.09f16, 1.09f16, + 1.54f16, 1.54f16, 1.54f16, 1.54f16, + } + }, + { + { -0.505f16 }, + { + -2.38f16, -2.38f16, -2.38f16, -2.38f16, + -2.06f16, -2.06f16, -2.06f16, -2.06f16, + -1.69f16, -1.69f16, -1.69f16, -1.69f16, + -1.1f16, -1.1f16, -1.1f16, -1.1f16, + }, + { + -1.77f16, -1.77f16, -1.77f16, -1.77f16, + -1.6f16, -1.6f16, -1.6f16, -1.6f16, + -1.f16, -1.f16, -1.f16, -1.f16, + -1.23f16, -1.23f16, -1.23f16, -1.23f16, + }, + { + -1.49f16, -1.49f16, -1.49f16, -1.49f16, + -1.25f16, -1.25f16, -1.25f16, -1.25f16, + -1.18f16, -1.18f16, -1.18f16, -1.18f16, + -0.479f16, -0.479f16, -0.479f16, -0.479f16, + } + }, + { + { 4.95e-04f16 }, + { + 1.4266e-05f16, 1.4266e-05f16, 1.4266e-05f16, 1.4266e-05f16, + 1.8129e-05f16, 1.8129e-05f16, 1.8129e-05f16, 1.8129e-05f16, + -8.4710e-06f16, -8.4710e-06f16, -8.4710e-06f16, -8.4710e-06f16, + 3.7876e-05f16, 3.7876e-05f16, 3.7876e-05f16, 3.7876e-05f16, + }, + { + 2.2808e-02f16, 2.2808e-02f16, 2.2808e-02f16, 2.2808e-02f16, + 3.9633e-02f16, 3.9633e-02f16, 3.9633e-02f16, 3.9633e-02f16, + 9.9657e-02f16, 9.9657e-02f16, 9.9657e-02f16, 9.9657e-02f16, + 7.7189e-02f16, 7.7189e-02f16, 7.7189e-02f16, 7.7189e-02f16, + }, + { + 2.5547e-05f16, 2.5547e-05f16, 2.5547e-05f16, 2.5547e-05f16, + 3.7732e-05f16, 3.7732e-05f16, 3.7732e-05f16, 3.7732e-05f16, + 4.0820e-05f16, 4.0820e-05f16, 4.0820e-05f16, 4.0820e-05f16, + 7.6054e-05f16, 7.6054e-05f16, 7.6054e-05f16, 7.6054e-05f16, + } + }, +}; + +float TEST_MULOP_DATA(float, add)[][4][N] = +{ + { + { 43.71f }, + { + -410.28f, -410.28f, -410.28f, -410.28f, + -276.91f, -276.91f, -276.91f, -276.91f, + -103.38f, -103.38f, -103.38f, -103.38f, + -378.24f, -378.24f, -378.24f, -378.24f, + }, + { + 9.56f, 9.56f, 9.56f, 9.56f, + 6.39f, 6.39f, 6.39f, 6.39f, + 2.40f, 2.40f, 2.40f, 2.40f, + 8.80f, 8.80f, 8.80f, 8.80f, + }, + { + 7.59f, 7.59f, 7.59f, 7.59f, + 2.40f, 2.40f, 2.40f, 2.40f, + 1.52f, 1.52f, 1.52f, 1.52f, + 6.41f, 6.41f, 6.41f, 6.41f, + } + }, + { + { 2.04f }, + { + -110.22f, -110.22f, -110.22f, -110.22f, + -25.13f, -25.13f, -25.13f, -25.13f, + -108.18f, -108.18f, -108.18f, -108.18f, + -107.14f, -107.14f, -107.14f, -107.14f, + }, + { + 64.82f, 64.82f, 64.82f, 64.82f, + 31.65f, 31.65f, 31.65f, 31.65f, + 87.32f, 87.32f, 87.32f, 87.32f, + 58.70f, 58.70f, 58.70f, 58.70f, + }, + { + 22.01f, 22.01f, 22.01f, 22.01f, + 39.44f, 39.44f, 39.44f, 39.44f, + 69.95f, 69.95f, 69.95f, 69.95f, + 12.61f, 12.61f, 12.61f, 12.61f, + } + }, + { + { 20.35f }, + { + 881.43f, 881.43f, 881.43f, 881.43f, + 3300.17f, 3300.17f, 3300.17f, 3300.17f, + 5217.85f, 5217.85f, 5217.85f, 5217.85f, + 66.57f, 66.57f, 66.57f, 66.57f, + }, + { + 64.82f, 64.82f, 64.82f, 64.82f, + 31.65f, 31.65f, 31.65f, 31.65f, + 87.32f, 87.32f, 87.32f, 87.32f, + 58.70f, 58.70f, 58.70f, 58.70f, + }, + { + 2200.52f, 2200.52f, 2200.52f, 2200.52f, + 3944.25f, 3944.25f, 3944.25f, 3944.25f, + 6994.81f, 6994.81f, 6994.81f, 6994.81f, + 1261.12f, 1261.12f, 1261.12f, 1261.12f, + } + }, +}; + +double TEST_MULOP_DATA(double, add)[][4][N] = +{ + { + { 1.16e+12 }, + { + 1.8757e+45, 1.8757e+45, 1.8757e+45, 1.8757e+45, + 7.5140e+45, 7.5140e+45, 7.5140e+45, 7.5140e+45, + 8.2069e+45, 8.2069e+45, 8.2069e+45, 8.2069e+45, + 4.9456e+45, 4.9456e+45, 4.9456e+45, 4.9456e+45, + }, + { + 9.0242e+32, 9.0242e+32, 9.0242e+32, 9.0242e+32, + 3.6908e+32, 3.6908e+32, 3.6908e+32, 3.6908e+32, + 3.9202e+32, 3.9202e+32, 3.9202e+32, 3.9202e+32, + 5.0276e+32, 5.0276e+32, 5.0276e+32, 5.0276e+32, + }, + { + 2.9201e+45, 2.9201e+45, 2.9201e+45, 2.9201e+45, + 7.9411e+45, 7.9411e+45, 7.9411e+45, 7.9411e+45, + 8.6606e+45, 8.6606e+45, 8.6606e+45, 8.6606e+45, + 5.5275e+45, 5.5275e+45, 5.5275e+45, 5.5275e+45, + } + }, + { + { -7.29e+23 }, + { + -6.4993e+65, -6.4993e+65, -6.4993e+65, -6.4993e+65, + -4.6760e+65, -4.6760e+65, -4.6760e+65, -4.6760e+65, + -8.1564e+65, -8.1564e+65, -8.1564e+65, -8.1564e+65, + -8.2899e+65, -8.2899e+65, -8.2899e+65, -8.2899e+65, + }, + { + -7.7764e+41, -7.7764e+41, -7.7764e+41, -7.7764e+41, + -1.9756e+41, -1.9756e+41, -1.9756e+41, -1.9756e+41, + -4.8980e+41, -4.8980e+41, -4.8980e+41, -4.8980e+41, + -8.1062e+41, -8.1062e+41, -8.1062e+41, -8.1062e+41, + }, + { + -8.2928e+64, -8.2928e+64, -8.2928e+64, -8.2928e+64, + -3.2356e+65, -3.2356e+65, -3.2356e+65, -3.2356e+65, + -4.5850e+65, -4.5850e+65, -4.5850e+65, -4.5850e+65, + -2.3794e+65, -2.3794e+65, -2.3794e+65, -2.3794e+65, + } + }, + { + { 2.02e-03 }, + { + -1.2191e-35, -1.2191e-35, -1.2191e-35, -1.2191e-35, + -1.0471e-36, -1.0471e-36, -1.0471e-36, -1.0471e-36, + -9.7582e-36, -9.7582e-36, -9.7582e-36, -9.7582e-36, + -2.2097e-36, -2.2097e-36, -2.2097e-36, -2.2097e-36, + }, + { + 9.7703e-33, 9.7703e-33, 9.7703e-33, 9.7703e-33, + 4.1632e-33, 4.1632e-33, 4.1632e-33, 4.1632e-33, + 8.1964e-33, 8.1964e-33, 8.1964e-33, 8.1964e-33, + 4.7314e-33, 4.7314e-33, 4.7314e-33, 4.7314e-33, + }, + { + 7.5586e-36, 7.5586e-36, 7.5586e-36, 7.5586e-36, + 7.3684e-36, 7.3684e-36, 7.3684e-36, 7.3684e-36, + 6.8101e-36, 6.8101e-36, 6.8101e-36, 6.8101e-36, + 7.3543e-36, 7.3543e-36, 7.3543e-36, 7.3543e-36, + } + }, +}; + +_Float16 TEST_MULOP_DATA(_Float16, sub)[][4][N] = +{ + { + { 0.676f16 }, + { + 1.39f16, 1.39f16, 1.39f16, 1.39f16, + 1.68f16, 1.68f16, 1.68f16, 1.68f16, + 1.63f16, 1.63f16, 1.63f16, 1.63f16, + 2.12f16, 2.12f16, 2.12f16, 2.12f16, + }, + { + 1.04f16, 1.04f16, 1.04f16, 1.04f16, + 1.64f16, 1.64f16, 1.64f16, 1.64f16, + 1.95f16, 1.95f16, 1.95f16, 1.95f16, + 1.39f16, 1.39f16, 1.39f16, 1.39f16, + }, + { + 0.687f16, 0.687f16, 0.687f16, 0.687f16, + 0.568f16, 0.568f16, 0.568f16, 0.568f16, + 0.315f16, 0.315f16, 0.315f16, 0.315f16, + 1.18f16, 1.18f16, 1.18f16, 1.18f16, + } +}, + { + { -0.324f16 }, + { + -0.679f16, -0.679f16, -0.679f16, -0.679f16, + -0.992f16, -0.992f16, -0.992f16, -0.992f16, + -1.34f16, -1.34f16, -1.34f16, -1.34f16, + -0.297f16, -0.297f16, -0.297f16, -0.297f16, + }, + { + -1.96f16, -1.96f16, -1.96f16, -1.96f16, + -1.36f16, -1.36f16, -1.36f16, -1.36f16, + -1.05f16, -1.05f16, -1.05f16, -1.05f16, + -1.61f16, -1.61f16, -1.61f16, -1.61f16, + }, + { + -1.31f16, -1.31f16, -1.31f16, -1.31f16, + -1.43f16, -1.43f16, -1.43f16, -1.43f16, + -1.68f16, -1.68f16, -1.68f16, -1.68f16, + -0.82f16, -0.82f16, -0.82f16, -0.82f16, + } + }, + { + { 7.08e+01f16 }, + { + 4.49e+03f16, 4.49e+03f16, 4.49e+03f16, 4.49e+03f16, + 7.73e+03f16, 7.73e+03f16, 7.73e+03f16, 7.73e+03f16, + 8.42e+03f16, 8.42e+03f16, 8.42e+03f16, 8.42e+03f16, + 9.12e+03f16, 9.12e+03f16, 9.12e+03f16, 9.12e+03f16, + }, + { + 1.40e+01f16, 1.40e+01f16, 1.40e+01f16, 1.40e+01f16, + 6.80e+01f16, 6.80e+01f16, 6.80e+01f16, 6.80e+01f16, + 9.54e+01f16, 9.54e+01f16, 9.54e+01f16, 9.54e+01f16, + 4.49e+01f16, 4.49e+01f16, 4.49e+01f16, 4.49e+01f16, + }, + { + 3.50e+03f16, 3.50e+03f16, 3.50e+03f16, 3.50e+03f16, + 2.91e+03f16, 2.91e+03f16, 2.91e+03f16, 2.91e+03f16, + 1.66e+03f16, 1.66e+03f16, 1.66e+03f16, 1.66e+03f16, + 5.94e+03f16, 5.94e+03f16, 5.94e+03f16, 5.94e+03f16, + } + }, +}; + +float TEST_MULOP_DATA(float, sub)[][4][N] = +{ + { + {8.51f }, + { + 24.21f, 24.21f, 24.21f, 24.21f, + 40.31f, 40.31f, 40.31f, 40.31f, + 59.68f, 59.68f, 59.68f, 59.68f, + 45.42f, 45.42f, 45.42f, 45.42f, + }, + { + 1.94f, 1.94f, 1.94f, 1.94f, + 4.24f, 4.24f, 4.24f, 4.24f, + 6.48f, 6.48f, 6.48f, 6.48f, + 4.68f, 4.68f, 4.68f, 4.68f, + }, + { + 7.70f, 7.70f, 7.70f, 7.70f, + 4.23f, 4.23f, 4.23f, 4.23f, + 4.54f, 4.54f, 4.54f, 4.54f, + 5.59f, 5.59f, 5.59f, 5.59f, + }, +}, + { + { 85.14f }, + { + 1731.29f, 1731.29f, 1731.29f, 1731.29f, + 3656.53f, 3656.53f, 3656.53f, 3656.53f, + 5565.07f, 5565.07f, 5565.07f, 5565.07f, + 4042.14f, 4042.14f, 4042.14f, 4042.14f, + }, + { + 19.43f, 19.43f, 19.43f, 19.43f, + 42.45f, 42.45f, 42.45f, 42.45f, + 64.83f, 64.83f, 64.83f, 64.83f, + 46.82f, 46.82f, 46.82f, 46.82f, + }, + { + 77.02f, 77.02f, 77.02f, 77.02f, + 42.34f, 42.34f, 42.34f, 42.34f, + 45.44f, 45.44f, 45.44f, 45.44f, + 55.89f, 55.89f, 55.89f, 55.89f, + } + }, + { + { 99.01f }, + { + 6240.43f, 6240.43f, 6240.43f, 6240.43f, + 2179.23f, 2179.23f, 2179.23f, 2179.23f, + 5346.65f, 5346.65f, 5346.65f, 5346.65f, + 2649.91f, 2649.91f, 2649.91f, 2649.91f, + }, + { + 59.46f, 59.46f, 59.46f, 59.46f, + 16.96f, 16.96f, 16.96f, 16.96f, + 52.55f, 52.55f, 52.55f, 52.55f, + 24.70f, 24.70f, 24.70f, 24.70f, + }, + { + 353.30f, 353.30f, 353.30f, 353.30f, + 500.02f, 500.02f, 500.02f, 500.02f, + 143.67f, 143.67f, 143.67f, 143.67f, + 204.36f, 204.36f, 204.36f, 204.36f, + } + }, +}; + +double TEST_MULOP_DATA(double, sub)[][4][N] = +{ + { + { 80.54 }, + { + 5731.60, 5731.60, 5731.60, 5731.60, + 6682.41, 6682.41, 6682.41, 6682.41, + 7737.53, 7737.53, 7737.53, 7737.53, + 4922.68, 4922.68, 4922.68, 4922.68, + }, + { + 67.14, 67.14, 67.14, 67.14, + 78.23, 78.23, 78.23, 78.23, + 94.35, 94.35, 94.35, 94.35, + 49.68, 49.68, 49.68, 49.68, + }, + { + 324.14, 324.14, 324.14, 324.14, + 381.77, 381.77, 381.77, 381.77, + 138.58, 138.58, 138.58, 138.58, + 921.45, 921.45, 921.45, 921.45, + } + }, + { + { 8.05e+01 }, + { + 8.65e+27, 8.65e+27, 8.65e+27, 8.65e+27, + 1.01e+28, 1.01e+28, 1.01e+28, 1.01e+28, + 8.99e+27, 8.99e+27, 8.99e+27, 8.99e+27, + 1.32e+28, 1.32e+28, 1.32e+28, 1.32e+28, + }, + { + 6.71e+25, 6.71e+25, 6.71e+25, 6.71e+25, + 7.82e+25, 7.82e+25, 7.82e+25, 7.82e+25, + 9.44e+25, 9.44e+25, 9.44e+25, 9.44e+25, + 4.97e+25, 4.97e+25, 4.97e+25, 4.97e+25, + }, + { + 3.24e+27, 3.24e+27, 3.24e+27, 3.24e+27, + 3.82e+27, 3.82e+27, 3.82e+27, 3.82e+27, + 1.39e+27, 1.39e+27, 1.39e+27, 1.39e+27, + 9.21e+27, 9.21e+27, 9.21e+27, 9.21e+27, + } + }, + { + { 2.02e-03 }, + { + 2.7308e-35, 2.7308e-35, 2.7308e-35, 2.7308e-35, + 1.5784e-35, 1.5784e-35, 1.5784e-35, 1.5784e-35, + 2.3378e-35, 2.3378e-35, 2.3378e-35, 2.3378e-35, + 1.6918e-35, 1.6918e-35, 1.6918e-35, 1.6918e-35, + }, + { + 9.7703e-33, 9.7703e-33, 9.7703e-33, 9.7703e-33, + 4.1632e-33, 4.1632e-33, 4.1632e-33, 4.1632e-33, + 8.1964e-33, 8.1964e-33, 8.1964e-33, 8.1964e-33, + 4.7314e-33, 4.7314e-33, 4.7314e-33, 4.7314e-33, + }, + { + 7.5586e-36, 7.5586e-36, 7.5586e-36, 7.5586e-36, + 7.3684e-36, 7.3684e-36, 7.3684e-36, 7.3684e-36, + 6.8101e-36, 6.8101e-36, 6.8101e-36, 6.8101e-36, + 7.3543e-36, 7.3543e-36, 7.3543e-36, 7.3543e-36, + } + }, +}; + + +#endif diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf_mulop_run.h b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf_mulop_run.h new file mode 100644 index 0000000..bc6f483d --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf_mulop_run.h @@ -0,0 +1,34 @@ +#ifndef HAVE_DEFINED_VF_MULOP_RUN_H +#define HAVE_DEFINED_VF_MULOP_RUN_H + +#include <math.h> + +#define TYPE_FABS(x, T) \ + (__builtin_types_compatible_p (T, double) ? fabs (x) : fabsf (x)) + +int +main () +{ + unsigned i, k; + + for (i = 0; i < sizeof (TEST_DATA) / sizeof (TEST_DATA[0]); i++) + { + T x = TEST_DATA[i][0][0]; + T *in = TEST_DATA[i][1]; + T *out = TEST_DATA[i][2]; + T *expect = TEST_DATA[i][3]; + + TEST_RUN (T, NAME, out, in, x, N); + + for (k = 0; k < N; k++) + { + T diff = expect[k] - out[k]; + if (TYPE_FABS (diff, T) > .01 * TYPE_FABS (expect[k], T)) + __builtin_abort (); + } + } + + return 0; +} + +#endif diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf_vfmadd-run-1-f16.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf_vfmadd-run-1-f16.c new file mode 100644 index 0000000..1bcf9e0 --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf_vfmadd-run-1-f16.c @@ -0,0 +1,15 @@ +/* { dg-do run { target { riscv_v } } } */ +/* { dg-additional-options "--param=fpr2vr-cost=0" } */ + +#include "vf_mulop.h" +#include "vf_mulop_data.h" + +#define T _Float16 +#define NAME add + +DEF_VF_MULOP_CASE_0_WRAP(T, +, NAME) + +#define TEST_DATA TEST_MULOP_DATA_WRAP(T, NAME) +#define TEST_RUN(T, NAME, out, in, x, n) RUN_VF_MULOP_CASE_0_WRAP(T, NAME, out, in, x, n) + +#include "vf_mulop_run.h" diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf_vfmadd-run-1-f32.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf_vfmadd-run-1-f32.c new file mode 100644 index 0000000..199b9ad --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf_vfmadd-run-1-f32.c @@ -0,0 +1,15 @@ +/* { dg-do run { target { riscv_v } } } */ +/* { dg-additional-options "--param=fpr2vr-cost=0" } */ + +#include "vf_mulop.h" +#include "vf_mulop_data.h" + +#define T float +#define NAME add + +DEF_VF_MULOP_CASE_0_WRAP(T, +, NAME) + +#define TEST_DATA TEST_MULOP_DATA_WRAP(T, NAME) +#define TEST_RUN(T, NAME, out, in, x, n) RUN_VF_MULOP_CASE_0_WRAP(T, NAME, out, in, x, n) + +#include "vf_mulop_run.h" diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf_vfmadd-run-1-f64.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf_vfmadd-run-1-f64.c new file mode 100644 index 0000000..3857f58 --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf_vfmadd-run-1-f64.c @@ -0,0 +1,15 @@ +/* { dg-do run { target { riscv_v } } } */ +/* { dg-additional-options "--param=fpr2vr-cost=0" } */ + +#include "vf_mulop.h" +#include "vf_mulop_data.h" + +#define T double +#define NAME add + +DEF_VF_MULOP_CASE_0_WRAP(T, +, NAME) + +#define TEST_DATA TEST_MULOP_DATA_WRAP(T, NAME) +#define TEST_RUN(T, NAME, out, in, x, n) RUN_VF_MULOP_CASE_0_WRAP(T, NAME, out, in, x, n) + +#include "vf_mulop_run.h" diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf_vfmsub-run-1-f16.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf_vfmsub-run-1-f16.c new file mode 100644 index 0000000..671c7d8 --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf_vfmsub-run-1-f16.c @@ -0,0 +1,15 @@ +/* { dg-do run { target { riscv_v } } } */ +/* { dg-additional-options "--param=fpr2vr-cost=0" } */ + +#include "vf_mulop.h" +#include "vf_mulop_data.h" + +#define T _Float16 +#define NAME sub + +DEF_VF_MULOP_CASE_0_WRAP(T, -, NAME) + +#define TEST_DATA TEST_MULOP_DATA_WRAP(T, NAME) +#define TEST_RUN(T, NAME, out, in, x, n) RUN_VF_MULOP_CASE_0_WRAP(T, NAME, out, in, x, n) + +#include "vf_mulop_run.h" diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf_vfmsub-run-1-f32.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf_vfmsub-run-1-f32.c new file mode 100644 index 0000000..f896963 --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf_vfmsub-run-1-f32.c @@ -0,0 +1,15 @@ +/* { dg-do run { target { riscv_v } } } */ +/* { dg-additional-options "--param=fpr2vr-cost=0" } */ + +#include "vf_mulop.h" +#include "vf_mulop_data.h" + +#define T float +#define NAME sub + +DEF_VF_MULOP_CASE_0_WRAP(T, -, NAME) + +#define TEST_DATA TEST_MULOP_DATA_WRAP(T, NAME) +#define TEST_RUN(T, NAME, out, in, x, n) RUN_VF_MULOP_CASE_0_WRAP(T, NAME, out, in, x, n) + +#include "vf_mulop_run.h" diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf_vfmsub-run-1-f64.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf_vfmsub-run-1-f64.c new file mode 100644 index 0000000..b42ab1e --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vf_vfmsub-run-1-f64.c @@ -0,0 +1,15 @@ +/* { dg-do run { target { riscv_v } } } */ +/* { dg-additional-options "--param=fpr2vr-cost=0" } */ + +#include "vf_mulop.h" +#include "vf_mulop_data.h" + +#define T double +#define NAME sub + +DEF_VF_MULOP_CASE_0_WRAP(T, -, NAME) + +#define TEST_DATA TEST_MULOP_DATA_WRAP(T, NAME) +#define TEST_RUN(T, NAME, out, in, x, n) RUN_VF_MULOP_CASE_0_WRAP(T, NAME, out, in, x, n) + +#include "vf_mulop_run.h" diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-1-i16.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-1-i16.c index 144d1ba..d88e76b 100644 --- a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-1-i16.c +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-1-i16.c @@ -12,6 +12,7 @@ DEF_VX_BINARY_CASE_0_WRAP(T, &, and) DEF_VX_BINARY_CASE_0_WRAP(T, |, or) DEF_VX_BINARY_CASE_0_WRAP(T, ^, xor) DEF_VX_BINARY_CASE_0_WRAP(T, *, mul) +DEF_VX_BINARY_CASE_0_WRAP(T, /, div) /* { dg-final { scan-assembler-times {vadd.vx} 1 } } */ /* { dg-final { scan-assembler-times {vsub.vx} 1 } } */ @@ -20,3 +21,4 @@ DEF_VX_BINARY_CASE_0_WRAP(T, *, mul) /* { dg-final { scan-assembler-times {vor.vx} 1 } } */ /* { dg-final { scan-assembler-times {vxor.vx} 1 } } */ /* { dg-final { scan-assembler-times {vmul.vx} 1 } } */ +/* { dg-final { scan-assembler-times {vdiv.vx} 1 } } */ diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-1-i32.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-1-i32.c index 74d35d1..53189c2 100644 --- a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-1-i32.c +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-1-i32.c @@ -12,6 +12,7 @@ DEF_VX_BINARY_CASE_0_WRAP(T, &, and) DEF_VX_BINARY_CASE_0_WRAP(T, |, or) DEF_VX_BINARY_CASE_0_WRAP(T, ^, xor) DEF_VX_BINARY_CASE_0_WRAP(T, *, mul) +DEF_VX_BINARY_CASE_0_WRAP(T, /, div) /* { dg-final { scan-assembler-times {vadd.vx} 1 } } */ /* { dg-final { scan-assembler-times {vsub.vx} 1 } } */ @@ -20,3 +21,4 @@ DEF_VX_BINARY_CASE_0_WRAP(T, *, mul) /* { dg-final { scan-assembler-times {vor.vx} 1 } } */ /* { dg-final { scan-assembler-times {vxor.vx} 1 } } */ /* { dg-final { scan-assembler-times {vmul.vx} 1 } } */ +/* { dg-final { scan-assembler-times {vdiv.vx} 1 } } */ diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-1-i64.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-1-i64.c index ac512ff..5059beb 100644 --- a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-1-i64.c +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-1-i64.c @@ -12,6 +12,7 @@ DEF_VX_BINARY_CASE_0_WRAP(T, &, and) DEF_VX_BINARY_CASE_0_WRAP(T, |, or) DEF_VX_BINARY_CASE_0_WRAP(T, ^, xor) DEF_VX_BINARY_CASE_0_WRAP(T, *, mul) +DEF_VX_BINARY_CASE_0_WRAP(T, /, div) /* { dg-final { scan-assembler-times {vadd.vx} 1 } } */ /* { dg-final { scan-assembler-times {vsub.vx} 1 } } */ @@ -20,3 +21,4 @@ DEF_VX_BINARY_CASE_0_WRAP(T, *, mul) /* { dg-final { scan-assembler-times {vor.vx} 1 } } */ /* { dg-final { scan-assembler-times {vxor.vx} 1 } } */ /* { dg-final { scan-assembler-times {vmul.vx} 1 } } */ +/* { dg-final { scan-assembler-times {vdiv.vx} 1 } } */ diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-1-i8.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-1-i8.c index 4f7b675..4bbe5a4 100644 --- a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-1-i8.c +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-1-i8.c @@ -12,6 +12,7 @@ DEF_VX_BINARY_CASE_0_WRAP(T, &, and) DEF_VX_BINARY_CASE_0_WRAP(T, |, or) DEF_VX_BINARY_CASE_0_WRAP(T, ^, xor) DEF_VX_BINARY_CASE_0_WRAP(T, *, mul) +DEF_VX_BINARY_CASE_0_WRAP(T, /, div) /* { dg-final { scan-assembler-times {vadd.vx} 1 } } */ /* { dg-final { scan-assembler-times {vsub.vx} 1 } } */ @@ -20,3 +21,4 @@ DEF_VX_BINARY_CASE_0_WRAP(T, *, mul) /* { dg-final { scan-assembler-times {vor.vx} 1 } } */ /* { dg-final { scan-assembler-times {vxor.vx} 1 } } */ /* { dg-final { scan-assembler-times {vmul.vx} 1 } } */ +/* { dg-final { scan-assembler-times {vdiv.vx} 1 } } */ diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-2-i16.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-2-i16.c index 075c8be..0437db4 100644 --- a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-2-i16.c +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-2-i16.c @@ -12,6 +12,7 @@ DEF_VX_BINARY_CASE_0_WRAP(T, &, and) DEF_VX_BINARY_CASE_0_WRAP(T, |, or) DEF_VX_BINARY_CASE_0_WRAP(T, ^, xor) DEF_VX_BINARY_CASE_0_WRAP(T, *, mul) +DEF_VX_BINARY_CASE_0_WRAP(T, /, div) /* { dg-final { scan-assembler-not {vadd.vx} } } */ /* { dg-final { scan-assembler-not {vsub.vx} } } */ @@ -20,3 +21,4 @@ DEF_VX_BINARY_CASE_0_WRAP(T, *, mul) /* { dg-final { scan-assembler-not {vor.vx} } } */ /* { dg-final { scan-assembler-not {vxor.vx} } } */ /* { dg-final { scan-assembler-not {vmul.vx} } } */ +/* { dg-final { scan-assembler-not {vdiv.vx} } } */ diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-2-i32.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-2-i32.c index 595479c..95ed403 100644 --- a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-2-i32.c +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-2-i32.c @@ -12,6 +12,7 @@ DEF_VX_BINARY_CASE_0_WRAP(T, &, and) DEF_VX_BINARY_CASE_0_WRAP(T, |, or) DEF_VX_BINARY_CASE_0_WRAP(T, ^, xor) DEF_VX_BINARY_CASE_0_WRAP(T, *, mul) +DEF_VX_BINARY_CASE_0_WRAP(T, /, div) /* { dg-final { scan-assembler-not {vadd.vx} } } */ /* { dg-final { scan-assembler-not {vsub.vx} } } */ @@ -20,3 +21,4 @@ DEF_VX_BINARY_CASE_0_WRAP(T, *, mul) /* { dg-final { scan-assembler-not {vor.vx} } } */ /* { dg-final { scan-assembler-not {vxor.vx} } } */ /* { dg-final { scan-assembler-not {vmul.vx} } } */ +/* { dg-final { scan-assembler-not {vdiv.vx} } } */ diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-2-i64.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-2-i64.c index 7b6fcbf..f8912a0 100644 --- a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-2-i64.c +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-2-i64.c @@ -12,6 +12,7 @@ DEF_VX_BINARY_CASE_0_WRAP(T, &, and) DEF_VX_BINARY_CASE_0_WRAP(T, |, or) DEF_VX_BINARY_CASE_0_WRAP(T, ^, xor) DEF_VX_BINARY_CASE_0_WRAP(T, *, mul) +DEF_VX_BINARY_CASE_0_WRAP(T, /, div) /* { dg-final { scan-assembler-not {vadd.vx} } } */ /* { dg-final { scan-assembler-not {vsub.vx} } } */ @@ -20,3 +21,4 @@ DEF_VX_BINARY_CASE_0_WRAP(T, *, mul) /* { dg-final { scan-assembler-not {vor.vx} } } */ /* { dg-final { scan-assembler-not {vxor.vx} } } */ /* { dg-final { scan-assembler-not {vmul.vx} } } */ +/* { dg-final { scan-assembler-not {vdiv.vx} } } */ diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-2-i8.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-2-i8.c index 55fc717..3c8f915 100644 --- a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-2-i8.c +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-2-i8.c @@ -12,6 +12,7 @@ DEF_VX_BINARY_CASE_0_WRAP(T, &, and) DEF_VX_BINARY_CASE_0_WRAP(T, |, or) DEF_VX_BINARY_CASE_0_WRAP(T, ^, xor) DEF_VX_BINARY_CASE_0_WRAP(T, *, mul) +DEF_VX_BINARY_CASE_0_WRAP(T, /, div) /* { dg-final { scan-assembler-not {vadd.vx} } } */ /* { dg-final { scan-assembler-not {vsub.vx} } } */ @@ -20,3 +21,4 @@ DEF_VX_BINARY_CASE_0_WRAP(T, *, mul) /* { dg-final { scan-assembler-not {vor.vx} } } */ /* { dg-final { scan-assembler-not {vxor.vx} } } */ /* { dg-final { scan-assembler-not {vmul.vx} } } */ +/* { dg-final { scan-assembler-not {vdiv.vx} } } */ diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-3-i16.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-3-i16.c index bec6b3a..f49dae4 100644 --- a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-3-i16.c +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-3-i16.c @@ -12,6 +12,7 @@ DEF_VX_BINARY_CASE_0_WRAP(T, &, and) DEF_VX_BINARY_CASE_0_WRAP(T, |, or) DEF_VX_BINARY_CASE_0_WRAP(T, ^, xor) DEF_VX_BINARY_CASE_0_WRAP(T, *, mul) +DEF_VX_BINARY_CASE_0_WRAP(T, /, div) /* { dg-final { scan-assembler-not {vadd.vx} } } */ /* { dg-final { scan-assembler-not {vsub.vx} } } */ @@ -20,3 +21,4 @@ DEF_VX_BINARY_CASE_0_WRAP(T, *, mul) /* { dg-final { scan-assembler-not {vor.vx} } } */ /* { dg-final { scan-assembler-not {vxor.vx} } } */ /* { dg-final { scan-assembler-not {vmul.vx} } } */ +/* { dg-final { scan-assembler-not {vdiv.vx} } } */ diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-3-i32.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-3-i32.c index 98fce52..8f502a3 100644 --- a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-3-i32.c +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-3-i32.c @@ -12,6 +12,7 @@ DEF_VX_BINARY_CASE_0_WRAP(T, &, and) DEF_VX_BINARY_CASE_0_WRAP(T, |, or) DEF_VX_BINARY_CASE_0_WRAP(T, ^, xor) DEF_VX_BINARY_CASE_0_WRAP(T, *, mul) +DEF_VX_BINARY_CASE_0_WRAP(T, /, div) /* { dg-final { scan-assembler-not {vadd.vx} } } */ /* { dg-final { scan-assembler-not {vsub.vx} } } */ @@ -20,3 +21,4 @@ DEF_VX_BINARY_CASE_0_WRAP(T, *, mul) /* { dg-final { scan-assembler-not {vor.vx} } } */ /* { dg-final { scan-assembler-not {vxor.vx} } } */ /* { dg-final { scan-assembler-not {vmul.vx} } } */ +/* { dg-final { scan-assembler-not {vdiv.vx} } } */ diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-3-i64.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-3-i64.c index 48dd57a..3277bf2 100644 --- a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-3-i64.c +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-3-i64.c @@ -12,6 +12,7 @@ DEF_VX_BINARY_CASE_0_WRAP(T, &, and) DEF_VX_BINARY_CASE_0_WRAP(T, |, or) DEF_VX_BINARY_CASE_0_WRAP(T, ^, xor) DEF_VX_BINARY_CASE_0_WRAP(T, *, mul) +DEF_VX_BINARY_CASE_0_WRAP(T, /, div) /* { dg-final { scan-assembler-not {vadd.vx} } } */ /* { dg-final { scan-assembler-not {vsub.vx} } } */ @@ -20,3 +21,4 @@ DEF_VX_BINARY_CASE_0_WRAP(T, *, mul) /* { dg-final { scan-assembler-not {vor.vx} } } */ /* { dg-final { scan-assembler-not {vxor.vx} } } */ /* { dg-final { scan-assembler-not {vmul.vx} } } */ +/* { dg-final { scan-assembler-not {vdiv.vx} } } */ diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-3-i8.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-3-i8.c index 9bdce82..25ed2ad 100644 --- a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-3-i8.c +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-3-i8.c @@ -12,6 +12,7 @@ DEF_VX_BINARY_CASE_0_WRAP(T, &, and) DEF_VX_BINARY_CASE_0_WRAP(T, |, or) DEF_VX_BINARY_CASE_0_WRAP(T, ^, xor) DEF_VX_BINARY_CASE_0_WRAP(T, *, mul) +DEF_VX_BINARY_CASE_0_WRAP(T, /, div) /* { dg-final { scan-assembler-not {vadd.vx} } } */ /* { dg-final { scan-assembler-not {vsub.vx} } } */ @@ -20,3 +21,4 @@ DEF_VX_BINARY_CASE_0_WRAP(T, *, mul) /* { dg-final { scan-assembler-not {vor.vx} } } */ /* { dg-final { scan-assembler-not {vxor.vx} } } */ /* { dg-final { scan-assembler-not {vmul.vx} } } */ +/* { dg-final { scan-assembler-not {vdiv.vx} } } */ diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-4-i16.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-4-i16.c index a1b24f7..1e409de 100644 --- a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-4-i16.c +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-4-i16.c @@ -12,6 +12,7 @@ DEF_VX_BINARY_CASE_1_WRAP(T, &, and, VX_BINARY_BODY_X16) DEF_VX_BINARY_CASE_1_WRAP(T, |, or, VX_BINARY_BODY_X16) DEF_VX_BINARY_CASE_1_WRAP(T, ^, xor, VX_BINARY_BODY_X16) DEF_VX_BINARY_CASE_1_WRAP(T, *, mul, VX_BINARY_BODY_X16) +DEF_VX_BINARY_CASE_1_WRAP(T, /, div, VX_BINARY_BODY_X16) /* { dg-final { scan-assembler {vadd.vx} } } */ /* { dg-final { scan-assembler {vsub.vx} } } */ @@ -20,3 +21,4 @@ DEF_VX_BINARY_CASE_1_WRAP(T, *, mul, VX_BINARY_BODY_X16) /* { dg-final { scan-assembler {vor.vx} } } */ /* { dg-final { scan-assembler {vxor.vx} } } */ /* { dg-final { scan-assembler {vmul.vx} } } */ +/* { dg-final { scan-assembler {vdiv.vx} } } */ diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-4-i32.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-4-i32.c index 53bd744..2f242c7 100644 --- a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-4-i32.c +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-4-i32.c @@ -12,6 +12,7 @@ DEF_VX_BINARY_CASE_1_WRAP(T, &, and, VX_BINARY_BODY_X4) DEF_VX_BINARY_CASE_1_WRAP(T, |, or, VX_BINARY_BODY_X4) DEF_VX_BINARY_CASE_1_WRAP(T, ^, xor, VX_BINARY_BODY_X4) DEF_VX_BINARY_CASE_1_WRAP(T, *, mul, VX_BINARY_BODY_X4) +DEF_VX_BINARY_CASE_1_WRAP(T, /, div, VX_BINARY_BODY_X4) /* { dg-final { scan-assembler {vadd.vx} } } */ /* { dg-final { scan-assembler {vsub.vx} } } */ @@ -20,3 +21,4 @@ DEF_VX_BINARY_CASE_1_WRAP(T, *, mul, VX_BINARY_BODY_X4) /* { dg-final { scan-assembler {vor.vx} } } */ /* { dg-final { scan-assembler {vxor.vx} } } */ /* { dg-final { scan-assembler {vmul.vx} } } */ +/* { dg-final { scan-assembler {vdiv.vx} } } */ diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-4-i64.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-4-i64.c index 73cb89d..f027bd8 100644 --- a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-4-i64.c +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-4-i64.c @@ -12,6 +12,7 @@ DEF_VX_BINARY_CASE_1_WRAP(T, &, and, VX_BINARY_BODY) DEF_VX_BINARY_CASE_1_WRAP(T, |, or, VX_BINARY_BODY) DEF_VX_BINARY_CASE_1_WRAP(T, ^, xor, VX_BINARY_BODY) DEF_VX_BINARY_CASE_1_WRAP(T, *, mul, VX_BINARY_BODY) +DEF_VX_BINARY_CASE_1_WRAP(T, /, div, VX_BINARY_BODY) /* { dg-final { scan-assembler {vadd.vx} } } */ /* { dg-final { scan-assembler {vsub.vx} } } */ @@ -20,3 +21,4 @@ DEF_VX_BINARY_CASE_1_WRAP(T, *, mul, VX_BINARY_BODY) /* { dg-final { scan-assembler {vor.vx} } } */ /* { dg-final { scan-assembler {vxor.vx} } } */ /* { dg-final { scan-assembler {vmul.vx} } } */ +/* { dg-final { scan-assembler {vdiv.vx} } } */ diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-4-i8.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-4-i8.c index ec20474..c4f55b0 100644 --- a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-4-i8.c +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-4-i8.c @@ -12,6 +12,7 @@ DEF_VX_BINARY_CASE_1_WRAP(T, &, and, VX_BINARY_BODY_X16) DEF_VX_BINARY_CASE_1_WRAP(T, |, or, VX_BINARY_BODY_X16) DEF_VX_BINARY_CASE_1_WRAP(T, ^, xor, VX_BINARY_BODY_X16) DEF_VX_BINARY_CASE_1_WRAP(T, *, mul, VX_BINARY_BODY_X16) +DEF_VX_BINARY_CASE_1_WRAP(T, /, div, VX_BINARY_BODY_X8) /* { dg-final { scan-assembler {vadd.vx} } } */ /* { dg-final { scan-assembler {vsub.vx} } } */ @@ -20,3 +21,4 @@ DEF_VX_BINARY_CASE_1_WRAP(T, *, mul, VX_BINARY_BODY_X16) /* { dg-final { scan-assembler {vor.vx} } } */ /* { dg-final { scan-assembler {vxor.vx} } } */ /* { dg-final { scan-assembler {vmul.vx} } } */ +/* { dg-final { scan-assembler {vdiv.vx} } } */ diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-5-i16.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-5-i16.c index 902ba1e..d6b05bc 100644 --- a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-5-i16.c +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-5-i16.c @@ -12,6 +12,7 @@ DEF_VX_BINARY_CASE_1_WRAP(T, &, and, VX_BINARY_BODY_X8) DEF_VX_BINARY_CASE_1_WRAP(T, |, or, VX_BINARY_BODY_X8) DEF_VX_BINARY_CASE_1_WRAP(T, ^, xor, VX_BINARY_BODY_X8) DEF_VX_BINARY_CASE_1_WRAP(T, *, mul, VX_BINARY_BODY_X8) +DEF_VX_BINARY_CASE_1_WRAP(T, /, div, VX_BINARY_BODY_X8) /* { dg-final { scan-assembler-not {vadd.vx} } } */ /* { dg-final { scan-assembler {vsub.vx} } } */ @@ -20,3 +21,4 @@ DEF_VX_BINARY_CASE_1_WRAP(T, *, mul, VX_BINARY_BODY_X8) /* { dg-final { scan-assembler {vor.vx} } } */ /* { dg-final { scan-assembler {vxor.vx} } } */ /* { dg-final { scan-assembler-not {vmul.vx} } } */ +/* { dg-final { scan-assembler {vdiv.vx} } } */ diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-5-i32.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-5-i32.c index e57cee6..e1c043f 100644 --- a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-5-i32.c +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-5-i32.c @@ -12,6 +12,7 @@ DEF_VX_BINARY_CASE_1_WRAP(T, &, and, VX_BINARY_BODY_X4) DEF_VX_BINARY_CASE_1_WRAP(T, |, or, VX_BINARY_BODY_X4) DEF_VX_BINARY_CASE_1_WRAP(T, ^, xor, VX_BINARY_BODY_X4) DEF_VX_BINARY_CASE_1_WRAP(T, *, mul, VX_BINARY_BODY_X4) +DEF_VX_BINARY_CASE_1_WRAP(T, /, div, VX_BINARY_BODY_X4) /* { dg-final { scan-assembler {vadd.vx} } } */ /* { dg-final { scan-assembler {vsub.vx} } } */ @@ -20,3 +21,4 @@ DEF_VX_BINARY_CASE_1_WRAP(T, *, mul, VX_BINARY_BODY_X4) /* { dg-final { scan-assembler {vor.vx} } } */ /* { dg-final { scan-assembler {vxor.vx} } } */ /* { dg-final { scan-assembler {vmul.vx} } } */ +/* { dg-final { scan-assembler {vdiv.vx} } } */ diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-5-i64.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-5-i64.c index 3b4138d..1beb914 100644 --- a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-5-i64.c +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-5-i64.c @@ -12,6 +12,7 @@ DEF_VX_BINARY_CASE_1_WRAP(T, &, and, VX_BINARY_BODY) DEF_VX_BINARY_CASE_1_WRAP(T, |, or, VX_BINARY_BODY) DEF_VX_BINARY_CASE_1_WRAP(T, ^, xor, VX_BINARY_BODY) DEF_VX_BINARY_CASE_1_WRAP(T, *, mul, VX_BINARY_BODY) +DEF_VX_BINARY_CASE_1_WRAP(T, /, div, VX_BINARY_BODY) /* { dg-final { scan-assembler {vadd.vx} } } */ /* { dg-final { scan-assembler {vsub.vx} } } */ @@ -20,3 +21,4 @@ DEF_VX_BINARY_CASE_1_WRAP(T, *, mul, VX_BINARY_BODY) /* { dg-final { scan-assembler {vor.vx} } } */ /* { dg-final { scan-assembler {vxor.vx} } } */ /* { dg-final { scan-assembler {vmul.vx} } } */ +/* { dg-final { scan-assembler {vdiv.vx} } } */ diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-5-i8.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-5-i8.c index 0ad52b2..0291517 100644 --- a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-5-i8.c +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-5-i8.c @@ -12,6 +12,7 @@ DEF_VX_BINARY_CASE_1_WRAP(T, &, and, VX_BINARY_BODY_X16) DEF_VX_BINARY_CASE_1_WRAP(T, |, or, VX_BINARY_BODY_X16) DEF_VX_BINARY_CASE_1_WRAP(T, ^, xor, VX_BINARY_BODY_X16) DEF_VX_BINARY_CASE_1_WRAP(T, *, mul, VX_BINARY_BODY_X16) +DEF_VX_BINARY_CASE_1_WRAP(T, /, div, VX_BINARY_BODY_X8) /* { dg-final { scan-assembler-not {vadd.vx} } } */ /* { dg-final { scan-assembler {vsub.vx} } } */ @@ -20,3 +21,4 @@ DEF_VX_BINARY_CASE_1_WRAP(T, *, mul, VX_BINARY_BODY_X16) /* { dg-final { scan-assembler {vor.vx} } } */ /* { dg-final { scan-assembler {vxor.vx} } } */ /* { dg-final { scan-assembler-not {vmul.vx} } } */ +/* { dg-final { scan-assembler {vdiv.vx} } } */ diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-6-i16.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-6-i16.c index 5e04050..c22c82d 100644 --- a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-6-i16.c +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-6-i16.c @@ -12,6 +12,7 @@ DEF_VX_BINARY_CASE_1_WRAP(T, &, and, VX_BINARY_BODY_X8) DEF_VX_BINARY_CASE_1_WRAP(T, |, or, VX_BINARY_BODY_X8) DEF_VX_BINARY_CASE_1_WRAP(T, ^, xor, VX_BINARY_BODY_X8) DEF_VX_BINARY_CASE_1_WRAP(T, *, mul, VX_BINARY_BODY_X8) +DEF_VX_BINARY_CASE_1_WRAP(T, /, div, VX_BINARY_BODY_X8) /* { dg-final { scan-assembler-not {vadd.vx} } } */ /* { dg-final { scan-assembler {vsub.vx} } } */ @@ -20,3 +21,4 @@ DEF_VX_BINARY_CASE_1_WRAP(T, *, mul, VX_BINARY_BODY_X8) /* { dg-final { scan-assembler {vor.vx} } } */ /* { dg-final { scan-assembler {vxor.vx} } } */ /* { dg-final { scan-assembler-not {vmul.vx} } } */ +/* { dg-final { scan-assembler {vdiv.vx} } } */ diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-6-i32.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-6-i32.c index 13a9fe2..dc35600 100644 --- a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-6-i32.c +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-6-i32.c @@ -12,6 +12,7 @@ DEF_VX_BINARY_CASE_1_WRAP(T, &, and, VX_BINARY_BODY_X4) DEF_VX_BINARY_CASE_1_WRAP(T, |, or, VX_BINARY_BODY_X4) DEF_VX_BINARY_CASE_1_WRAP(T, ^, xor, VX_BINARY_BODY_X4) DEF_VX_BINARY_CASE_1_WRAP(T, *, mul, VX_BINARY_BODY_X4) +DEF_VX_BINARY_CASE_1_WRAP(T, /, div, VX_BINARY_BODY_X4) /* { dg-final { scan-assembler {vadd.vx} } } */ /* { dg-final { scan-assembler {vsub.vx} } } */ @@ -20,3 +21,4 @@ DEF_VX_BINARY_CASE_1_WRAP(T, *, mul, VX_BINARY_BODY_X4) /* { dg-final { scan-assembler {vor.vx} } } */ /* { dg-final { scan-assembler {vxor.vx} } } */ /* { dg-final { scan-assembler {vmul.vx} } } */ +/* { dg-final { scan-assembler {vdiv.vx} } } */ diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-6-i64.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-6-i64.c index ca515b4..cee1e3a 100644 --- a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-6-i64.c +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-6-i64.c @@ -12,6 +12,7 @@ DEF_VX_BINARY_CASE_1_WRAP(T, &, and, VX_BINARY_BODY) DEF_VX_BINARY_CASE_1_WRAP(T, |, or, VX_BINARY_BODY) DEF_VX_BINARY_CASE_1_WRAP(T, ^, xor, VX_BINARY_BODY) DEF_VX_BINARY_CASE_1_WRAP(T, *, mul, VX_BINARY_BODY) +DEF_VX_BINARY_CASE_1_WRAP(T, /, div, VX_BINARY_BODY) /* { dg-final { scan-assembler-not {vadd.vx} } } */ /* { dg-final { scan-assembler-not {vsub.vx} } } */ @@ -20,3 +21,4 @@ DEF_VX_BINARY_CASE_1_WRAP(T, *, mul, VX_BINARY_BODY) /* { dg-final { scan-assembler-not {vor.vx} } } */ /* { dg-final { scan-assembler-not {vxor.vx} } } */ /* { dg-final { scan-assembler-not {vmul.vx} } } */ +/* { dg-final { scan-assembler-not {vdiv.vx} } } */ diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-6-i8.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-6-i8.c index 70e1abc..74fd2fb 100644 --- a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-6-i8.c +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx-6-i8.c @@ -12,6 +12,7 @@ DEF_VX_BINARY_CASE_1_WRAP(T, &, and, VX_BINARY_BODY_X16) DEF_VX_BINARY_CASE_1_WRAP(T, |, or, VX_BINARY_BODY_X16) DEF_VX_BINARY_CASE_1_WRAP(T, ^, xor, VX_BINARY_BODY_X16) DEF_VX_BINARY_CASE_1_WRAP(T, *, mul, VX_BINARY_BODY_X16) +DEF_VX_BINARY_CASE_1_WRAP(T, /, div, VX_BINARY_BODY_X8) /* { dg-final { scan-assembler-not {vadd.vx} } } */ /* { dg-final { scan-assembler {vsub.vx} } } */ @@ -20,3 +21,4 @@ DEF_VX_BINARY_CASE_1_WRAP(T, *, mul, VX_BINARY_BODY_X16) /* { dg-final { scan-assembler {vor.vx} } } */ /* { dg-final { scan-assembler {vxor.vx} } } */ /* { dg-final { scan-assembler-not {vmul.vx} } } */ +/* { dg-final { scan-assembler {vdiv.vx} } } */ diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx_binary_data.h b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx_binary_data.h index c7289ac..ed8c562 100644 --- a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx_binary_data.h +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx_binary_data.h @@ -2554,4 +2554,200 @@ int64_t TEST_BINARY_DATA(int64_t, mul)[][3][N] = }, }; +int8_t TEST_BINARY_DATA(int8_t, div)[][3][N] = +{ + { + { 1 }, + { + 2, 2, 2, 2, + 1, 1, 1, 1, + -1, -1, -1, -1, + -2, -2, -2, -2, + }, + { + 2, 2, 2, 2, + 1, 1, 1, 1, + -1, -1, -1, -1, + -2, -2, -2, -2, + }, + }, + { + { 127 }, + { + 127, 127, 127, 127, + -1, -1, -1, -1, + -128, -128, -128, -128, + -2, -2, -2, -2, + }, + { + 1, 1, 1, 1, + 0, 0, 0, 0, + -1, -1, -1, -1, + 0, 0, 0, 0, + }, + }, + { + { -128 }, + { + -128, -128, -128, -128, + 1, 1, 1, 1, + 127, 127, 127, 127, + 2, 2, 2, 2, + }, + { + 1, 1, 1, 1, + 0, 0, 0, 0, + 0, 0, 0, 0, + 0, 0, 0, 0, + }, + }, +}; + +int16_t TEST_BINARY_DATA(int16_t, div)[][3][N] = +{ + { + { 1 }, + { + 2, 2, 2, 2, + 1, 1, 1, 1, + -1, -1, -1, -1, + -2, -2, -2, -2, + }, + { + 2, 2, 2, 2, + 1, 1, 1, 1, + -1, -1, -1, -1, + -2, -2, -2, -2, + }, + }, + { + { 32767 }, + { + 32767, 32767, 32767, 32767, + -1, -1, -1, -1, + -32768, -32768, -32768, -32768, + -2, -2, -2, -2, + }, + { + 1, 1, 1, 1, + 0, 0, 0, 0, + -1, -1, -1, -1, + 0, 0, 0, 0, + }, + }, + { + { -32768 }, + { + -32768, -32768, -32768, -32768, + 1, 1, 1, 1, + 32767, 32767, 32767, 32767, + 2, 2, 2, 2, + }, + { + 1, 1, 1, 1, + 0, 0, 0, 0, + 0, 0, 0, 0, + 0, 0, 0, 0, + }, + }, +}; + +int32_t TEST_BINARY_DATA(int32_t, div)[][3][N] = +{ + { + { 1 }, + { + 2, 2, 2, 2, + 1, 1, 1, 1, + -1, -1, -1, -1, + -2, -2, -2, -2, + }, + { + 2, 2, 2, 2, + 1, 1, 1, 1, + -1, -1, -1, -1, + -2, -2, -2, -2, + }, + }, + { + { 2147483647 }, + { + 2147483647, 2147483647, 2147483647, 2147483647, + -1, -1, -1, -1, + -2147483648, -2147483648, -2147483648, -2147483648, + -2, -2, -2, -2, + }, + { + 1, 1, 1, 1, + 0, 0, 0, 0, + -1, -1, -1, -1, + 0, 0, 0, 0, + }, + }, + { + { -2147483648 }, + { + -2147483648, -2147483648, -2147483648, -2147483648, + 1, 1, 1, 1, + 2147483647, 2147483647, 2147483647, 2147483647, + 2, 2, 2, 2, + }, + { + 1, 1, 1, 1, + 0, 0, 0, 0, + 0, 0, 0, 0, + 0, 0, 0, 0, + }, + }, +}; + +int64_t TEST_BINARY_DATA(int64_t, div)[][3][N] = +{ + { + { 1 }, + { + 2, 2, 2, 2, + 1, 1, 1, 1, + -1, -1, -1, -1, + -2, -2, -2, -2, + }, + { + 2, 2, 2, 2, + 1, 1, 1, 1, + -1, -1, -1, -1, + -2, -2, -2, -2, + }, + }, + { + { 9223372036854775807ll }, + { + 9223372036854775807ll, 9223372036854775807ll, 9223372036854775807ll, 9223372036854775807ll, + -1, -1, -1, -1, + -9223372036854775808ull, -9223372036854775808ull, -9223372036854775808ull, -9223372036854775808ull, + -2, -2, -2, -2, + }, + { + 1, 1, 1, 1, + 0, 0, 0, 0, + -1, -1, -1, -1, + 0, 0, 0, 0, + }, + }, + { + { -9223372036854775808ull }, + { + -9223372036854775808ull, -9223372036854775808ull, -9223372036854775808ull, -9223372036854775808ull, + 1, 1, 1, 1, + 9223372036854775807ll, 9223372036854775807ll, 9223372036854775807ll, 9223372036854775807ll, + 2, 2, 2, 2, + }, + { + 1, 1, 1, 1, + 0, 0, 0, 0, + 0, 0, 0, 0, + 0, 0, 0, 0, + }, + }, +}; + #endif diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx_vdiv-run-1-i16.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx_vdiv-run-1-i16.c new file mode 100644 index 0000000..64cf31c --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx_vdiv-run-1-i16.c @@ -0,0 +1,15 @@ +/* { dg-do run { target { riscv_v } } } */ +/* { dg-additional-options "-std=c99 --param=gpr2vr-cost=0" } */ + +#include "vx_binary.h" +#include "vx_binary_data.h" + +#define T int16_t +#define NAME div + +DEF_VX_BINARY_CASE_0_WRAP(T, /, NAME) + +#define TEST_DATA TEST_BINARY_DATA_WRAP(T, NAME) +#define TEST_RUN(T, NAME, out, in, x, n) RUN_VX_BINARY_CASE_0_WRAP(T, NAME, out, in, x, n) + +#include "vx_binary_run.h" diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx_vdiv-run-1-i32.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx_vdiv-run-1-i32.c new file mode 100644 index 0000000..2fe6623 --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx_vdiv-run-1-i32.c @@ -0,0 +1,15 @@ +/* { dg-do run { target { riscv_v } } } */ +/* { dg-additional-options "-std=c99 --param=gpr2vr-cost=0" } */ + +#include "vx_binary.h" +#include "vx_binary_data.h" + +#define T int32_t +#define NAME div + +DEF_VX_BINARY_CASE_0_WRAP(T, /, NAME) + +#define TEST_DATA TEST_BINARY_DATA_WRAP(T, NAME) +#define TEST_RUN(T, NAME, out, in, x, n) RUN_VX_BINARY_CASE_0_WRAP(T, NAME, out, in, x, n) + +#include "vx_binary_run.h" diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx_vdiv-run-1-i64.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx_vdiv-run-1-i64.c new file mode 100644 index 0000000..03dbe03 --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx_vdiv-run-1-i64.c @@ -0,0 +1,15 @@ +/* { dg-do run { target { riscv_v } } } */ +/* { dg-additional-options "-std=c99 --param=gpr2vr-cost=0" } */ + +#include "vx_binary.h" +#include "vx_binary_data.h" + +#define T int64_t +#define NAME div + +DEF_VX_BINARY_CASE_0_WRAP(T, /, NAME) + +#define TEST_DATA TEST_BINARY_DATA_WRAP(T, NAME) +#define TEST_RUN(T, NAME, out, in, x, n) RUN_VX_BINARY_CASE_0_WRAP(T, NAME, out, in, x, n) + +#include "vx_binary_run.h" diff --git a/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx_vdiv-run-1-i8.c b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx_vdiv-run-1-i8.c new file mode 100644 index 0000000..e54e5bc --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/rvv/autovec/vx_vf/vx_vdiv-run-1-i8.c @@ -0,0 +1,15 @@ +/* { dg-do run { target { riscv_v } } } */ +/* { dg-additional-options "-std=c99 --param=gpr2vr-cost=0" } */ + +#include "vx_binary.h" +#include "vx_binary_data.h" + +#define T int8_t +#define NAME div + +DEF_VX_BINARY_CASE_0_WRAP(T, /, NAME) + +#define TEST_DATA TEST_BINARY_DATA_WRAP(T, NAME) +#define TEST_RUN(T, NAME, out, in, x, n) RUN_VX_BINARY_CASE_0_WRAP(T, NAME, out, in, x, n) + +#include "vx_binary_run.h" diff --git a/gcc/testsuite/gfortran.dg/coarray_data_2.f90 b/gcc/testsuite/gfortran.dg/coarray_data_2.f90 new file mode 100644 index 0000000..bda57f3 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray_data_2.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! { dg-additional-options "-fcoarray=lib -Warray-temporaries" } +! +! PR fortran/99838 - ICE due to missing locus with data statement for coarray +! +! Contributed by Gerhard Steinmetz + +program p + type t + integer :: a + end type + type(t) :: x(3)[*] + data x%a /1, 2, 3/ ! { dg-warning "Creating array temporary" } +end diff --git a/gcc/testsuite/gfortran.dg/inline_matmul_16.f90 b/gcc/testsuite/gfortran.dg/inline_matmul_16.f90 index 580cb1a..bb1a3cb 100644 --- a/gcc/testsuite/gfortran.dg/inline_matmul_16.f90 +++ b/gcc/testsuite/gfortran.dg/inline_matmul_16.f90 @@ -58,4 +58,4 @@ program main end do end do end program main -! { dg-final { scan-tree-dump-times "_gfortran_matmul" 1 "optimized" } } +! { dg-final { scan-tree-dump-not "_gfortran_matmul" "optimized" } } diff --git a/gcc/testsuite/gfortran.dg/inline_matmul_26.f90 b/gcc/testsuite/gfortran.dg/inline_matmul_26.f90 new file mode 100644 index 0000000..0876941 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/inline_matmul_26.f90 @@ -0,0 +1,36 @@ +! { dg-do run } +! { dg-options "-ffrontend-optimize -fdump-tree-optimized -Wrealloc-lhs -finline-matmul-limit=1000 -O" } +! PR 66094: Check functionality for MATMUL(TRANSPOSE(A),B)) for two-dimensional arrays +program main + implicit none + integer :: in, im, icnt + integer, volatile :: ten + + ten = 10 + ! cycle through a few test cases... + do in = 2,ten + do im = 2,ten + do icnt = 2,ten + block + real, dimension(icnt,in) :: a2 + real, dimension(icnt,im) :: b2 + real, dimension(in,im) :: c2,cr + integer :: i,j,k + call random_number(a2) + call random_number(b2) + c2 = 0 + do i=1,size(a2,2) + do j=1, size(b2,2) + do k=1, size(a2,1) + c2(i,j) = c2(i,j) + a2(k,i) * b2(k,j) + end do + end do + end do + cr = matmul(transpose(a2), b2) + if (any(abs(c2-cr) > 1e-4)) STOP 7 + end block + end do + end do + end do +end program main +! { dg-final { scan-tree-dump-times "_gfortran_matmul" 1 "optimized" } } diff --git a/gcc/testsuite/gfortran.dg/save_8.f90 b/gcc/testsuite/gfortran.dg/save_8.f90 new file mode 100644 index 0000000..8e9198c --- /dev/null +++ b/gcc/testsuite/gfortran.dg/save_8.f90 @@ -0,0 +1,13 @@ +!{ dg-do run } + +! Check PR120483 is fixed. +! Contributed by Thomas Koenig <tkoenig@gcc.gnu.org> +! and Peter Güntert <peter@guentert.com> + +program save_8 + implicit none + character(len=:), allocatable, save :: s1 + s1 = 'ABC' + if (s1(3:3) /= 'C') stop 1 +end program save_8 + diff --git a/gcc/testsuite/gnat.dg/specs/opt7.ads b/gcc/testsuite/gnat.dg/specs/opt7.ads new file mode 100644 index 0000000..ee151f0 --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/opt7.ads @@ -0,0 +1,15 @@ +-- { dg-do compile } +-- { dg-options "-O2 -gnatn" } + +with Opt7_Pkg; use Opt7_Pkg; + +package Opt7 is + + type Rec is record + E : Enum; + end record; + + function Image (R : Rec) return String is + (if R.E = A then Image (R.E) else ""); + +end Opt7; diff --git a/gcc/testsuite/gnat.dg/specs/opt7_pkg.adb b/gcc/testsuite/gnat.dg/specs/opt7_pkg.adb new file mode 100644 index 0000000..1c9d79b --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/opt7_pkg.adb @@ -0,0 +1,15 @@ +package body Opt7_Pkg is + + type Constant_String_Access is access constant String; + + type Enum_Name is array (Enum) of Constant_String_Access; + + Enum_Name_Table : constant Enum_Name := + (A => new String'("A"), B => new String'("B")); + + function Image (E : Enum) return String is + begin + return Enum_Name_Table (E).all; + end Image; + +end Opt7_Pkg; diff --git a/gcc/testsuite/gnat.dg/specs/opt7_pkg.ads b/gcc/testsuite/gnat.dg/specs/opt7_pkg.ads new file mode 100644 index 0000000..2dd271b --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/opt7_pkg.ads @@ -0,0 +1,9 @@ +-- { dg-excess-errors "no code generated" } + +package Opt7_Pkg is + + type Enum is (A, B); + + function Image (E : Enum) return String with Inline; + +end Opt7_Pkg; diff --git a/gcc/tree-eh.cc b/gcc/tree-eh.cc index a4d5995..8cc81eb 100644 --- a/gcc/tree-eh.cc +++ b/gcc/tree-eh.cc @@ -2538,6 +2538,13 @@ operation_could_trap_helper_p (enum tree_code op, /* Constructing an object cannot trap. */ return false; + case FIX_TRUNC_EXPR: + case VEC_PACK_FIX_TRUNC_EXPR: + case VEC_UNPACK_FIX_TRUNC_HI_EXPR: + case VEC_UNPACK_FIX_TRUNC_LO_EXPR: + /* The FIX_TRUNC family are always potentially trapping. */ + return flag_trapping_math; + case COND_EXPR: case VEC_COND_EXPR: /* Whether *COND_EXPR can trap depends on whether the diff --git a/gcc/tree-sra.cc b/gcc/tree-sra.cc index 4b6daf7..23236fc 100644 --- a/gcc/tree-sra.cc +++ b/gcc/tree-sra.cc @@ -3760,7 +3760,7 @@ sra_get_max_scalarization_size (void) /* If the user didn't set PARAM_SRA_MAX_SCALARIZATION_SIZE_<...>, fall back to a target default. */ unsigned HOST_WIDE_INT max_scalarization_size - = get_move_ratio (optimize_speed_p) * UNITS_PER_WORD; + = get_move_ratio (optimize_speed_p) * MOVE_MAX; if (optimize_speed_p) { diff --git a/gcc/tree-ssa-ccp.cc b/gcc/tree-ssa-ccp.cc index 8d2cbb3..13cd81d 100644 --- a/gcc/tree-ssa-ccp.cc +++ b/gcc/tree-ssa-ccp.cc @@ -298,7 +298,7 @@ get_default_value (tree var) { val.lattice_val = VARYING; val.mask = -1; - if (flag_tree_bit_ccp) + if (flag_tree_bit_ccp && !VECTOR_TYPE_P (TREE_TYPE (var))) { wide_int nonzero_bits = get_nonzero_bits (var); tree value; @@ -2491,11 +2491,11 @@ evaluate_stmt (gimple *stmt) is_constant = (val.lattice_val == CONSTANT); } + tree lhs = gimple_get_lhs (stmt); if (flag_tree_bit_ccp + && lhs && TREE_CODE (lhs) == SSA_NAME && !VECTOR_TYPE_P (TREE_TYPE (lhs)) && ((is_constant && TREE_CODE (val.value) == INTEGER_CST) - || !is_constant) - && gimple_get_lhs (stmt) - && TREE_CODE (gimple_get_lhs (stmt)) == SSA_NAME) + || !is_constant)) { tree lhs = gimple_get_lhs (stmt); wide_int nonzero_bits = get_nonzero_bits (lhs); @@ -2567,7 +2567,12 @@ insert_clobber_before_stack_restore (tree saved_val, tree var, { clobber = build_clobber (TREE_TYPE (var), CLOBBER_STORAGE_END); clobber_stmt = gimple_build_assign (var, clobber); - + /* Manually update the vdef/vuse here. */ + gimple_set_vuse (clobber_stmt, gimple_vuse (stmt)); + gimple_set_vdef (clobber_stmt, make_ssa_name (gimple_vop (cfun))); + gimple_set_vuse (stmt, gimple_vdef (clobber_stmt)); + SSA_NAME_DEF_STMT (gimple_vdef (clobber_stmt)) = clobber_stmt; + update_stmt (stmt); i = gsi_for_stmt (stmt); gsi_insert_before (&i, clobber_stmt, GSI_SAME_STMT); } @@ -3020,7 +3025,7 @@ do_ssa_ccp (bool nonzero_p) ccp_propagate.ssa_propagate (); if (ccp_finalize (nonzero_p || flag_ipa_bit_cp)) { - todo = (TODO_cleanup_cfg | TODO_update_ssa); + todo = TODO_cleanup_cfg; /* ccp_finalize does not preserve loop-closed ssa. */ loops_state_clear (LOOP_CLOSED_SSA); diff --git a/gcc/tree-ssa-forwprop.cc b/gcc/tree-ssa-forwprop.cc index 75901ec..27197bb 100644 --- a/gcc/tree-ssa-forwprop.cc +++ b/gcc/tree-ssa-forwprop.cc @@ -1343,6 +1343,88 @@ optimize_memcpy_to_memset (gimple_stmt_iterator *gsip, tree dest, tree src, tree } return true; } +/* Optimizes + a = c; + b = a; + into + a = c; + b = c; + GSIP is the second statement and SRC is the common + between the statements. +*/ +static bool +optimize_agr_copyprop (gimple_stmt_iterator *gsip) +{ + gimple *stmt = gsi_stmt (*gsip); + if (gimple_has_volatile_ops (stmt)) + return false; + + tree dest = gimple_assign_lhs (stmt); + tree src = gimple_assign_rhs1 (stmt); + /* If the statement is `src = src;` then ignore it. */ + if (operand_equal_p (dest, src, 0)) + return false; + + tree vuse = gimple_vuse (stmt); + /* If the vuse is the default definition, then there is no store beforehand. */ + if (SSA_NAME_IS_DEFAULT_DEF (vuse)) + return false; + gimple *defstmt = SSA_NAME_DEF_STMT (vuse); + if (!gimple_assign_load_p (defstmt) + || !gimple_store_p (defstmt)) + return false; + if (gimple_has_volatile_ops (defstmt)) + return false; + + tree dest2 = gimple_assign_lhs (defstmt); + tree src2 = gimple_assign_rhs1 (defstmt); + + /* If the original store is `src2 = src2;` skip over it. */ + if (operand_equal_p (src2, dest2, 0)) + return false; + if (!operand_equal_p (src, dest2, 0)) + return false; + + + /* For 2 memory refences and using a temporary to do the copy, + don't remove the temporary as the 2 memory references might overlap. + Note t does not need to be decl as it could be field. + See PR 22237 for full details. + E.g. + t = *a; + *b = t; + Cannot be convert into + t = *a; + *b = *a; + Though the following is allowed to be done: + t = *a; + *a = t; + And convert it into: + t = *a; + *a = *a; + */ + if (!operand_equal_p (src2, dest, 0) + && !DECL_P (dest) && !DECL_P (src2)) + return false; + + if (dump_file && (dump_flags & TDF_DETAILS)) + { + fprintf (dump_file, "Simplified\n "); + print_gimple_stmt (dump_file, stmt, 0, dump_flags); + fprintf (dump_file, "after previous\n "); + print_gimple_stmt (dump_file, defstmt, 0, dump_flags); + } + gimple_assign_set_rhs_from_tree (gsip, unshare_expr (src2)); + update_stmt (stmt); + + if (dump_file && (dump_flags & TDF_DETAILS)) + { + fprintf (dump_file, "into\n "); + print_gimple_stmt (dump_file, stmt, 0, dump_flags); + } + statistics_counter_event (cfun, "copy prop for aggregate", 1); + return true; +} /* *GSI_P is a GIMPLE_CALL to a builtin function. Optimize @@ -4724,6 +4806,11 @@ pass_forwprop::execute (function *fun) changed = true; break; } + if (optimize_agr_copyprop (&gsi)) + { + changed = true; + break; + } } if (TREE_CODE_CLASS (code) == tcc_comparison) diff --git a/gcc/tree-ssanames.cc b/gcc/tree-ssanames.cc index fd2abfe..b6ca880 100644 --- a/gcc/tree-ssanames.cc +++ b/gcc/tree-ssanames.cc @@ -508,6 +508,14 @@ get_nonzero_bits_1 (const_tree name) /* Use element_precision instead of TYPE_PRECISION so complex and vector types get a non-zero precision. */ unsigned int precision = element_precision (TREE_TYPE (name)); + + if (VECTOR_TYPE_P (TREE_TYPE (name))) + { + tree elem = uniform_vector_p (name); + if (elem) + return get_nonzero_bits_1 (elem); + } + if (TREE_CODE (name) != SSA_NAME) return wi::shwi (-1, precision); diff --git a/gcc/tree-switch-conversion.cc b/gcc/tree-switch-conversion.cc index bd4de96..d088287 100644 --- a/gcc/tree-switch-conversion.cc +++ b/gcc/tree-switch-conversion.cc @@ -1030,6 +1030,9 @@ switch_conversion::build_one_array (int num, tree arr_index_type, TREE_CONSTANT (decl) = 1; TREE_READONLY (decl) = 1; DECL_IGNORED_P (decl) = 1; + /* The decl is mergable since we don't take the address ever and + just reading from it. */ + DECL_MERGEABLE (decl) = 1; if (offloading_function_p (cfun->decl)) DECL_ATTRIBUTES (decl) = tree_cons (get_identifier ("omp declare target"), NULL_TREE, diff --git a/gcc/tree-vect-data-refs.cc b/gcc/tree-vect-data-refs.cc index f2deb75..036903a 100644 --- a/gcc/tree-vect-data-refs.cc +++ b/gcc/tree-vect-data-refs.cc @@ -3685,7 +3685,7 @@ vect_analyze_data_ref_accesses (vec_info *vinfo, /* For datarefs with big gap, it's better to split them into different groups. .i.e a[0], a[1], a[2], .. a[7], a[100], a[101],..., a[107] */ - if ((unsigned HOST_WIDE_INT)(init_b - init_prev) * tree_to_uhwi (szb) + if ((unsigned HOST_WIDE_INT)(init_b - init_prev) > MAX_BITSIZE_MODE_ANY_MODE / BITS_PER_UNIT) break; @@ -7249,7 +7249,8 @@ vect_can_force_dr_alignment_p (const_tree decl, poly_uint64 alignment) return false; if (decl_in_symtab_p (decl) - && !symtab_node::get (decl)->can_increase_alignment_p ()) + && (!symtab_node::get (decl) + || !symtab_node::get (decl)->can_increase_alignment_p ())) return false; if (TREE_STATIC (decl)) diff --git a/gcc/var-tracking.cc b/gcc/var-tracking.cc index d70ed02..8732c3b 100644 --- a/gcc/var-tracking.cc +++ b/gcc/var-tracking.cc @@ -6273,7 +6273,7 @@ prepare_call_arguments (basic_block bb, rtx_insn *insn) if (SYMBOL_REF_DECL (symbol)) fndecl = SYMBOL_REF_DECL (symbol); } - if (fndecl == NULL_TREE) + if (fndecl == NULL_TREE && MEM_P (XEXP (call, 0))) fndecl = MEM_EXPR (XEXP (call, 0)); if (fndecl && TREE_CODE (TREE_TYPE (fndecl)) != FUNCTION_TYPE diff --git a/include/ChangeLog b/include/ChangeLog index 5110716..886dab6 100644 --- a/include/ChangeLog +++ b/include/ChangeLog @@ -1,3 +1,8 @@ +2025-06-02 Tobias Burnus <tburnus@baylibre.com> + + PR libgomp/120444 + * cuda/cuda.h (cuMemsetD8, cuMemsetD8Async): Declare. + 2025-05-30 Julian Brown <julian@codesourcery.com> Tobias Burnus <tburnus@baylibre.com> diff --git a/libgcobol/ChangeLog b/libgcobol/ChangeLog index 4293598..80057c1 100644 --- a/libgcobol/ChangeLog +++ b/libgcobol/ChangeLog @@ -1,3 +1,253 @@ +2025-06-04 Robert Dubner <rdubner@symas.com> + + PR cobol/119323 + * charmaps.cc (__gg__raw_to_ascii): Eliminate cppcheck warnings. + (__gg__raw_to_ebcdic): Likewise. + (__gg__ebcdic_to_console): Likewise. + (__gg__console_to_ascii): Likewise. + (__gg__console_to_ebcdic): Likewise. + * common-defs.h (struct cbl_declarative_t): Likewise. + * gfileio.cc (get_filename): Likewise. + (max_value): Likewise. + (relative_file_delete_varying): Likewise. + (relative_file_delete): Likewise. + (read_an_indexed_record): Likewise. + (position_state_restore): Likewise. + (indexed_file_delete): Likewise. + (indexed_file_start): Likewise. + (sequential_file_rewrite): Likewise. + (relative_file_write_varying): Likewise. + (relative_file_write): Likewise. + (sequential_file_write): Likewise. + (indexed_file_write): Likewise. + (__io__file_write): Likewise. + (line_sequential_file_read): Likewise. + (indexed_file_read): Likewise. + (file_indexed_open): Likewise. + (__gg__file_reopen): Likewise. + * gmath.cc (conditional_stash): Likewise. + (__gg__pow): Likewise. + (multiply_int256_by_int64): Likewise. + (add_int256_to_int256): Likewise. + (divide_int256_by_int64): Likewise. + (squeeze_int256): Likewise. + (get_int256_from_qualified_field): Likewise. + (__gg__add_fixed_phase1): Likewise. + (__gg__addf1_fixed_phase2): Likewise. + (__gg__fixed_phase2_assign_to_c): Likewise. + (__gg__add_float_phase1): Likewise. + (__gg__addf1_float_phase2): Likewise. + (__gg__float_phase2_assign_to_c): Likewise. + (__gg__addf3): Likewise. + (__gg__subtractf1_fixed_phase2): Likewise. + (__gg__subtractf2_fixed_phase1): Likewise. + (__gg__subtractf1_float_phase2): Likewise. + (__gg__subtractf2_float_phase1): Likewise. + (__gg__subtractf3): Likewise. + (__gg__multiplyf1_phase1): Likewise. + (multiply_int128_by_int128): Likewise. + (__gg__multiplyf1_phase2): Likewise. + (__gg__multiplyf2): Likewise. + (shift_in_place128): Likewise. + (divide_int128_by_int128): Likewise. + (__gg__dividef1_phase2): Likewise. + (__gg__dividef23): Likewise. + (__gg__dividef45): Likewise. + * intrinsic.cc (struct input_state): Likewise. + (get_value_as_double_from_qualified_field): Likewise. + (kahan_summation): Likewise. + (variance): Likewise. + (get_all_time): Likewise. + (populate_ctm_from_date): Likewise. + (populate_ctm_from_time): Likewise. + (ftime_replace): Likewise. + (__gg__abs): Likewise. + (__gg__acos): Likewise. + (__gg__annuity): Likewise. + (__gg__asin): Likewise. + (__gg__atan): Likewise. + (__gg__byte_length): Likewise. + (__gg__char): Likewise. + (__gg__combined_datetime): Likewise. + (__gg__cos): Likewise. + (__gg__date_of_integer): Likewise. + (__gg__date_to_yyyymmdd): Likewise. + (__gg__day_of_integer): Likewise. + (__gg__day_to_yyyyddd): Likewise. + (__gg__exp): Likewise. + (__gg__exp10): Likewise. + (__gg__factorial): Likewise. + (__gg__formatted_current_date): Likewise. + (__gg__formatted_date): Likewise. + (__gg__formatted_datetime): Likewise. + (__gg__formatted_time): Likewise. + (__gg__integer): Likewise. + (__gg__integer_of_date): Likewise. + (__gg__integer_of_day): Likewise. + (__gg__integer_part): Likewise. + (__gg__fraction_part): Likewise. + (__gg__log): Likewise. + (__gg__log10): Likewise. + (__gg__max): Likewise. + (__gg__lower_case): Likewise. + (__gg__median): Likewise. + (__gg__min): Likewise. + (numval): Likewise. + (numval_c): Likewise. + (__gg__numval): Likewise. + (__gg__test_numval): Likewise. + (__gg__numval_c): Likewise. + (__gg__test_numval_c): Likewise. + (__gg__ord): Likewise. + (__gg__rem): Likewise. + (__gg__trim): Likewise. + (__gg__random): Likewise. + (__gg__reverse): Likewise. + (__gg__sign): Likewise. + (__gg__sin): Likewise. + (__gg__sqrt): Likewise. + (__gg__tan): Likewise. + (__gg__test_date_yyyymmdd): Likewise. + (__gg__test_day_yyyyddd): Likewise. + (__gg__upper_case): Likewise. + (__gg__year_to_yyyy): Likewise. + (gets_int): Likewise. + (gets_year): Likewise. + (gets_month): Likewise. + (gets_day): Likewise. + (gets_day_of_week): Likewise. + (gets_day_of_year): Likewise. + (gets_week): Likewise. + (gets_hours): Likewise. + (gets_minutes): Likewise. + (gets_seconds): Likewise. + (gets_nanoseconds): Likewise. + (fill_cobol_tm): Likewise. + (__gg__test_formatted_datetime): Likewise. + (__gg__integer_of_formatted_date): Likewise. + (__gg__seconds_from_formatted_time): Likewise. + (__gg__hex_of): Likewise. + (__gg__highest_algebraic): Likewise. + (__gg__lowest_algebraic): Likewise. + (floating_format_tester): Likewise. + (__gg__numval_f): Likewise. + (__gg__test_numval_f): Likewise. + (ismatch): Likewise. + (iscasematch): Likewise. + (strstr): Likewise. + (strcasestr): Likewise. + (strlaststr): Likewise. + (strcaselaststr): Likewise. + (__gg__substitute): Likewise. + (__gg__locale_compare): Likewise. + (__gg__locale_date): Likewise. + (__gg__locale_time): Likewise. + (__gg__locale_time_from_seconds): Likewise. + * libgcobol.cc (class ec_status_t): Likewise. + (__gg__set_truncation_mode): Likewise. + (malloc): Likewise. + (__gg__mabort): Likewise. + (__gg__resize_int_p): Likewise. + (__gg__resize_treeplet): Likewise. + (var_is_refmod): Likewise. + (value_is_too_big): Likewise. + (__gg__string_to_alpha_edited_ascii): Likewise. + (int128_to_field): Likewise. + (edited_to_binary): Likewise. + (get_binary_value_local): Likewise. + (__gg__get_date_yymmdd): Likewise. + (__gg__get_date_yyyymmdd): Likewise. + (__gg__get_date_yyddd): Likewise. + (__gg__get_yyyyddd): Likewise. + (__gg__get_date_dow): Likewise. + (get_scaled_rdigits): Likewise. + (format_for_display_internal): Likewise. + (compare_88): Likewise. + (get_float128): Likewise. + (compare_field_class): Likewise. + (compare_strings): Likewise. + (__gg__compare_2): Likewise. + (__gg__sort_table): Likewise. + (init_var_both): Likewise. + (alpha_to_alpha_move_from_location): Likewise. + (alpha_to_alpha_move): Likewise. + (__gg__move): Likewise. + (__gg__move_literala): Likewise. + (__gg__sort_workfile): Likewise. + (__gg__merge_files): Likewise. + (normalize_id): Likewise. + (inspect_backward_format_1): Likewise. + (__gg__inspect_format_1): Likewise. + (inspect_backward_format_2): Likewise. + (__gg__inspect_format_2): Likewise. + (__gg__inspect_format_4): Likewise. + (move_string): Likewise. + (__gg__string): Likewise. + (display_both): Likewise. + (__gg__display_string): Likewise. + (__gg__accept): Likewise. + (__gg__binary_value_from_qualified_field): Likewise. + (__gg__float128_from_qualified_field): Likewise. + (float128_to_int128): Likewise. + (float128_to_location): Likewise. + (__gg__set_initial_switch_value): Likewise. + (is_numeric_display_numeric): Likewise. + (is_packed_numeric): Likewise. + (is_alpha_a_number): Likewise. + (__gg__classify): Likewise. + (__gg__accept_envar): Likewise. + (__gg__set_envar): Likewise. + (command_line_plan_b): Likewise. + (__gg__get_command_line): Likewise. + (__gg__set_pointer): Likewise. + (__gg__ascii_to_internal_field): Likewise. + (__gg__internal_to_console_in_place): Likewise. + (__gg__routine_to_call): Likewise. + (__gg__fetch_call_by_value_value): Likewise. + (__gg__assign_value_from_stack): Likewise. + (__gg__literaln_alpha_compare): Likewise. + (string_in): Likewise. + (__gg__unstring): Likewise. + (local_ec_type_of): Likewise. + (struct exception_descr_t): Likewise. + (struct cbl_exception_t): Likewise. + (cbl_enabled_exception_t: Likewise.: Likewise.dump): Likewise. + (__gg__match_exception): Likewise. + (__gg__float128_from_location): Likewise. + (__gg__integer_from_float128): Likewise. + (__gg__set_exception_file): Likewise. + (__gg__func_exception_file): Likewise. + (__gg__set_exception_code): Likewise. + (__gg__is_float_infinite): Likewise. + (__gg__float32_from_128): Likewise. + (__gg__float32_from_64): Likewise. + (__gg__float64_from_128): Likewise. + (__gg__copy_as_big_endian): Likewise. + (__gg__get_figconst_data): Likewise. + (find_in_dirs): Likewise. + (__gg__function_handle_from_cobpath): Likewise. + (__gg__just_mangle_name): Likewise. + (__gg__function_handle_from_literal): Likewise. + (__gg__function_handle_from_name): Likewise. + (__gg__mirror_range): Likewise. + (__gg__deallocate): Likewise. + (__gg__allocate): Likewise. + (__gg__module_name): Likewise. + (__gg__set_env_name): Likewise. + (__gg__set_env_value): Likewise. + * libgcobol.h (__gg__mabort): Likewise. + (massert): Likewise. + (PTRCAST): Likewise. + (__gg__float128_from_location): Likewise. + (__gg__set_exception_file): Likewise. + (__gg__binary_value_from_qualified_field): Likewise. + (__gg__float128_from_qualified_field): Likewise. + * valconv.cc (__gg__realloc_if_necessary): Likewise. + (__gg__alphabet_create): Likewise. + (__gg__string_to_numeric_edited): Likewise. + (__gg__string_to_alpha_edited): Likewise. + * valconv.h: Likewise. + 2025-06-01 Robert Dubner <rdubner@symas.com> PR cobol/119524 diff --git a/libgcobol/charmaps.cc b/libgcobol/charmaps.cc index 2cdcfc0..eb82609 100644 --- a/libgcobol/charmaps.cc +++ b/libgcobol/charmaps.cc @@ -435,7 +435,7 @@ __gg__raw_to_ascii(char **dest, size_t *dest_size, const char *in, size_t length size_t code_point; // Pull the next code_point from the UTF-8 stream - long unicode_point = extract_next_code_point((const unsigned char *)in, + long unicode_point = extract_next_code_point(reinterpret_cast<const unsigned char *>(in), length, position ); @@ -497,7 +497,7 @@ __gg__raw_to_ebcdic(char **dest, size_t *dest_size, const char *in, size_t lengt } // Pull the next code_point from the UTF-8 stream - long unicode_point = extract_next_code_point( (const unsigned char *)in, + long unicode_point = extract_next_code_point( reinterpret_cast<const unsigned char *>(in), length, position ); // Check for that unicode code point in the subset of characters we @@ -722,7 +722,8 @@ char *__gg__ebcdic_to_console(char **dest, const size_t length) { static size_t ebcdic_size = MINIMUM_ALLOCATION_SIZE; - static char *ebcdic = (char *)malloc(ebcdic_size); + static char *ebcdic = static_cast<char *>(malloc(ebcdic_size)); + if(!ebcdic)abort(); __gg__realloc_if_necessary(&ebcdic, &ebcdic_size, length); memcpy(ebcdic, str, length); @@ -757,7 +758,7 @@ void __gg__console_to_ascii(char * const str, size_t length) size_t code_point; // Pull the next code_point from the UTF-8 stream long unicode_point - = extract_next_code_point( (const unsigned char *)str, + = extract_next_code_point( reinterpret_cast<const unsigned char *>(str), length, position ); if( unicode_point == -1 ) @@ -797,7 +798,7 @@ __gg__console_to_ebcdic(char * const str, size_t length) size_t code_point; // Pull the next code_point from the UTF-8 stream long unicode_point - = extract_next_code_point( (const unsigned char *)str, + = extract_next_code_point( reinterpret_cast<const unsigned char *>(str), length, position ); if( unicode_point == -1 ) diff --git a/libgcobol/common-defs.h b/libgcobol/common-defs.h index 2aecc8f..764d9f8 100644 --- a/libgcobol/common-defs.h +++ b/libgcobol/common-defs.h @@ -464,16 +464,20 @@ struct cbl_declarative_t { uint32_t nfile, files[files_max]; cbl_file_mode_t mode; + // cppcheck-suppress noExplicitConstructor cbl_declarative_t( cbl_file_mode_t mode = file_mode_none_e ) - : section(0), global(false) + : section(0) + , global(false) , type(ec_none_e) , nfile(0) , mode(mode) { std::fill(files, files + COUNT_OF(files), 0); } + // cppcheck-suppress noExplicitConstructor cbl_declarative_t( ec_type_t type ) - : section(0), global(false) + : section(0) + , global(false) , type(type) , nfile(0) , mode(file_mode_none_e) @@ -533,9 +537,9 @@ struct cbl_declarative_t { return section < that.section; } - // TRUE if there are no files to match, or the provided file is in the list. - bool match_file( size_t file ) const { - static const auto pend = files + nfile; + // TRUE if there are no files to match, or the provided file is in the list. + bool match_file( size_t file ) const { + static const auto pend = files + nfile; // cppcheck-suppress constVariablePointer return nfile == 0 || pend != std::find(files, files + nfile, file); } diff --git a/libgcobol/config.h.in b/libgcobol/config.h.in index ee3dd6b..1b511d0 100644 --- a/libgcobol/config.h.in +++ b/libgcobol/config.h.in @@ -3,6 +3,9 @@ /* Define to 1 if the target assembler supports thread-local storage. */ #undef HAVE_CC_TLS +/* Define to 1 if you have the `clock_gettime' function. */ +#undef HAVE_CLOCK_GETTIME + /* Define to 1 if you have the <complex.h> header file. */ #undef HAVE_COMPLEX_H diff --git a/libgcobol/configure b/libgcobol/configure index 5f319ee..7271517 100755 --- a/libgcobol/configure +++ b/libgcobol/configure @@ -17275,6 +17275,59 @@ if test "$ac_res" != no; then : fi +# Copied from gcc/configure.ac. 2025-06-05 R.J.Dubner +# At least for glibc, clock_gettime is in librt. But don't pull that +# in if it still doesn't give us the function we want. +ac_cv_func_clock_gettime=no +if test $ac_cv_func_clock_gettime = no; then + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for clock_gettime in -lrt" >&5 +$as_echo_n "checking for clock_gettime in -lrt... " >&6; } +if ${ac_cv_lib_rt_clock_gettime+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-lrt $LIBS" +if test x$gcc_no_link = xyes; then + as_fn_error $? "Link tests are not allowed after GCC_NO_EXECUTABLES." "$LINENO" 5 +fi +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char clock_gettime (); +int +main () +{ +return clock_gettime (); + ; + return 0; +} +_ACEOF +if ac_fn_cxx_try_link "$LINENO"; then : + ac_cv_lib_rt_clock_gettime=yes +else + ac_cv_lib_rt_clock_gettime=no +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_rt_clock_gettime" >&5 +$as_echo "$ac_cv_lib_rt_clock_gettime" >&6; } +if test "x$ac_cv_lib_rt_clock_gettime" = xyes; then : + LIBS="-lrt $LIBS" + +$as_echo "#define HAVE_CLOCK_GETTIME 1" >>confdefs.h + +fi + +fi + have_iec_60559_libc_support=no if test "x$ac_cv_func_strtof128$ac_cv_func_strfromf128" = xyesyes \ && test "x$libgcobol_have_sinf128$libgcobol_have_cacosf128" = xyesyes; then diff --git a/libgcobol/configure.ac b/libgcobol/configure.ac index 1332696..acfca7e 100644 --- a/libgcobol/configure.ac +++ b/libgcobol/configure.ac @@ -232,6 +232,17 @@ AC_SEARCH_LIBS([sinf128], [c m], libgcobol_have_sinf128=yes) libgcobol_have_cacosf128=no AC_SEARCH_LIBS([cacosf128], [c m], libgcobol_have_cacosf128=yes) +# Copied from gcc/configure.ac. 2025-06-05 R.J.Dubner +# At least for glibc, clock_gettime is in librt. But don't pull that +# in if it still doesn't give us the function we want. +ac_cv_func_clock_gettime=no +if test $ac_cv_func_clock_gettime = no; then + AC_CHECK_LIB(rt, clock_gettime, + [LIBS="-lrt $LIBS" + AC_DEFINE(HAVE_CLOCK_GETTIME, 1, + [Define to 1 if you have the `clock_gettime' function.])]) +fi + have_iec_60559_libc_support=no if test "x$ac_cv_func_strtof128$ac_cv_func_strfromf128" = xyesyes \ && test "x$libgcobol_have_sinf128$libgcobol_have_cacosf128" = xyesyes; then diff --git a/libgcobol/gfileio.cc b/libgcobol/gfileio.cc index 806f4a9..9124288 100644 --- a/libgcobol/gfileio.cc +++ b/libgcobol/gfileio.cc @@ -105,6 +105,11 @@ */ +/* cppcheck has its opinions about ++iterator being superior to iterator++. + however, can't abide by the prefix notation; it just looks dumb to me. + And I have to believe that in the year of our Lord 2025 that the + optimizing algorithms in modern compilers have sorted this out by now. */ + extern "C" void __gg__handle_error(const char *function, const char *msg) @@ -191,11 +196,12 @@ handle_errno(cblc_file_t *file, const char *function, const char *msg) static char * -get_filename( cblc_file_t *file, +get_filename( const cblc_file_t *file, int is_quoted) { static size_t fname_size = MINIMUM_ALLOCATION_SIZE; - static char *fname = (char *)malloc(MINIMUM_ALLOCATION_SIZE); + static char *fname = static_cast<char *>(malloc(MINIMUM_ALLOCATION_SIZE)); + massert(fname); fname = internal_to_console(&fname, &fname_size, file->filename, @@ -205,14 +211,15 @@ get_filename( cblc_file_t *file, { // We have been given something that might be the name of an // environment variable that contains the filename: - char *p_from_environment = getenv(fname); + const char *p_from_environment = getenv(fname); if( p_from_environment ) { if( strlen(p_from_environment)+1 > fname_size ) { fname_size = strlen(p_from_environment)+1; free(fname); - fname = (char *)malloc(fname_size); + fname = static_cast<char *>(malloc(fname_size)); + massert(fname); } strcpy(fname, p_from_environment); } @@ -272,7 +279,7 @@ __gg__set_user_status(cblc_field_t *ustatus, cblc_file_t *file) } static long -max_value(cblc_field_t *key) +max_value(const cblc_field_t *key) { long retval; if( key->digits ) @@ -537,7 +544,8 @@ relative_file_delete_varying(cblc_file_t *file, bool is_random) size_t payload_length; - unsigned char *stash = (unsigned char *)malloc(file->default_record->capacity); + unsigned char *stash = static_cast<unsigned char *>(malloc(file->default_record->capacity)); + massert(stash); memcpy(stash, file->default_record->data, file->default_record->capacity); long starting_pos = ftell(file->file_pointer); @@ -654,7 +662,8 @@ relative_file_delete(cblc_file_t *file, bool is_random) char record_marker; - unsigned char *stash = (unsigned char *)malloc(file->default_record->capacity); + unsigned char *stash = static_cast<unsigned char *>(malloc(file->default_record->capacity)); + massert(stash); memcpy(stash, file->default_record->data, file->default_record->capacity); long starting_pos = ftell(file->file_pointer); @@ -829,7 +838,7 @@ read_an_indexed_record( cblc_file_t *file, goto done; } - record_length = ach[0]<<8; + record_length = static_cast<long>(ach[0])<<8; record_length += ach[1]; if(ach[2] != 0) { @@ -906,7 +915,7 @@ position_state_preserve(cblc_file_t *file, position_state_t &state) } static void -position_state_restore(cblc_file_t *file, position_state_t &state) +position_state_restore(cblc_file_t *file, const position_state_t &state) { file->recent_key = state.recent_key; fseek(file->file_pointer, state.starting_position, SEEK_SET); @@ -973,7 +982,8 @@ indexed_file_delete(cblc_file_t *file, bool is_random) // and the record area itself are unchanged by the delete operation. // So, we save the current record area: - stash = (unsigned char *)malloc(file->record_area_max); + stash = static_cast<unsigned char *>(malloc(file->record_area_max)); + massert(stash); memcpy(stash, file->default_record->data, file->record_area_max); // And the position state of our file @@ -1051,8 +1061,6 @@ indexed_file_delete(cblc_file_t *file, bool is_random) // we find one, we check to see if the keys match. If the keys don't // match, then we have to remove the existing one from the index. - std::vector<unsigned char> the_key - = file_indexed_make_key(file, key_number); bool deleting = true; while(deleting) { @@ -1069,6 +1077,7 @@ indexed_file_delete(cblc_file_t *file, bool is_random) deleting = true; break; } + it++; } } @@ -1234,7 +1243,7 @@ indexed_file_start( cblc_file_t *file, file->io_status = FsErrno; } } - else if( result < 0 ) + else // if( result < 0 ) { // The index is less than the key. if( relop == lt_op @@ -1656,7 +1665,7 @@ sequential_file_rewrite( cblc_file_t *file, size_t length ) if( file->record_area_min != file->record_area_max ) { - unsigned char preamble[4] = + const unsigned char preamble[4] = { (unsigned char)(bytes_to_write>>8), (unsigned char)(bytes_to_write), @@ -1688,7 +1697,6 @@ done: fseek(file->file_pointer, starting_position, SEEK_SET); handle_ferror(file, __func__, "fseek() error"); file->prior_op = file_op_rewrite; - file->prior_op = file_op_rewrite; establish_status(file, starting_position); } @@ -2210,7 +2218,7 @@ __io__file_rewrite(cblc_file_t *file, size_t length, bool is_random) static void relative_file_write_varying(cblc_file_t *file, - unsigned char *location, + const unsigned char *location, size_t length, bool is_random) { @@ -2359,7 +2367,7 @@ done: static void relative_file_write(cblc_file_t *file, - unsigned char *location, + const unsigned char *location, size_t length, bool is_random) { @@ -2374,7 +2382,7 @@ relative_file_write(cblc_file_t *file, file->io_status = FsErrno; long necessary_file_size; - unsigned char achPostamble[] = {internal_cr, internal_newline}; + const unsigned char achPostamble[] = {internal_cr, internal_newline}; relative_file_parameters rfp; @@ -2493,7 +2501,7 @@ done: static void sequential_file_write(cblc_file_t *file, - unsigned char *location, + const unsigned char *location, size_t length, int after, int lines) @@ -2609,7 +2617,7 @@ sequential_file_write(cblc_file_t *file, { // Because of the min/max mismatch, we require a preamble: // The first two bytes are the big-endian character count - unsigned char preamble[4] = + const unsigned char preamble[4] = { (unsigned char)(characters_to_write>>8), (unsigned char)(characters_to_write), @@ -2681,7 +2689,7 @@ done: static void indexed_file_write( cblc_file_t *file, - unsigned char *location, + const unsigned char *location, size_t length, bool is_random) { @@ -2752,13 +2760,13 @@ indexed_file_write( cblc_file_t *file, // We are allowed to do the write, but only if there will be no key // violations as a result: - for(size_t key_number=1; - key_number<file->supplemental->indexes.size(); - key_number++) + for(size_t keynum=1; + keynum<file->supplemental->indexes.size(); + keynum++) { - if( file->supplemental->uniques[key_number] ) + if( file->supplemental->uniques[keynum] ) { - long record_position = file_indexed_first_position(file, key_number); + long record_position = file_indexed_first_position(file, keynum); if( record_position != -1 ) { // No can do, because we already have a unique key with that value @@ -2849,7 +2857,7 @@ done: static void __io__file_write( cblc_file_t *file, - unsigned char *location, + const unsigned char *location, size_t length, int after, int lines, @@ -2983,7 +2991,7 @@ line_sequential_file_read( cblc_file_t *file) { break; } - if( ch == file->delimiter || ch == EOF ) + if( ch == EOF ) { hit_eof = true; clearerr(file->file_pointer); @@ -3647,6 +3655,7 @@ indexed_file_read( cblc_file_t *file, goto done; } + // cppcheck-suppress derefInvalidIteratorRedundantCheck fpos = file_index->current_iterator->second; if( file_index->current_iterator == file_index->key_to_position.end() ) @@ -3728,6 +3737,7 @@ indexed_file_read( cblc_file_t *file, // We are ready to proceed + // cppcheck-suppress derefInvalidIteratorRedundantCheck fpos = file_index->current_iterator->second; if( file_index->current_iterator == file_index->key_to_position.end() ) { @@ -3922,7 +3932,6 @@ file_indexed_open(cblc_file_t *file) { if( file->key_numbers[index] != current_key_number ) { - file_index_t file_index; file->supplemental->indexes.push_back(file_index); current_key_number = file->key_numbers[index]; file->supplemental->uniques.push_back(file->uniques[index]); @@ -3952,7 +3961,8 @@ file_indexed_open(cblc_file_t *file) // We need to open the file for reading, and build the // maps for each index: static size_t fname_size = MINIMUM_ALLOCATION_SIZE; - static char *fname = (char *)malloc(fname_size); + static char *fname = static_cast<char *>(malloc(fname_size)); + massert(fname); internal_to_console(&fname, &fname_size, @@ -3969,7 +3979,8 @@ file_indexed_open(cblc_file_t *file) } // Stash the existing record area: - stash = (unsigned char *)malloc(file->record_area_max); + stash = static_cast<unsigned char *>(malloc(file->record_area_max)); + massert(stash); memcpy( stash, file->default_record->data, file->record_area_max); @@ -4111,7 +4122,8 @@ __gg__file_reopen(cblc_file_t *file, int mode_char) } static size_t fname_size = MINIMUM_ALLOCATION_SIZE; - static char *fname = (char *)malloc(fname_size); + static char *fname = static_cast<char *>(malloc(fname_size)); + massert(fname) internal_to_console(&fname, &fname_size, file->filename, @@ -4465,7 +4477,7 @@ public: typedef void (read_t)( cblc_file_t *file, int where ); typedef void (write_t)( cblc_file_t *file, - unsigned char *location, + const unsigned char *location, size_t length, int after, int lines, diff --git a/libgcobol/gmath.cc b/libgcobol/gmath.cc index e51cf9f..8a9880b 100644 --- a/libgcobol/gmath.cc +++ b/libgcobol/gmath.cc @@ -88,7 +88,8 @@ conditional_stash( cblc_field_t *destination, // This is slightly more complex, because in the event of a // SIZE ERROR. we need to leave the original value untouched - unsigned char *stash = (unsigned char *)malloc(destination_s); + unsigned char *stash = static_cast<unsigned char *>(malloc(destination_s)); + massert(stash); memcpy(stash, destination->data+destination_o, destination_s); __gg__int128_to_qualified_field(destination, @@ -132,7 +133,9 @@ conditional_stash( cblc_field_t *destination, { // This is slightly more complex, because in the event of a // SIZE ERROR. we need to leave the original value untouched - unsigned char *stash = (unsigned char *)malloc(destination_s); + assert(destination_s); + unsigned char *stash = static_cast<unsigned char *>(malloc(destination_s)); + massert(stash); memcpy(stash, destination->data+destination_o, destination_s); __gg__float128_to_qualified_field(destination, destination_o, @@ -256,20 +259,20 @@ __gg__pow( cbl_arith_format_t, size_t, size_t, size_t, - cbl_round_t *rounded, + const cbl_round_t *rounded, int on_error_flag, int *compute_error ) { - cblc_field_t **A = __gg__treeplet_1f; - size_t *A_o = __gg__treeplet_1o; - size_t *A_s = __gg__treeplet_1s; - cblc_field_t **B = __gg__treeplet_2f; - size_t *B_o = __gg__treeplet_2o; - size_t *B_s = __gg__treeplet_2s; - cblc_field_t **C = __gg__treeplet_3f; - size_t *C_o = __gg__treeplet_3o; - size_t *C_s = __gg__treeplet_3s; + cblc_field_t **A = __gg__treeplet_1f; + const size_t *A_o = __gg__treeplet_1o; + const size_t *A_s = __gg__treeplet_1s; + cblc_field_t **B = __gg__treeplet_2f; + const size_t *B_o = __gg__treeplet_2o; + const size_t *B_s = __gg__treeplet_2s; + cblc_field_t **C = __gg__treeplet_3f; + const size_t *C_o = __gg__treeplet_3o; + const size_t *C_s = __gg__treeplet_3s; GCOB_FP128 avalue = __gg__float128_from_qualified_field(A[0], A_o[0], A_s[0]); GCOB_FP128 bvalue = __gg__float128_from_qualified_field(B[0], B_o[0], B_s[0]); @@ -368,8 +371,8 @@ multiply_int256_by_int64(int256 &product, const uint64_t multiplier) for(int i=0; i<4; i++) { uint128 temp = (uint128)product.i64[i] * multiplier; - product.i64[i] = *(uint64_t *)(&temp); - overflows[i+1] = *(uint64_t *)((uint8_t *)(&temp) + 8); + product.i64[i] = *PTRCAST(uint64_t, &temp); + overflows[i+1] = *PTRCAST(uint64_t, PTRCAST(uint8_t, &temp) + 8); } for(int i=1; i<4; i++) @@ -386,7 +389,7 @@ multiply_int256_by_int64(int256 &product, const uint64_t multiplier) } static int -add_int256_to_int256(int256 &sum, const int256 addend) +add_int256_to_int256(int256 &sum, const int256 &addend) { uint128 overflows[3] = {}; for(int i=0; i<2; i++) @@ -451,10 +454,11 @@ divide_int256_by_int64(int256 &val, uint64_t divisor) for( int i=3; i>=0; i-- ) { // Left shift temp 64 bits: - *(uint64_t *)(((uint8_t *)&temp)+8) = *(uint64_t *)(((uint8_t *)&temp)+0); + *PTRCAST(uint64_t, ((PTRCAST(uint8_t, &temp))+8)) + = *PTRCAST(uint64_t, ((PTRCAST(uint8_t, &temp))+0)); // Put the high digit of val into the bottom of temp - *(uint64_t *)(((uint8_t *)&temp)+0) = val.i64[i]; + *PTRCAST(uint64_t, ((PTRCAST(uint8_t, &temp))+0)) = val.i64[i]; // Divide that combinary by divisor to get the new digits val.i64[i] = temp / divisor; @@ -469,7 +473,8 @@ squeeze_int256(int256 &val, int &rdigits) { int overflow = 0; // It has been decreed that at this juncture the result must fit into - // MAX_FIXED_POINT_DIGITS. If the result does not, we have an OVERFLOW error. + // MAX_FIXED_POINT_DIGITS. If the result does not, we have an OVERFLOW + // error. int is_negative = val.data[31] & 0x80; if( is_negative ) @@ -477,9 +482,9 @@ squeeze_int256(int256 &val, int &rdigits) negate_int256(val); } - // As long as there are some decimal places left, we hold our nose and right- - // shift a too-large value rightward by decimal digits. In other words, we - // truncate the fractional part to make room for the integer part: + // As long as there are some decimal places left, we hold our nose and + // right-shift a too-large value rightward by decimal digits. In other + // words, we truncate the fractional part to make room for the integer part: while(rdigits > 0 && val.i128[1] ) { divide_int256_by_int64(val, 10UL); @@ -504,7 +509,7 @@ squeeze_int256(int256 &val, int &rdigits) // These sixteen bytes comprise the binary value of 10^38 static const uint8_t C1038[] = {0x00, 0x00, 0x00, 0x00, 0x40, 0x22, 0x8a, 0x09, 0x7a, 0xc4, 0x86, 0x5a, 0xa8, 0x4c, 0x3b, 0x4b}; - static const uint128 biggest = *(uint128 *)C1038; + static const uint128 biggest = *reinterpret_cast<const uint128 *>(C1038); // If we still have some rdigits to throw away, we can keep shrinking // the value: @@ -540,7 +545,7 @@ squeeze_int256(int256 &val, int &rdigits) static void get_int256_from_qualified_field(int256 &var, int &rdigits, - cblc_field_t *field, + const cblc_field_t *field, size_t field_o, size_t field_s) { @@ -571,7 +576,7 @@ __gg__add_fixed_phase1( cbl_arith_format_t , size_t nA, size_t , size_t , - cbl_round_t *, + const cbl_round_t *, int , int *compute_error ) @@ -580,9 +585,9 @@ __gg__add_fixed_phase1( cbl_arith_format_t , // The result goes into the temporary phase1_result. - cblc_field_t **A = __gg__treeplet_1f; - size_t *A_o = __gg__treeplet_1o; - size_t *A_s = __gg__treeplet_1s; + cblc_field_t **A = __gg__treeplet_1f; + const size_t *A_o = __gg__treeplet_1o; + const size_t *A_s = __gg__treeplet_1s; // Let us prime the pump with the first value of A[] get_int256_from_qualified_field(phase1_result, phase1_rdigits, A[0], A_o[0], A_s[0]); @@ -600,7 +605,6 @@ __gg__add_fixed_phase1( cbl_arith_format_t , if( phase1_rdigits > temp_rdigits ) { scale_int256_by_digits(temp, phase1_rdigits - temp_rdigits); - temp_rdigits = phase1_rdigits; } else if( phase1_rdigits < temp_rdigits ) { @@ -628,14 +632,14 @@ __gg__addf1_fixed_phase2( cbl_arith_format_t , size_t , size_t , size_t , - cbl_round_t *rounded, + const cbl_round_t *rounded, int on_error_flag, int *compute_error ) { - cblc_field_t **C = __gg__treeplet_3f; - size_t *C_o = __gg__treeplet_3o; - size_t *C_s = __gg__treeplet_3s; + cblc_field_t **C = __gg__treeplet_3f; + const size_t *C_o = __gg__treeplet_3o; + const size_t *C_s = __gg__treeplet_3s; // This is the assignment phase of an ADD Format 1 @@ -680,7 +684,6 @@ __gg__addf1_fixed_phase2( cbl_arith_format_t , if( rdigits_a > rdigits_b ) { scale_int256_by_digits(value_b, rdigits_a - rdigits_b); - rdigits_b = rdigits_a; } else if( rdigits_a < rdigits_b ) { @@ -713,16 +716,16 @@ __gg__fixed_phase2_assign_to_c( cbl_arith_format_t , size_t , size_t , size_t , - cbl_round_t *rounded, + const cbl_round_t *rounded, int on_error_flag, int *compute_error ) { // This is the assignment phase of an ADD Format 2 - cblc_field_t **C = __gg__treeplet_3f; - size_t *C_o = __gg__treeplet_3o; - size_t *C_s = __gg__treeplet_3s; + cblc_field_t **C = __gg__treeplet_3f; + const size_t *C_o = __gg__treeplet_3o; + const size_t *C_s = __gg__treeplet_3s; // We take phase1_result and put it into C @@ -771,7 +774,7 @@ __gg__add_float_phase1( cbl_arith_format_t , size_t nA, size_t , size_t , - cbl_round_t *, + const cbl_round_t *, int , int *compute_error ) @@ -780,9 +783,9 @@ __gg__add_float_phase1( cbl_arith_format_t , // The result goes into the temporary phase1_result_ffloat. - cblc_field_t **A = __gg__treeplet_1f; - size_t *A_o = __gg__treeplet_1o; - size_t *A_s = __gg__treeplet_1s; + cblc_field_t **A = __gg__treeplet_1f; + const size_t *A_o = __gg__treeplet_1o; + const size_t *A_s = __gg__treeplet_1s; // Let us prime the pump with the first value of A[] phase1_result_float = __gg__float128_from_qualified_field(A[0], A_o[0], A_s[0]); @@ -804,14 +807,14 @@ __gg__addf1_float_phase2( cbl_arith_format_t , size_t , size_t , size_t , - cbl_round_t *rounded, + const cbl_round_t *rounded, int on_error_flag, int *compute_error ) { - cblc_field_t **C = __gg__treeplet_3f; - size_t *C_o = __gg__treeplet_3o; - size_t *C_s = __gg__treeplet_3s; + cblc_field_t **C = __gg__treeplet_3f; + const size_t *C_o = __gg__treeplet_3o; + const size_t *C_s = __gg__treeplet_3s; bool on_size_error = !!(on_error_flag & ON_SIZE_ERROR); // This is the assignment phase of an ADD Format 2 @@ -831,14 +834,14 @@ __gg__float_phase2_assign_to_c( cbl_arith_format_t , size_t , size_t , size_t , - cbl_round_t *rounded, + const cbl_round_t *rounded, int on_error_flag, int *compute_error ) { - cblc_field_t **C = __gg__treeplet_3f; - size_t *C_o = __gg__treeplet_3o; - size_t *C_s = __gg__treeplet_3s; + cblc_field_t **C = __gg__treeplet_3f; + const size_t *C_o = __gg__treeplet_3o; + const size_t *C_s = __gg__treeplet_3s; bool on_size_error = !!(on_error_flag & ON_SIZE_ERROR); // This is the assignment phase of an ADD Format 2 @@ -856,7 +859,7 @@ __gg__addf3(cbl_arith_format_t , size_t nA, size_t , size_t , - cbl_round_t *rounded, + const cbl_round_t *rounded, int on_error_flag, int *compute_error ) @@ -864,13 +867,13 @@ __gg__addf3(cbl_arith_format_t , // This is an ADD Format 3. Each A[i] gets accumulated into each C[i]. When // both are fixed, we do fixed arithmetic. When either is a FldFloat, we // do floating-point arithmetic. - cblc_field_t **A = __gg__treeplet_1f; - size_t *A_o = __gg__treeplet_1o; - size_t *A_s = __gg__treeplet_1s; + cblc_field_t **A = __gg__treeplet_1f; + const size_t *A_o = __gg__treeplet_1o; + const size_t *A_s = __gg__treeplet_1s; - cblc_field_t **C = __gg__treeplet_3f; - size_t *C_o = __gg__treeplet_3o; - size_t *C_s = __gg__treeplet_3s; + cblc_field_t **C = __gg__treeplet_3f; + const size_t *C_o = __gg__treeplet_3o; + const size_t *C_s = __gg__treeplet_3s; bool on_size_error = !!(on_error_flag & ON_SIZE_ERROR); @@ -906,7 +909,6 @@ __gg__addf3(cbl_arith_format_t , if( rdigits_a > rdigits_b ) { scale_int256_by_digits(value_b, rdigits_a - rdigits_b); - rdigits_b = rdigits_a; } else if( rdigits_a < rdigits_b ) { @@ -940,14 +942,14 @@ __gg__subtractf1_fixed_phase2(cbl_arith_format_t , size_t , size_t , size_t , - cbl_round_t *rounded, + const cbl_round_t *rounded, int on_error_flag, int *compute_error ) { - cblc_field_t **C = __gg__treeplet_3f; - size_t *C_o = __gg__treeplet_3o; - size_t *C_s = __gg__treeplet_3s; + cblc_field_t **C = __gg__treeplet_3f; + const size_t *C_o = __gg__treeplet_3o; + const size_t *C_s = __gg__treeplet_3s; // This is the assignment phase of an ADD Format 1 @@ -997,7 +999,6 @@ __gg__subtractf1_fixed_phase2(cbl_arith_format_t , else if( rdigits_a < rdigits_b ) { scale_int256_by_digits(value_a, rdigits_b - rdigits_a); - rdigits_a = rdigits_b; } // The two numbers have the same number of rdigits. It's now safe to add @@ -1025,16 +1026,16 @@ __gg__subtractf2_fixed_phase1(cbl_arith_format_t , size_t nA, size_t , size_t , - cbl_round_t *rounded, + const cbl_round_t *rounded, int on_error_flag, int *compute_error ) { // This is the calculation phase of a fixed-point SUBTRACT Format 2 - cblc_field_t **B = __gg__treeplet_2f; - size_t *B_o = __gg__treeplet_2o; - size_t *B_s = __gg__treeplet_2s; + cblc_field_t **B = __gg__treeplet_2f; + const size_t *B_o = __gg__treeplet_2o; + const size_t *B_s = __gg__treeplet_2s; // Add up all the A values __gg__add_fixed_phase1( not_expected_e , @@ -1065,7 +1066,6 @@ __gg__subtractf2_fixed_phase1(cbl_arith_format_t , else if( rdigits_a < rdigits_b ) { scale_int256_by_digits(value_a, rdigits_b - rdigits_a); - rdigits_a = rdigits_b; } // The two numbers have the same number of rdigits. It's now safe to add @@ -1081,21 +1081,20 @@ __gg__subtractf2_fixed_phase1(cbl_arith_format_t , phase1_rdigits = rdigits_b; } - extern "C" void __gg__subtractf1_float_phase2(cbl_arith_format_t , size_t , size_t , size_t , - cbl_round_t *rounded, + const cbl_round_t *rounded, int on_error_flag, int *compute_error ) { - cblc_field_t **C = __gg__treeplet_3f; - size_t *C_o = __gg__treeplet_3o; - size_t *C_s = __gg__treeplet_3s; + cblc_field_t **C = __gg__treeplet_3f; + const size_t *C_o = __gg__treeplet_3o; + const size_t *C_s = __gg__treeplet_3s; bool on_size_error = !!(on_error_flag & ON_SIZE_ERROR); // This is the assignment phase of an ADD Format 2 @@ -1109,23 +1108,22 @@ __gg__subtractf1_float_phase2(cbl_arith_format_t , *rounded++); } - extern "C" void __gg__subtractf2_float_phase1(cbl_arith_format_t , size_t nA, size_t , size_t , - cbl_round_t *rounded, + const cbl_round_t *rounded, int on_error_flag, int *compute_error ) { // This is the calculation phase of a fixed-point SUBTRACT Format 2 - cblc_field_t **B = __gg__treeplet_2f; - size_t *B_o = __gg__treeplet_2o; - size_t *B_s = __gg__treeplet_2s; + cblc_field_t **B = __gg__treeplet_2f; + const size_t *B_o = __gg__treeplet_2o; + const size_t *B_s = __gg__treeplet_2s; // Add up all the A values __gg__add_float_phase1( not_expected_e , @@ -1151,7 +1149,7 @@ __gg__subtractf3( cbl_arith_format_t , size_t nA, size_t , size_t , - cbl_round_t *rounded, + const cbl_round_t *rounded, int on_error_flag, int *compute_error ) @@ -1159,12 +1157,12 @@ __gg__subtractf3( cbl_arith_format_t , // This is an ADD Format 3. Each A[i] gets accumulated into each C[i]. Each // SUBTRACTION is treated separately. - cblc_field_t **A = __gg__treeplet_1f; - size_t *A_o = __gg__treeplet_1o; - size_t *A_s = __gg__treeplet_1s; - cblc_field_t **C = __gg__treeplet_3f; - size_t *C_o = __gg__treeplet_3o; - size_t *C_s = __gg__treeplet_3s; + cblc_field_t **A = __gg__treeplet_1f; + const size_t *A_o = __gg__treeplet_1o; + const size_t *A_s = __gg__treeplet_1s; + cblc_field_t **C = __gg__treeplet_3f; + const size_t *C_o = __gg__treeplet_3o; + const size_t *C_s = __gg__treeplet_3s; bool on_size_error = !!(on_error_flag & ON_SIZE_ERROR); @@ -1205,7 +1203,6 @@ __gg__subtractf3( cbl_arith_format_t , else if( rdigits_a < rdigits_b ) { scale_int256_by_digits(value_a, rdigits_b - rdigits_a); - rdigits_a = rdigits_b; } // The two numbers have the same number of rdigits. It's now safe to add @@ -1240,16 +1237,16 @@ __gg__multiplyf1_phase1(cbl_arith_format_t , size_t , size_t , size_t , - cbl_round_t *, + const cbl_round_t *, int , int *) { // We are getting just the one value, which we are converting to the necessary // intermediate form - cblc_field_t **A = __gg__treeplet_1f; - size_t *A_o = __gg__treeplet_1o; - size_t *A_s = __gg__treeplet_1s; + cblc_field_t **A = __gg__treeplet_1f; + const size_t *A_o = __gg__treeplet_1o; + const size_t *A_s = __gg__treeplet_1s; if( A[0]->type == FldFloat ) { @@ -1274,7 +1271,8 @@ void multiply_int128_by_int128(int256 &ABCD, __int128 ab_value, __int128 cd_value) { - int is_negative = ( ((uint8_t *)(&ab_value))[15]^((uint8_t *)(&cd_value))[15]) & 0x80; + int is_negative = ( (PTRCAST(uint8_t, (&ab_value)))[15] + ^(PTRCAST(uint8_t, (&cd_value)))[15]) & 0x80; if( ab_value < 0 ) { ab_value = -ab_value; @@ -1290,10 +1288,10 @@ void multiply_int128_by_int128(int256 &ABCD, uint128 BD; // Let's extract the digits. - uint64_t a = *(uint64_t *)((unsigned char *)(&ab_value)+8); - uint64_t b = *(uint64_t *)((unsigned char *)(&ab_value)+0); - uint64_t c = *(uint64_t *)((unsigned char *)(&cd_value)+8); - uint64_t d = *(uint64_t *)((unsigned char *)(&cd_value)+0); + uint64_t a = *PTRCAST(uint64_t, (PTRCAST(unsigned char, (&ab_value))+8)); + uint64_t b = *PTRCAST(uint64_t, (PTRCAST(unsigned char, (&ab_value))+0)); + uint64_t c = *PTRCAST(uint64_t, (PTRCAST(unsigned char, (&cd_value))+8)); + uint64_t d = *PTRCAST(uint64_t, (PTRCAST(unsigned char, (&cd_value))+0)); // multiply (a0 + b) * (c0 + d) @@ -1334,14 +1332,14 @@ __gg__multiplyf1_phase2(cbl_arith_format_t , size_t , size_t , size_t , - cbl_round_t *rounded, + const cbl_round_t *rounded, int on_error_flag, int *compute_error ) { - cblc_field_t **C = __gg__treeplet_3f; - size_t *C_o = __gg__treeplet_3o; - size_t *C_s = __gg__treeplet_3s; + cblc_field_t **C = __gg__treeplet_3f; + const size_t *C_o = __gg__treeplet_3o; + const size_t *C_s = __gg__treeplet_3s; bool on_size_error = !!(on_error_flag & ON_SIZE_ERROR); int error_this_time=0; @@ -1415,14 +1413,13 @@ __gg__multiplyf1_phase2(cbl_arith_format_t , if( error_this_time && on_size_error) { *compute_error |= error_this_time; - rounded++; } else { *compute_error |= conditional_stash(C[0], C_o[0], C_s[0], on_size_error, a_value, - *rounded++); + *rounded); } done: return; @@ -1434,20 +1431,20 @@ __gg__multiplyf2( cbl_arith_format_t , size_t , size_t , size_t nC, - cbl_round_t *rounded, + const cbl_round_t *rounded, int on_error_flag, int *compute_error ) { - cblc_field_t **A = __gg__treeplet_1f; - size_t *A_o = __gg__treeplet_1o; - size_t *A_s = __gg__treeplet_1s; - cblc_field_t **B = __gg__treeplet_2f; - size_t *B_o = __gg__treeplet_2o; - size_t *B_s = __gg__treeplet_2s; - cblc_field_t **C = __gg__treeplet_3f; - size_t *C_o = __gg__treeplet_3o; - size_t *C_s = __gg__treeplet_3s; + cblc_field_t **A = __gg__treeplet_1f; + const size_t *A_o = __gg__treeplet_1o; + const size_t *A_s = __gg__treeplet_1s; + cblc_field_t **B = __gg__treeplet_2f; + const size_t *B_o = __gg__treeplet_2o; + const size_t *B_s = __gg__treeplet_2s; + cblc_field_t **C = __gg__treeplet_3f; + const size_t *C_o = __gg__treeplet_3o; + const size_t *C_s = __gg__treeplet_3s; bool on_size_error = !!(on_error_flag & ON_SIZE_ERROR); @@ -1517,7 +1514,7 @@ shift_in_place128(uint8_t *buf, int size, int bits) uint128 temp; uint128 overflow = 0; - uint128 *as128 = (uint128 *)buf; + uint128 *as128 = PTRCAST(uint128, buf); for( size_t i=0; i<places; i++ ) { @@ -1598,7 +1595,7 @@ divide_int128_by_int128(int256 "ient, } // We are going to be referencing the 64-bit pices of the 128-bit divisor: - uint64_t *divisor64 = (uint64_t *)&divisor; + uint64_t *divisor64 = PTRCAST(uint64_t, &divisor); quotient.i128[1] = 0; quotient.i128[0] = dividend; @@ -1667,12 +1664,11 @@ divide_int128_by_int128(int256 "ient, int bits_to_shift = 0; int i=15; - while( ((uint8_t *)(&divisor))[i] == 0 ) + while( (PTRCAST(uint8_t, &divisor))[i] == 0 ) { i -= 1; bits_to_shift += 8; - } - uint8_t tail = ((uint8_t *)(&divisor))[i]; + } uint8_t tail = ( PTRCAST(uint8_t, &divisor) )[i]; while( !(tail & 0x80) ) { bits_to_shift += 1; @@ -1681,9 +1677,8 @@ divide_int128_by_int128(int256 "ient, // Shift both the numerator and the divisor that number of bits - shift_in_place128((uint8_t *)&numerator, sizeof(numerator), bits_to_shift); - shift_in_place128((uint8_t *)&divisor, sizeof(divisor), bits_to_shift); - + shift_in_place128( PTRCAST(uint8_t, &numerator), sizeof(numerator), bits_to_shift); + shift_in_place128( PTRCAST(uint8_t, &divisor), sizeof(divisor), bits_to_shift); // We are now ready to do the guess-multiply-subtract loop. We know that // the result will have two places, so we know we are going to go through @@ -1700,7 +1695,7 @@ divide_int128_by_int128(int256 "ient, // We develop our guess for a quotient by dividing the top two places of // the numerator area by C uint128 temp; - uint64_t *temp64 = (uint64_t *)&temp; + uint64_t *temp64 = PTRCAST(uint64_t, &temp); temp64[1] = numerator.i64[q_place+2]; temp64[0] = numerator.i64[q_place+1]; @@ -1714,10 +1709,10 @@ divide_int128_by_int128(int256 "ient, subber[2] = 0; // Start with the bottom 128 bits of the "subber" - *(uint128 *)subber = (uint128) divisor64[0] * quotient.i64[q_place]; + *PTRCAST(uint128, subber) = (uint128) divisor64[0] * quotient.i64[q_place]; // Get the next 128 bits of subber - temp = (uint128) divisor64[1] * quotient.i64[q_place]; + temp = (uint128) divisor64[1] * quotient.i64[q_place]; // Add the top of the first product to the bottom of the second: subber[1] += temp64[0]; @@ -1738,20 +1733,20 @@ divide_int128_by_int128(int256 "ient, // the numerator: uint64_t borrow = 0; - for(size_t i=0; i<3; i++) + for(size_t j=0; j<3; j++) { - if( numerator.i64[q_place + i] == 0 && borrow ) + if( numerator.i64[q_place + j] == 0 && borrow ) { // We are subtracting from zero and we have a borrow. Leave the // borrow on and just do the subtraction: - numerator.i64[q_place + i] -= subber[i]; + numerator.i64[q_place + j] -= subber[j]; } else { - uint64_t stash = numerator.i64[q_place + i]; - numerator.i64[q_place + i] -= borrow; - numerator.i64[q_place + i] -= subber[i]; - if( numerator.i64[q_place + i] > stash ) + uint64_t stash = numerator.i64[q_place + j]; + numerator.i64[q_place + j] -= borrow; + numerator.i64[q_place + j] -= subber[j]; + if( numerator.i64[q_place + j] > stash ) { // After subtracting, the value got bigger, which means we have // to borrow from the next value to the left @@ -1775,21 +1770,21 @@ divide_int128_by_int128(int256 "ient, { // We need to add subber back into the numerator area uint64_t carry = 0; - for(size_t i=0; i<3; i++) + for(size_t ii=0; ii<3; ii++) { - if( numerator.i64[q_place + i] == 0xFFFFFFFFFFFFFFFFUL && carry ) + if( numerator.i64[q_place + ii] == 0xFFFFFFFFFFFFFFFFUL && carry ) { // We are at the top and have a carry. Just leave the carry on // and do the addition: - numerator.i64[q_place + i] += subber[i]; + numerator.i64[q_place + ii] += subber[ii]; } else { // We are not at the top. - uint64_t stash = numerator.i64[q_place + i]; - numerator.i64[q_place + i] += carry; - numerator.i64[q_place + i] += subber[i]; - if( numerator.i64[q_place + i] < stash ) + uint64_t stash = numerator.i64[q_place + ii]; + numerator.i64[q_place + ii] += carry; + numerator.i64[q_place + ii] += subber[ii]; + if( numerator.i64[q_place + ii] < stash ) { // The addition caused the result to get smaller, meaning that // we wrapped around: @@ -1817,14 +1812,14 @@ __gg__dividef1_phase2(cbl_arith_format_t , size_t , size_t , size_t , - cbl_round_t *rounded, + const cbl_round_t *rounded, int on_error_flag, int *compute_error ) { - cblc_field_t **C = __gg__treeplet_3f; - size_t *C_o = __gg__treeplet_3o; - size_t *C_s = __gg__treeplet_3s; + cblc_field_t **C = __gg__treeplet_3f; + const size_t *C_o = __gg__treeplet_3o; + const size_t *C_s = __gg__treeplet_3s; bool on_size_error = !!(on_error_flag & ON_SIZE_ERROR); int error_this_time=0; @@ -1904,14 +1899,13 @@ __gg__dividef1_phase2(cbl_arith_format_t , if( error_this_time && on_size_error) { - rounded++; } else { *compute_error |= conditional_stash(C[0], C_o[0], C_s[0], on_size_error, b_value, - *rounded++); + *rounded); } done: return; @@ -1923,20 +1917,20 @@ __gg__dividef23(cbl_arith_format_t , size_t , size_t , size_t nC, - cbl_round_t *rounded, + const cbl_round_t *rounded, int on_error_flag, int *compute_error ) { - cblc_field_t **A = __gg__treeplet_1f; - size_t *A_o = __gg__treeplet_1o; - size_t *A_s = __gg__treeplet_1s; - cblc_field_t **B = __gg__treeplet_2f; - size_t *B_o = __gg__treeplet_2o; - size_t *B_s = __gg__treeplet_2s; - cblc_field_t **C = __gg__treeplet_3f; - size_t *C_o = __gg__treeplet_3o; - size_t *C_s = __gg__treeplet_3s; + cblc_field_t **A = __gg__treeplet_1f; + const size_t *A_o = __gg__treeplet_1o; + const size_t *A_s = __gg__treeplet_1s; + cblc_field_t **B = __gg__treeplet_2f; + const size_t *B_o = __gg__treeplet_2o; + const size_t *B_s = __gg__treeplet_2s; + cblc_field_t **C = __gg__treeplet_3f; + const size_t *C_o = __gg__treeplet_3o; + const size_t *C_s = __gg__treeplet_3s; bool on_size_error = !!(on_error_flag & ON_SIZE_ERROR); int error_this_time=0; @@ -2009,15 +2003,15 @@ __gg__dividef45(cbl_arith_format_t , int *compute_error ) { - cblc_field_t **A = __gg__treeplet_1f; // Numerator - size_t *A_o = __gg__treeplet_1o; - size_t *A_s = __gg__treeplet_1s; - cblc_field_t **B = __gg__treeplet_2f; // Denominator - size_t *B_o = __gg__treeplet_2o; - size_t *B_s = __gg__treeplet_2s; - cblc_field_t **C = __gg__treeplet_3f; // Has remainder, then quotient - size_t *C_o = __gg__treeplet_3o; - size_t *C_s = __gg__treeplet_3s; + cblc_field_t **A = __gg__treeplet_1f; // Numerator + const size_t *A_o = __gg__treeplet_1o; + const size_t *A_s = __gg__treeplet_1s; + cblc_field_t **B = __gg__treeplet_2f; // Denominator + const size_t *B_o = __gg__treeplet_2o; + const size_t *B_s = __gg__treeplet_2s; + cblc_field_t **C = __gg__treeplet_3f; // Has remainder, then quotient + const size_t *C_o = __gg__treeplet_3o; + const size_t *C_s = __gg__treeplet_3s; bool on_size_error = !!(on_error_flag & ON_SIZE_ERROR); int error_this_time=0; diff --git a/libgcobol/intrinsic.cc b/libgcobol/intrinsic.cc index 1af4a53..2d8d79c 100644 --- a/libgcobol/intrinsic.cc +++ b/libgcobol/intrinsic.cc @@ -167,7 +167,7 @@ JD_to_DOW(double JD) static char * -timespec_to_string(char *retval, struct timespec &tp) +timespec_to_string(char *retval, struct cbl_timespec &tp) { /* Returns a 21-character string: @@ -248,9 +248,12 @@ struct input_state nsubscript = N; if(N) { - subscript_alls = (bool *) malloc(nsubscript); - subscripts = (size_t *)malloc(nsubscript); - subscript_limits = (size_t *)malloc(nsubscript); + subscript_alls = static_cast<bool *>(malloc(nsubscript)); + subscripts = static_cast<size_t *>(malloc(nsubscript)); + subscript_limits = static_cast<size_t *>(malloc(nsubscript)); + massert(subscript_alls); + massert(subscripts); + massert(subscript_limits); } done = false; } @@ -378,7 +381,7 @@ year_to_yyyy(int arg1, int arg2, int arg3) static double -get_value_as_double_from_qualified_field( cblc_field_t *input, +get_value_as_double_from_qualified_field( const cblc_field_t *input, size_t input_o, size_t input_s) { @@ -411,9 +414,9 @@ get_value_as_double_from_qualified_field( cblc_field_t *input, static GCOB_FP128 kahan_summation(size_t ncount, cblc_field_t **source, - size_t *source_o, - size_t *source_s, - int *flags, + const size_t *source_o, + const size_t *source_s, + const int *flags, size_t *k_count) { // We use compensated addition. Look up Kahan summation. @@ -458,9 +461,9 @@ static GCOB_FP128 variance( size_t ncount, cblc_field_t **source, - size_t *source_o, - size_t *source_s, - int *flags) + const size_t *source_o, + const size_t *source_s, + const int *flags) { // In order to avoid catastrophic cancellation, we are going to use an // algorithm that is a bit wasteful of time, but is described as particularly @@ -547,14 +550,14 @@ get_all_time( char *stime, // days of January show up in the final week of the prior year. sprintf(stime, - "%4.4u%2.2u%2.2uT" // YYYYMMSS - "%2.2u%2.2u%2.2u" // hhmmss - ".%9.9u" // .sssssssss - "%c%2.2u%2.2u" // +hhmm - "W%2.2u" // Www - "%1u" // DOW [1-7], 1 for Monday - "%3.3u" // DDD day of year, 001 - 365,366 - "%4.4u", // ZZZZ Year for YYYY-Www-D + "%4.4d%2.2d%2.2dT" // YYYYMMSS + "%2.2d%2.2d%2.2d" // hhmmss + ".%9.9d" // .sssssssss + "%c%2.2d%2.2d" // +hhmm + "W%2.2d" // Www + "%1d" // DOW [1-7], 1 for Monday + "%3.3d" // DDD day of year, 001 - 365,366 + "%4.4d", // ZZZZ Year for YYYY-Www-D ctm.YYYY, ctm.MM, ctm.DD, @@ -687,7 +690,7 @@ populate_ctm_from_JD(struct cobol_tm &ctm, double JD ) static void populate_ctm_from_date( struct cobol_tm &ctm, - cblc_field_t *pdate, + const cblc_field_t *pdate, size_t pdate_offset, size_t pdate_size) { @@ -721,10 +724,10 @@ populate_ctm_from_double_time(struct cobol_tm &ctm, double time) static void populate_ctm_from_time( struct cobol_tm &ctm, - cblc_field_t *ptime, + const cblc_field_t *ptime, size_t ptime_o, size_t ptime_s, - cblc_field_t *poffset, + const cblc_field_t *poffset, size_t poffset_o, size_t poffset_s) { @@ -791,8 +794,10 @@ convert_to_zulu(cobol_tm &ctm) static void -ftime_replace(char *dest, char const * const dest_end, - char const *source, char const * const source_end, +ftime_replace(char *dest, + char const * const dest_end, + char const * source, + char const * const source_end, char const * const ftime) { // This routine is highly dependent on the source format being correct. @@ -956,7 +961,7 @@ ftime_replace(char *dest, char const * const dest_end, extern "C" void __gg__abs(cblc_field_t *dest, - cblc_field_t *source, + const cblc_field_t *source, size_t source_offset, size_t source_size) { @@ -978,7 +983,7 @@ __gg__abs(cblc_field_t *dest, extern "C" void __gg__acos( cblc_field_t *dest, - cblc_field_t *source, + const cblc_field_t *source, size_t source_offset, size_t source_size) { @@ -1005,10 +1010,10 @@ __gg__acos( cblc_field_t *dest, extern "C" void __gg__annuity(cblc_field_t *dest, - cblc_field_t *arg1, + const cblc_field_t *arg1, size_t arg1_offset, size_t arg1_size, - cblc_field_t *arg2, + const cblc_field_t *arg2, size_t arg2_offset, size_t arg2_size) { @@ -1050,7 +1055,7 @@ __gg__annuity(cblc_field_t *dest, extern "C" void __gg__asin( cblc_field_t *dest, - cblc_field_t *source, + const cblc_field_t *source, size_t source_offset, size_t source_size) { @@ -1080,7 +1085,7 @@ __gg__asin( cblc_field_t *dest, extern "C" void __gg__atan( cblc_field_t *dest, - cblc_field_t *source, + const cblc_field_t *source, size_t source_offset, size_t source_size) { @@ -1102,7 +1107,7 @@ __gg__atan( cblc_field_t *dest, extern "C" void __gg__byte_length(cblc_field_t *dest, - cblc_field_t */*source*/, + const cblc_field_t */*source*/, size_t /*source_offset*/, size_t source_size) { @@ -1118,7 +1123,7 @@ __gg__byte_length(cblc_field_t *dest, extern "C" void __gg__char( cblc_field_t *dest, - cblc_field_t *source, + const cblc_field_t *source, size_t source_offset, size_t source_size) { @@ -1143,10 +1148,10 @@ __gg__char( cblc_field_t *dest, extern "C" void __gg__combined_datetime(cblc_field_t *dest, - cblc_field_t *arg1, + const cblc_field_t *arg1, size_t arg1_offset, size_t arg1_size, - cblc_field_t *arg2, + const cblc_field_t *arg2, size_t arg2_offset, size_t arg2_size) { @@ -1192,7 +1197,7 @@ __gg__concat( cblc_field_t *dest, extern "C" void __gg__cos(cblc_field_t *dest, - cblc_field_t *source, + const cblc_field_t *source, size_t source_offset, size_t source_size) { @@ -1213,7 +1218,7 @@ void __gg__current_date(cblc_field_t *dest) { // FUNCTION CURRENT-DATE - struct timespec tp = {}; + struct cbl_timespec tp = {}; __gg__clock_gettime(CLOCK_REALTIME, &tp); // time_t tv_sec; long tv_nsec char retval[DATE_STRING_BUFFER_SIZE]; @@ -1227,7 +1232,7 @@ void __gg__seconds_past_midnight(cblc_field_t *dest) { // SECONDS-PAST-MIDNIGHT - struct timespec tp = {}; + struct cbl_timespec tp = {}; struct tm tm; __int128 retval=0; @@ -1251,7 +1256,7 @@ __gg__seconds_past_midnight(cblc_field_t *dest) extern "C" void __gg__date_of_integer(cblc_field_t *dest, - cblc_field_t *source, + const cblc_field_t *source, size_t source_offset, size_t source_size) { @@ -1277,13 +1282,13 @@ __gg__date_of_integer(cblc_field_t *dest, extern "C" void __gg__date_to_yyyymmdd( cblc_field_t *dest, - cblc_field_t *par1, + const cblc_field_t *par1, size_t par1_o, size_t par1_s, - cblc_field_t *par2, + const cblc_field_t *par2, size_t par2_o, size_t par2_s, - cblc_field_t *par3, + const cblc_field_t *par3, size_t par3_o, size_t par3_s) { @@ -1308,7 +1313,7 @@ __gg__date_to_yyyymmdd( cblc_field_t *dest, extern "C" void __gg__day_of_integer( cblc_field_t *dest, - cblc_field_t *source, + const cblc_field_t *source, size_t source_offset, size_t source_size) { @@ -1337,13 +1342,13 @@ __gg__day_of_integer( cblc_field_t *dest, extern "C" void __gg__day_to_yyyyddd( cblc_field_t *dest, - cblc_field_t *par1, + const cblc_field_t *par1, size_t par1_o, size_t par1_s, - cblc_field_t *par2, + const cblc_field_t *par2, size_t par2_o, size_t par2_s, - cblc_field_t *par3, + const cblc_field_t *par3, size_t par3_o, size_t par3_s) { @@ -1382,7 +1387,7 @@ __gg__e(cblc_field_t *dest) extern "C" void __gg__exp(cblc_field_t *dest, - cblc_field_t *source, + const cblc_field_t *source, size_t source_offset, size_t source_size) { @@ -1401,7 +1406,7 @@ __gg__exp(cblc_field_t *dest, extern "C" void __gg__exp10(cblc_field_t *dest, - cblc_field_t *source, + const cblc_field_t *source, size_t source_offset, size_t source_size) { @@ -1420,7 +1425,7 @@ __gg__exp10(cblc_field_t *dest, extern "C" void __gg__factorial(cblc_field_t *dest, - cblc_field_t *source, + const cblc_field_t *source, size_t source_offset, size_t source_size) { @@ -1451,24 +1456,24 @@ __gg__factorial(cblc_field_t *dest, extern "C" void __gg__formatted_current_date( cblc_field_t *dest, // Destination string - cblc_field_t *input, // datetime format + const cblc_field_t *input, // datetime format size_t input_offset, size_t input_size) { // FUNCTION CURRENT-DATE // Establish the destination, and set it to spaces - char *d = (char *)dest->data; - char *dend = d + dest->capacity; + char *d = PTRCAST(char, dest->data); + const char *dend = d + dest->capacity; memset(d, internal_space, dest->capacity); // Establish the formatting string: - char *format = (char *)(input->data+input_offset); - char *format_end = format + input_size; + const char *format = PTRCAST(char, (input->data+input_offset)); + const char *format_end = format + input_size; bool is_zulu = false; - char *p = format; + const char *p = format; while( p < format_end ) { int ch = *p++; @@ -1479,7 +1484,7 @@ __gg__formatted_current_date( cblc_field_t *dest, // Destination string } } - struct timespec ts = {}; + struct cbl_timespec ts = {}; __gg__clock_gettime(CLOCK_REALTIME, &ts); struct tm tm = {}; @@ -1512,23 +1517,23 @@ __gg__formatted_current_date( cblc_field_t *dest, // Destination string extern "C" void __gg__formatted_date(cblc_field_t *dest, // Destination string - cblc_field_t *arg1, // datetime format + const cblc_field_t *arg1, // datetime format size_t arg1_offset, size_t arg1_size, - cblc_field_t *arg2, // integer date + const cblc_field_t *arg2, // integer date size_t arg2_offset, size_t arg2_size) { // FUNCTION FORMATTED-DATE // Establish the destination, and set it to spaces - char *d = (char *)dest->data; - char *dend = d + dest->capacity; + char *d = PTRCAST(char, dest->data); + const char *dend = d + dest->capacity; memset(d, internal_space, dest->capacity); // Establish the formatting string: - char *format = (char *)(arg1->data+arg1_offset); - char *format_end = format + arg1_size; + char *format = PTRCAST(char, (arg1->data+arg1_offset)); + const char *format_end = format + arg1_size; struct cobol_tm ctm = {}; @@ -1550,16 +1555,16 @@ __gg__formatted_date(cblc_field_t *dest, // Destination string extern "C" void __gg__formatted_datetime( cblc_field_t *dest, // Destination string - cblc_field_t *par1, // datetime format + const cblc_field_t *par1, // datetime format size_t par1_o, size_t par1_s, - cblc_field_t *par2, // integer date + const cblc_field_t *par2, // integer date size_t par2_o, size_t par2_s, - cblc_field_t *par3, // numeric time + const cblc_field_t *par3, // numeric time size_t par3_o, size_t par3_s, - cblc_field_t *par4, // optional offset in seconds + const cblc_field_t *par4, // optional offset in seconds size_t par4_o, size_t par4_s ) @@ -1567,12 +1572,12 @@ __gg__formatted_datetime( cblc_field_t *dest, // Destination string // FUNCTION FORMATTED-DATETIME // Establish the destination, and set it to spaces - char *d = (char *)dest->data; - char *dend = d + dest->capacity; + char *d = PTRCAST(char, (dest->data)); + const char *dend = d + dest->capacity; memset(d, internal_space, dest->capacity); // Establish the formatting string: - char *format = (char *)(par1->data+par1_o); + char *format = PTRCAST(char, (par1->data+par1_o)); char *format_end = format + par1_s; trim_trailing_spaces(format, format_end); bool is_zulu = is_zulu_format(format, format_end); @@ -1605,13 +1610,13 @@ __gg__formatted_datetime( cblc_field_t *dest, // Destination string extern "C" void __gg__formatted_time( cblc_field_t *dest,// Destination string - cblc_field_t *par1, // datetime format + const cblc_field_t *par1, // datetime format size_t par1_o, size_t par1_s, - cblc_field_t *par2,// numeric time + const cblc_field_t *par2,// numeric time size_t par2_o, size_t par2_s, - cblc_field_t *par4, // optional offset in seconds + const cblc_field_t *par4, // optional offset in seconds size_t par4_o, size_t par4_s) @@ -1619,12 +1624,12 @@ __gg__formatted_time( cblc_field_t *dest,// Destination string // FUNCTION FORMATTED-TIME // Establish the destination, and set it to spaces - char *d = (char *)dest->data; - char *dend = d + dest->capacity; + char *d = PTRCAST(char, dest->data); + const char *dend = d + dest->capacity; memset(d, internal_space, dest->capacity); // Establish the formatting string: - char *format = (char *)(par1->data+par1_o); + char *format = PTRCAST(char, (par1->data+par1_o)); char *format_end = format + par1_s; trim_trailing_spaces(format, format_end); bool is_zulu = is_zulu_format(format, format_end); @@ -1659,7 +1664,7 @@ __gg__formatted_time( cblc_field_t *dest,// Destination string extern "C" void __gg__integer(cblc_field_t *dest, - cblc_field_t *source, + const cblc_field_t *source, size_t source_offset, size_t source_size) { @@ -1677,7 +1682,7 @@ __gg__integer(cblc_field_t *dest, extern "C" void __gg__integer_of_date(cblc_field_t *dest, - cblc_field_t *source, + const cblc_field_t *source, size_t source_offset, size_t source_size) { @@ -1732,7 +1737,7 @@ __gg__integer_of_date(cblc_field_t *dest, extern "C" void __gg__integer_of_day( cblc_field_t *dest, - cblc_field_t *source, + const cblc_field_t *source, size_t source_offset, size_t source_size) { @@ -1759,7 +1764,7 @@ __gg__integer_of_day( cblc_field_t *dest, extern "C" void __gg__integer_part( cblc_field_t *dest, - cblc_field_t *source, + const cblc_field_t *source, size_t source_offset, size_t source_size) { @@ -1782,7 +1787,7 @@ __gg__integer_part( cblc_field_t *dest, extern "C" void __gg__fraction_part(cblc_field_t *dest, - cblc_field_t *source, + const cblc_field_t *source, size_t source_offset, size_t source_size) { @@ -1811,10 +1816,10 @@ __gg__fraction_part(cblc_field_t *dest, extern "C" void -__gg__log( cblc_field_t *dest, - cblc_field_t *source, - size_t source_offset, - size_t source_size) +__gg__log(cblc_field_t *dest, + const cblc_field_t *source, + size_t source_offset, + size_t source_size) { // FUNCTION LOG GCOB_FP128 value = __gg__float128_from_qualified_field(source, @@ -1836,10 +1841,10 @@ __gg__log( cblc_field_t *dest, extern "C" void -__gg__log10( cblc_field_t *dest, - cblc_field_t *source, - size_t source_offset, - size_t source_size) +__gg__log10(cblc_field_t *dest, + const cblc_field_t *source, + size_t source_offset, + size_t source_size) { // FUNCTION LOG10 GCOB_FP128 value = __gg__float128_from_qualified_field(source, @@ -1870,8 +1875,8 @@ __gg__max(cblc_field_t *dest, || __gg__treeplet_1f[0]->type == FldLiteralA) ) { cblc_field_t *best_field ; - unsigned char *best_location ; - size_t best_length ; + unsigned char *best_location = nullptr ; + size_t best_length = 0 ; int best_attr ; int best_flags ; @@ -1931,8 +1936,10 @@ __gg__max(cblc_field_t *dest, } } + __gg__adjust_dest_size(dest, best_length); dest->type = FldAlphanumeric; + assert(best_location); memcpy(dest->data, best_location, best_length); } else @@ -1977,7 +1984,7 @@ __gg__max(cblc_field_t *dest, extern "C" void __gg__lower_case( cblc_field_t *dest, - cblc_field_t *input, + const cblc_field_t *input, size_t input_offset, size_t input_size) { @@ -1985,10 +1992,10 @@ __gg__lower_case( cblc_field_t *dest, size_t source_length = input_size; memset(dest->data, internal_space, dest_length); memcpy(dest->data, input->data+input_offset, std::min(dest_length, source_length)); - internal_to_ascii((char *)dest->data, dest_length); + internal_to_ascii( PTRCAST(char, dest->data), dest_length); std::transform(dest->data, dest->data + dest_length, dest->data, [](unsigned char c) { return std::tolower(c); }); - ascii_to_internal_str((char *)dest->data, dest_length); + ascii_to_internal_str( PTRCAST(char, dest->data), dest_length); } extern "C" @@ -2027,7 +2034,8 @@ __gg__median( cblc_field_t *dest, size_t list_size = 1; - GCOB_FP128 *the_list = (GCOB_FP128 *)malloc(list_size *sizeof(GCOB_FP128)); + GCOB_FP128 *the_list = static_cast<GCOB_FP128 *>(malloc(list_size *sizeof(GCOB_FP128))); + massert(the_list); size_t k_count = 0; assert(ncount); for(size_t i=0; i<ncount; i++) @@ -2040,9 +2048,11 @@ __gg__median( cblc_field_t *dest, if(k_count >= list_size) { list_size *= 2; - the_list = (GCOB_FP128 *)realloc(the_list, list_size *sizeof(GCOB_FP128)); + the_list = PTRCAST(GCOB_FP128, realloc(the_list, list_size *sizeof(GCOB_FP128))); + massert(the_list); } + assert(the_list); the_list[k_count] = __gg__float128_from_qualified_field(__gg__treeplet_1f[i], __gg__treeplet_1o[i], __gg__treeplet_1s[i]); @@ -2125,11 +2135,11 @@ __gg__min(cblc_field_t *dest, if( ( __gg__treeplet_1f[0]->type == FldAlphanumeric || __gg__treeplet_1f[0]->type == FldLiteralA) ) { - cblc_field_t *best_field ; - unsigned char *best_location ; - size_t best_length ; - int best_attr ; - int best_flags ; + cblc_field_t *best_field ; + unsigned char *best_location = nullptr ; + size_t best_length = 0 ; + int best_attr ; + int best_flags ; bool first_time = true; assert(ncount); @@ -2189,6 +2199,7 @@ __gg__min(cblc_field_t *dest, __gg__adjust_dest_size(dest, best_length); dest->type = FldAlphanumeric; + assert(best_location); memcpy(dest->data, best_location, best_length); } else @@ -2277,15 +2288,15 @@ __gg__mod(cblc_field_t *dest, static int numval( cblc_field_t *dest, - cblc_field_t *input, + const cblc_field_t *input, size_t input_offset, size_t input_size) { // Returns the one-based character position of a bad character // returns zero if it is okay - char *p = (char *)(input->data + input_offset); - char *pend = p + input_size; + const char *p = PTRCAST(char, (input->data + input_offset)); + const char *pend = p + input_size; int errpos = 0; __int128 retval = 0; @@ -2568,17 +2579,17 @@ numval( cblc_field_t *dest, static int numval_c( cblc_field_t *dest, - cblc_field_t *src, + const cblc_field_t *src, size_t src_offset, size_t src_size, - cblc_field_t *crcy, + const cblc_field_t *crcy, size_t crcy_offset, size_t crcy_size ) { size_t errcode = 0; - char *pstart = (char *)(src->data+src_offset); + char *pstart = PTRCAST(char, (src->data+src_offset)); char *pend = pstart + src_size; char *p = pstart; @@ -2593,7 +2604,7 @@ numval_c( cblc_field_t *dest, char *currency_end; if( crcy ) { - currency_start = (char *)(crcy->data+crcy_offset); + currency_start = PTRCAST(char, (crcy->data+crcy_offset)); currency_end = currency_start + crcy_size; } else @@ -2807,7 +2818,6 @@ numval_c( cblc_field_t *dest, if( sign ) { // A second sign isn't allowed - state = final_space; errcode = p - pstart; p = pend; } @@ -2875,7 +2885,7 @@ numval_c( cblc_field_t *dest, extern "C" void __gg__numval( cblc_field_t *dest, - cblc_field_t *source, + const cblc_field_t *source, size_t source_offset, size_t source_size) { @@ -2889,7 +2899,7 @@ __gg__numval( cblc_field_t *dest, extern "C" void __gg__test_numval(cblc_field_t *dest, - cblc_field_t *source, + const cblc_field_t *source, size_t source_offset, size_t source_size) { @@ -2904,10 +2914,10 @@ __gg__test_numval(cblc_field_t *dest, extern "C" void __gg__numval_c( cblc_field_t *dest, - cblc_field_t *src, + const cblc_field_t *src, size_t src_offset, size_t src_size, - cblc_field_t *crcy, + const cblc_field_t *crcy, size_t crcy_offset, size_t crcy_size ) @@ -2924,10 +2934,10 @@ __gg__numval_c( cblc_field_t *dest, extern "C" void __gg__test_numval_c(cblc_field_t *dest, - cblc_field_t *src, + const cblc_field_t *src, size_t src_offset, size_t src_size, - cblc_field_t *crcy, + const cblc_field_t *crcy, size_t crcy_offset, size_t crcy_size ) @@ -2949,12 +2959,12 @@ __gg__test_numval_c(cblc_field_t *dest, extern "C" void __gg__ord(cblc_field_t *dest, - cblc_field_t *input, + const cblc_field_t *input, size_t input_offset, size_t /*input_size*/) { // We get our input in internal_character form. - char *arg = (char *)(input->data + input_offset); + const char *arg = PTRCAST(char, (input->data + input_offset)); // The ORD function takes a single-character string and returns the // ordinal position of that character. @@ -3257,10 +3267,10 @@ __gg__range(cblc_field_t *dest, extern "C" void __gg__rem(cblc_field_t *dest, - cblc_field_t *par1, + const cblc_field_t *par1, size_t par1_offset, size_t par1_size, - cblc_field_t *par2, + const cblc_field_t *par2, size_t par2_offset, size_t par2_size) { @@ -3300,10 +3310,10 @@ __gg__rem(cblc_field_t *dest, extern "C" void __gg__trim( cblc_field_t *dest, - cblc_field_t *arg1, + const cblc_field_t *arg1, size_t arg1_offset, size_t arg1_size, - cblc_field_t *arg2, + const cblc_field_t *arg2, size_t arg2_offset, size_t arg2_size) { @@ -3329,7 +3339,7 @@ __gg__trim( cblc_field_t *dest, // No matter what, we want to find the leftmost non-space and the // rightmost non-space: - char *left = (char *)(arg1->data+arg1_offset); + char *left = PTRCAST(char, (arg1->data+arg1_offset)); char *right = left + arg1_size-1; // Find left and right: the first and last non-spaces @@ -3352,13 +3362,13 @@ __gg__trim( cblc_field_t *dest, { // We want to leave any trailing spaces, so we return 'right' to its // original value: - right = (char *)(arg1->data+arg1_offset) + arg1_size-1; + right = PTRCAST(char, (arg1->data+arg1_offset)) + arg1_size-1; } else if( type == TRAILING ) { // We want to leave any leading spaces, so we return 'left' to its // original value: - left = (char *)(arg1->data+arg1_offset); + left = PTRCAST(char, (arg1->data+arg1_offset)); } if( left > right ) @@ -3378,9 +3388,9 @@ __gg__trim( cblc_field_t *dest, // compiler believes the capacity to be at compile-time. But we obviously // think it'll be okay. - char *dest_left = (char *)dest->data; + char *dest_left = PTRCAST(char, dest->data); char *dest_right = dest_left + dest->capacity - 1; - char *dest_end = dest_left + dest->capacity; + const char *dest_end = dest_left + dest->capacity; while( dest_left <= dest_right && left <= right ) { @@ -3403,7 +3413,7 @@ static unsigned seed = 0; extern "C" void __gg__random( cblc_field_t *dest, - cblc_field_t *input, + const cblc_field_t *input, size_t input_offset, size_t input_size) { @@ -3422,7 +3432,7 @@ __gg__random( cblc_field_t *dest, buf->state = NULL; state = (char *)malloc(state_len); - struct timespec ts; + struct cbl_timespec ts; __gg__clock_gettime(CLOCK_REALTIME, &ts); initstate_r( ts.tv_nsec, state, state_len, buf); } @@ -3462,7 +3472,7 @@ __gg__random_next(cblc_field_t *dest) buf = (random_data *)malloc(sizeof(struct random_data)); buf->state = NULL; state = (char *)malloc(state_len); - struct timespec ts; + struct cbl_timespec ts; __gg__clock_gettime(CLOCK_REALTIME, &ts); initstate_r( ts.tv_nsec, state, state_len, buf); } @@ -3480,7 +3490,7 @@ __gg__random_next(cblc_field_t *dest) extern "C" void __gg__reverse(cblc_field_t *dest, - cblc_field_t *input, + const cblc_field_t *input, size_t input_offset, size_t input_size) { @@ -3501,7 +3511,7 @@ __gg__reverse(cblc_field_t *dest, extern "C" void __gg__sign( cblc_field_t *dest, - cblc_field_t *source, + const cblc_field_t *source, size_t source_offset, size_t source_size) { @@ -3534,7 +3544,7 @@ __gg__sign( cblc_field_t *dest, extern "C" void __gg__sin(cblc_field_t *dest, - cblc_field_t *source, + const cblc_field_t *source, size_t source_offset, size_t source_size) { @@ -3555,7 +3565,7 @@ __gg__sin(cblc_field_t *dest, extern "C" void __gg__sqrt( cblc_field_t *dest, - cblc_field_t *source, + const cblc_field_t *source, size_t source_offset, size_t source_size) { @@ -3621,7 +3631,7 @@ __gg__sum(cblc_field_t *dest, extern "C" void __gg__tan(cblc_field_t *dest, - cblc_field_t *source, + const cblc_field_t *source, size_t source_offset, size_t source_size) { @@ -3640,7 +3650,7 @@ __gg__tan(cblc_field_t *dest, extern "C" void __gg__test_date_yyyymmdd( cblc_field_t *dest, - cblc_field_t *source, + const cblc_field_t *source, size_t source_offset, size_t source_size) { @@ -3650,14 +3660,8 @@ __gg__test_date_yyyymmdd( cblc_field_t *dest, source_offset, source_size); int retval; - int dd = yyyymmdd % 100; int mmdd = yyyymmdd % 10000; int mm = mmdd / 100; - int yyyy = yyyymmdd / 10000; - int jy; - int jm; - int jd; - double JD; if( yyyymmdd < 16010000 || yyyymmdd > 99999999 ) { retval = 1; @@ -3668,6 +3672,13 @@ __gg__test_date_yyyymmdd( cblc_field_t *dest, } else { + int dd = yyyymmdd % 100; + int yyyy = yyyymmdd / 10000; + int jy; + int jm; + int jd; + double JD; + // If there is something wrong with the number of days per month for a // given year, the Julian Date conversion won't reverse properly. // For example, January 32 will come back as February 1 @@ -3692,7 +3703,7 @@ __gg__test_date_yyyymmdd( cblc_field_t *dest, extern "C" void __gg__test_day_yyyyddd( cblc_field_t *dest, - cblc_field_t *source, + const cblc_field_t *source, size_t source_offset, size_t source_size) { @@ -3730,7 +3741,7 @@ __gg__test_day_yyyyddd( cblc_field_t *dest, extern "C" void __gg__upper_case( cblc_field_t *dest, - cblc_field_t *input, + const cblc_field_t *input, size_t input_offset, size_t input_size) { @@ -3738,10 +3749,10 @@ __gg__upper_case( cblc_field_t *dest, size_t source_length = input_size; memset(dest->data, internal_space, dest_length); memcpy(dest->data, input->data+input_offset, std::min(dest_length, source_length)); - internal_to_ascii((char *)dest->data, dest_length); + internal_to_ascii( PTRCAST(char, dest->data), dest_length); std::transform(dest->data, dest->data + dest_length, dest->data, [](unsigned char c) { return std::toupper(c); }); - ascii_to_internal_str((char *)dest->data, dest_length); + ascii_to_internal_str( PTRCAST(char, dest->data), dest_length); } extern "C" @@ -3765,7 +3776,7 @@ extern "C" void __gg__when_compiled(cblc_field_t *dest, size_t tv_sec, long tv_nsec) { - struct timespec tp = {}; + struct cbl_timespec tp = {}; tp.tv_sec = tv_sec; tp.tv_nsec = tv_nsec; char retval[DATE_STRING_BUFFER_SIZE]; @@ -3777,13 +3788,13 @@ __gg__when_compiled(cblc_field_t *dest, size_t tv_sec, long tv_nsec) extern "C" void __gg__year_to_yyyy( cblc_field_t *dest, - cblc_field_t *par1, + const cblc_field_t *par1, size_t par1_o, size_t par1_s, - cblc_field_t *par2, + const cblc_field_t *par2, size_t par2_o, size_t par2_s, - cblc_field_t *par3, + const cblc_field_t *par3, size_t par3_o, size_t par3_s) { @@ -3804,7 +3815,7 @@ __gg__year_to_yyyy( cblc_field_t *dest, static int -gets_int(int ndigits, char *p, char *pend, int *digits) +gets_int(int ndigits, const char *p, const char *pend, int *digits) { // This routine returns the value of the integer at p. If there is something // wrong with the integer, it returns a negative number, the value being the @@ -3835,7 +3846,7 @@ gets_int(int ndigits, char *p, char *pend, int *digits) static int -gets_year(char *p, char *pend, struct cobol_tm &ctm) +gets_year(const char *p, const char *pend, struct cobol_tm &ctm) { // Populates ctm.YYYY, ctm.days_in_year, and ctm.weeks_in_year, which are // all determined by the YYYY value. @@ -3855,10 +3866,6 @@ gets_year(char *p, char *pend, struct cobol_tm &ctm) { return 2; } - if( digits[0] == 0 && digits[1] < 5) - { - return 2; - } if( digits[2] == -1 ) { return 3; @@ -3903,7 +3910,7 @@ gets_year(char *p, char *pend, struct cobol_tm &ctm) static int -gets_month(char *p, char *pend, struct cobol_tm &ctm) +gets_month(const char *p, const char *pend, struct cobol_tm &ctm) { // Populates ctm.MM @@ -3950,7 +3957,7 @@ gets_month(char *p, char *pend, struct cobol_tm &ctm) static int -gets_day(char *p, char *pend, struct cobol_tm &ctm) +gets_day(const char *p, const char *pend, struct cobol_tm &ctm) { // Populates ctm.DD, ctm.day_of_week, ctm.week_of_year, ctm.day_of_week @@ -3968,48 +3975,45 @@ gets_day(char *p, char *pend, struct cobol_tm &ctm) { return 2; } - if(DD >= 0) + if( DD >= 0 ) { - if( DD >= 0 ) + if( DD == 0) { - if( DD == 0) - { - // If zero, we know we failed at the second '0' in "00" - retval = 2; - } - else if( DD >= 40) + // If zero, we know we failed at the second '0' in "00" + retval = 2; + } + else if( DD >= 40) + { + // 40 or more, then we knew there was trouble at the first digit + retval = 1; + } + else if(ctm.MM == 2 && DD >=30) + { + // It's February, so if we see 3x we know on the 3 that we are in + // error: + retval = 1; + } + else + { + static const int month_days[13] = {-1,31,28,31,30,31,30,31,31,30,31,30,31}; + int days_in_month = month_days[ctm.MM]; + if( ctm.MM == 2 && ctm.days_in_year == 366 ) { - // 40 or more, then we knew there was trouble at the first digit - retval = 1; + days_in_month = 29; } - else if(ctm.MM == 2 && DD >=30) + + if( DD > days_in_month ) { - // It's February, so if we see 3x we know on the 3 that we are in - // error: - retval = 1; + retval = 2; } else { - static const int month_days[13] = {-1,31,28,31,30,31,30,31,31,30,31,30,31}; - int days_in_month = month_days[ctm.MM]; - if( ctm.MM == 2 && ctm.days_in_year == 366 ) - { - days_in_month = 29; - } - - if( DD > days_in_month ) - { - retval = 2; - } - else - { - // We have a good YYYY-MM-DD - ctm.DD = DD; - double JD = YMD_to_JD(ctm.YYYY, ctm.MM, DD); - double JD_Jan0 = YMD_to_JD(ctm.YYYY, 1, 0); - ctm.day_of_year = (int)(JD - JD_Jan0); - ctm.day_of_week = JD_to_DOW(JD); - } + // We have a good YYYY-MM-DD + ctm.DD = DD; + double JD = YMD_to_JD(ctm.YYYY, ctm.MM, DD); + double JD_Jan0 = YMD_to_JD(ctm.YYYY, 1, 0); + ctm.day_of_year = (int)(JD - JD_Jan0); + ctm.day_of_week = JD_to_DOW(JD); } } } @@ -4022,7 +4026,7 @@ gets_day(char *p, char *pend, struct cobol_tm &ctm) static int -gets_day_of_week(char *p, char *pend, struct cobol_tm &ctm) +gets_day_of_week(const char *p, const char *pend, struct cobol_tm &ctm) { // This is just a simple D, for day-of-week. The COBOL spec is that // it be 1 to 7, 1 being Monday @@ -4071,7 +4075,7 @@ gets_day_of_week(char *p, char *pend, struct cobol_tm &ctm) static int -gets_day_of_year(char *p, char *pend, struct cobol_tm &ctm) +gets_day_of_year(const char *p, const char *pend, struct cobol_tm &ctm) { // This is a three-digit day-of-year, 001 through 365,366 int digits[3]; @@ -4128,7 +4132,7 @@ gets_day_of_year(char *p, char *pend, struct cobol_tm &ctm) static int -gets_week(char *p, char *pend, struct cobol_tm &ctm) +gets_week(const char *p, const char *pend, struct cobol_tm &ctm) { // This is a two-digit value, 01 through 52,53 int digits[2]; @@ -4168,7 +4172,10 @@ gets_week(char *p, char *pend, struct cobol_tm &ctm) static int -gets_hours(char *p, char *pend, struct cobol_tm &ctm, bool in_offset) +gets_hours( const char *p, + const char *pend, + struct cobol_tm &ctm, + bool in_offset) { // This is a two-digit value, 01 through 23 int digits[2]; @@ -4213,7 +4220,10 @@ gets_hours(char *p, char *pend, struct cobol_tm &ctm, bool in_offset) static int -gets_minutes(char *p, char *pend, struct cobol_tm &ctm, bool in_offset) +gets_minutes( const char *p, + const char *pend, + struct cobol_tm &ctm, + bool in_offset) { // This is a two-digit value, 01 through 59 int digits[2]; @@ -4251,7 +4261,7 @@ gets_minutes(char *p, char *pend, struct cobol_tm &ctm, bool in_offset) static int -gets_seconds(char *p, char *pend, struct cobol_tm &ctm) +gets_seconds(const char *p, const char *pend, struct cobol_tm &ctm) { // This is a two-digit value, 01 through 59 int digits[2]; @@ -4281,7 +4291,11 @@ gets_seconds(char *p, char *pend, struct cobol_tm &ctm) static int -gets_nanoseconds(char *f, char *f_end, char *p, char *pend, struct cobol_tm &ctm) +gets_nanoseconds( const char *f, + const char *f_end, + const char *p, + const char *pend, + struct cobol_tm &ctm) { // Because nanoseconds digits to the right of the decimal point can vary from // one digit to our implementation-specific limit of nine characters, this @@ -4293,7 +4307,7 @@ gets_nanoseconds(char *f, char *f_end, char *p, char *pend, struct cobol_tm &ctm int ncount = 0; int nanoseconds = 0; - char *pinit = p; + const char *pinit = p; while( f < f_end && *f == internal_s && p < pend ) { f += 1; @@ -4325,19 +4339,19 @@ gets_nanoseconds(char *f, char *f_end, char *p, char *pend, struct cobol_tm &ctm static int fill_cobol_tm(cobol_tm &ctm, - cblc_field_t *par1, + const cblc_field_t *par1, size_t par1_offset, size_t par1_size, - cblc_field_t *par2, + const cblc_field_t *par2, size_t par2_offset, size_t par2_size) { // Establish the formatting string: - char *format = (char *)(par1->data+par1_offset); + char *format = PTRCAST(char, (par1->data+par1_offset)); char *format_end = format + par1_size; // Establish the string to be checked: - char *source = (char *)(par2->data+par2_offset); + char *source = PTRCAST(char, (par2->data+par2_offset)); char *source_end = source + par2_size; // Let's eliminate trailing spaces... @@ -4587,10 +4601,10 @@ proceed: extern "C" void __gg__test_formatted_datetime(cblc_field_t *dest, - cblc_field_t *arg1, + const cblc_field_t *arg1, size_t arg1_offset, size_t arg1_size, - cblc_field_t *arg2, + const cblc_field_t *arg2, size_t arg2_offset, size_t arg2_size) @@ -4610,10 +4624,10 @@ __gg__test_formatted_datetime(cblc_field_t *dest, extern "C" void __gg__integer_of_formatted_date(cblc_field_t *dest, - cblc_field_t *arg1, + const cblc_field_t *arg1, size_t arg1_offset, size_t arg1_size, - cblc_field_t *arg2, + const cblc_field_t *arg2, size_t arg2_offset, size_t arg2_size) { @@ -4645,10 +4659,10 @@ __gg__integer_of_formatted_date(cblc_field_t *dest, extern "C" void __gg__seconds_from_formatted_time(cblc_field_t *dest, - cblc_field_t *arg1, + const cblc_field_t *arg1, size_t arg1_offset, size_t arg1_size, - cblc_field_t *arg2, + const cblc_field_t *arg2, size_t arg2_offset, size_t arg2_size) { @@ -4673,7 +4687,7 @@ __gg__seconds_from_formatted_time(cblc_field_t *dest, extern "C" void __gg__hex_of(cblc_field_t *dest, - cblc_field_t *field, + const cblc_field_t *field, size_t field_offset, size_t field_size) { @@ -4691,7 +4705,7 @@ __gg__hex_of(cblc_field_t *dest, extern "C" void __gg__highest_algebraic(cblc_field_t *dest, - cblc_field_t *var, + const cblc_field_t *var, size_t, size_t) { @@ -4733,7 +4747,7 @@ __gg__highest_algebraic(cblc_field_t *dest, extern "C" void __gg__lowest_algebraic( cblc_field_t *dest, - cblc_field_t *var, + const cblc_field_t *var, size_t, size_t) { @@ -4795,7 +4809,7 @@ __gg__lowest_algebraic( cblc_field_t *dest, } static int -floating_format_tester(char const * const f, char * const f_end) +floating_format_tester(char const * const f, char const * const f_end) { int retval = -1; char decimal_point = __gg__get_decimal_point(); @@ -4983,13 +4997,13 @@ floating_format_tester(char const * const f, char * const f_end) extern "C" void __gg__numval_f( cblc_field_t *dest, - cblc_field_t *source, + const cblc_field_t *source, size_t source_offset, size_t source_size) { GCOB_FP128 value = 0; - char *data = (char * )(source->data + source_offset); - char *data_end = data + source_size; + const char *data = PTRCAST(char, (source->data + source_offset)); + const char *data_end = data + source_size; int error = floating_format_tester(data, data_end); @@ -5022,12 +5036,12 @@ __gg__numval_f( cblc_field_t *dest, extern "C" void __gg__test_numval_f(cblc_field_t *dest, - cblc_field_t *source, + const cblc_field_t *source, size_t source_offset, size_t source_size) { - char *data = (char * )(source->data + source_offset); - char *data_end = data + source_size; + const char *data = PTRCAST(char, (source->data + source_offset)); + const char *data_end = data + source_size; int error = floating_format_tester(data, data_end); @@ -5039,7 +5053,7 @@ __gg__test_numval_f(cblc_field_t *dest, } static bool -ismatch(char *a1, char *a2, char *b1, char *b2) +ismatch(const char *a1, const char *a2, const char *b1, const char *b2) { bool retval = true; while( a1 < a2 && b1 < b2 ) @@ -5053,7 +5067,7 @@ ismatch(char *a1, char *a2, char *b1, char *b2) } static bool -iscasematch(char *a1, char *a2, char *b1, char *b2) +iscasematch(const char *a1, const char *a2, const char *b1, const char *b2) { bool retval = true; while( a1 < a2 && b1 < b2 ) @@ -5066,11 +5080,15 @@ iscasematch(char *a1, char *a2, char *b1, char *b2) return retval; } -static char * -strstr(char *haystack, char *haystack_e, char *needle, char *needle_e) +static +const char * +strstr( const char *haystack, + const char *haystack_e, + const char *needle, + const char *needle_e) { - char *retval = NULL; - char *pend = haystack_e - (needle_e - needle); + const char *retval = NULL; + const char *pend = haystack_e - (needle_e - needle); while( haystack <= pend ) { if(ismatch(haystack, haystack_e, needle, needle_e)) @@ -5083,11 +5101,15 @@ strstr(char *haystack, char *haystack_e, char *needle, char *needle_e) return retval; } -static char * -strcasestr(char *haystack, char *haystack_e, char *needle, char *needle_e) +static +const char * +strcasestr( const char *haystack, + const char *haystack_e, + const char *needle, + const char *needle_e) { - char *retval = NULL; - char *pend = haystack_e - (needle_e - needle); + const char *retval = NULL; + const char *pend = haystack_e - (needle_e - needle); while( haystack <= pend ) { if(iscasematch(haystack, haystack_e, needle, needle_e)) @@ -5100,11 +5122,15 @@ strcasestr(char *haystack, char *haystack_e, char *needle, char *needle_e) return retval; } -static char * -strlaststr(char *haystack, char *haystack_e, char *needle, char *needle_e) +static +const char * +strlaststr( const char *haystack, + const char *haystack_e, + const char *needle, + const char *needle_e) { - char *retval = NULL; - char *pend = haystack_e - (needle_e - needle); + const char *retval = NULL; + const char *pend = haystack_e - (needle_e - needle); while( haystack <= pend ) { if(ismatch(haystack, haystack_e, needle, needle_e)) @@ -5116,11 +5142,15 @@ strlaststr(char *haystack, char *haystack_e, char *needle, char *needle_e) return retval; } -static char * -strcaselaststr(char *haystack, char *haystack_e, char *needle, char *needle_e) +static +const char * +strcaselaststr( const char *haystack, + const char *haystack_e, + const char *needle, + const char *needle_e) { - char *retval = NULL; - char *pend = haystack_e - (needle_e - needle); + const char *retval = NULL; + const char *pend = haystack_e - (needle_e - needle); while( haystack <= pend ) { if(iscasematch(haystack, haystack_e, needle, needle_e)) @@ -5134,13 +5164,13 @@ strcaselaststr(char *haystack, char *haystack_e, char *needle, char *needle_e) extern "C" -void __gg__substitute(cblc_field_t *dest, - cblc_field_t *arg1_f, - size_t arg1_o, - size_t arg1_s, - size_t N, - uint8_t *control - ) +void +__gg__substitute( cblc_field_t *dest, + const cblc_field_t *arg1_f, + size_t arg1_o, + size_t arg1_s, + size_t N, + const uint8_t *control) { // arg2 is the Group 1 triplet. // arg3 is the Group 2 triplet @@ -5148,19 +5178,22 @@ void __gg__substitute(cblc_field_t *dest, size_t *arg2_o = __gg__treeplet_1o; size_t *arg2_s = __gg__treeplet_1s; cblc_field_t **arg3_f = __gg__treeplet_2f; - size_t *arg3_o = __gg__treeplet_2o; - size_t *arg3_s = __gg__treeplet_2s; + const size_t *arg3_o = __gg__treeplet_2o; + const size_t *arg3_s = __gg__treeplet_2s; - ssize_t retval_size = 256; - char *retval = (char *)malloc(retval_size); + ssize_t retval_size; + retval_size = 256; + char *retval = static_cast<char *>(malloc(retval_size)); + massert(retval); *retval = '\0'; - char *haystack = (char *)(arg1_f->data + arg1_o); - char *haystack_e = haystack + arg1_s; + const char *haystack = PTRCAST(char, (arg1_f->data + arg1_o)); + const char *haystack_e = haystack + arg1_s; ssize_t outdex = 0; - char **pflasts = (char **)malloc(N * sizeof(char *)); + const char **pflasts = static_cast<const char **>(malloc(N * sizeof(char *))); + massert(pflasts); if( arg1_s == 0 ) { @@ -5181,15 +5214,15 @@ void __gg__substitute(cblc_field_t *dest, { pflasts[i] = strcasestr(haystack, haystack_e, - (char *)(arg2_f[i]->data+arg2_o[i]), - (char *)(arg2_f[i]->data+arg2_o[i]) + arg2_s[i]); + PTRCAST(char, (arg2_f[i]->data+arg2_o[i])), + PTRCAST(char, (arg2_f[i]->data+arg2_o[i])) + arg2_s[i]); } else if( control[i] & substitute_last_e) { pflasts[i] = strcaselaststr(haystack, haystack_e, - (char *)(arg2_f[i]->data+arg2_o[i]), - (char *)(arg2_f[i]->data+arg2_o[i]) + arg2_s[i]); + PTRCAST(char, (arg2_f[i]->data+arg2_o[i])), + PTRCAST(char, (arg2_f[i]->data+arg2_o[i])) + arg2_s[i]); } else { @@ -5202,15 +5235,15 @@ void __gg__substitute(cblc_field_t *dest, { pflasts[i] = strstr(haystack, haystack_e, - (char *)(arg2_f[i]->data+arg2_o[i]), - (char *)(arg2_f[i]->data+arg2_o[i]) + arg2_s[i]); + PTRCAST(char, (arg2_f[i]->data+arg2_o[i])), + PTRCAST(char, (arg2_f[i]->data+arg2_o[i])) + arg2_s[i]); } else if( control[i] & substitute_last_e) { pflasts[i] = strlaststr(haystack, haystack_e, - (char *)(arg2_f[i]->data+arg2_o[i]), - (char *)(arg2_f[i]->data+arg2_o[i]) + arg2_s[i]); + PTRCAST(char, (arg2_f[i]->data+arg2_o[i])), + PTRCAST(char, (arg2_f[i]->data+arg2_o[i])) + arg2_s[i]); } else { @@ -5230,7 +5263,8 @@ void __gg__substitute(cblc_field_t *dest, > retval_size ) { retval_size *= 2; - retval = (char *)realloc(retval, retval_size); + retval = static_cast<char *>(realloc(retval, retval_size)); + massert(retval); } // We checked earlier for FIRST/LAST matches @@ -5245,8 +5279,8 @@ void __gg__substitute(cblc_field_t *dest, continue; } - char *needle = (char *)(arg2_f[i]->data+arg2_o[i]); - char *needle_e = (char *)(arg2_f[i]->data+arg2_o[i]) + arg2_s[i]; + const char *needle = PTRCAST(char, arg2_f[i]->data+arg2_o[i]); + const char *needle_e = PTRCAST(char, arg2_f[i]->data+arg2_o[i]) + arg2_s[i]; matched = (control[i] & substitute_anycase_e) && iscasematch( haystack, haystack_e, @@ -5274,7 +5308,8 @@ void __gg__substitute(cblc_field_t *dest, while( outdex + 1 > retval_size ) { retval_size *= 2; - retval = (char *)realloc(retval, retval_size); + retval = static_cast<char *>(realloc(retval, retval_size)); + massert(retval); } retval[outdex++] = *haystack++; } @@ -5291,13 +5326,13 @@ void __gg__substitute(cblc_field_t *dest, extern "C" void __gg__locale_compare( cblc_field_t *dest, - cblc_field_t *arg1, + const cblc_field_t *arg1, size_t arg1_o, size_t arg1_s, - cblc_field_t *arg2, + const cblc_field_t *arg2, size_t arg2_o, size_t arg2_s, - cblc_field_t *arg_locale, + const cblc_field_t *arg_locale, size_t /*arg_locale_o*/, size_t /*arg_locale_s*/ ) @@ -5348,10 +5383,10 @@ __gg__locale_compare( cblc_field_t *dest, extern "C" void __gg__locale_date(cblc_field_t *dest, - cblc_field_t *arg1, + const cblc_field_t *arg1, size_t arg1_o, size_t /*arg1_s*/, - cblc_field_t *arg_locale, + const cblc_field_t *arg_locale, size_t /*arg_locale_o*/, size_t /*arg_locale_s*/) { @@ -5384,10 +5419,10 @@ __gg__locale_date(cblc_field_t *dest, extern "C" void __gg__locale_time(cblc_field_t *dest, - cblc_field_t *arg1, + const cblc_field_t *arg1, size_t arg1_o, size_t /*arg1_s*/, - cblc_field_t *arg_locale, + const cblc_field_t *arg_locale, size_t /*arg_locale_o*/, size_t /*arg_locale_s*/) @@ -5420,10 +5455,10 @@ __gg__locale_time(cblc_field_t *dest, extern "C" void __gg__locale_time_from_seconds( cblc_field_t *dest, - cblc_field_t *arg1, + const cblc_field_t *arg1, size_t arg1_o, size_t arg1_s, - cblc_field_t *arg_locale, + const cblc_field_t *arg_locale, size_t /*arg_locale_o*/, size_t /*arg_locale_s*/) { @@ -5439,7 +5474,7 @@ __gg__locale_time_from_seconds( cblc_field_t *dest, // Default locale tm tm = {}; - int rdigits; + int rdigits=0; long seconds = (long)__gg__binary_value_from_qualified_field(&rdigits, arg1, arg1_o, diff --git a/libgcobol/libgcobol.cc b/libgcobol/libgcobol.cc index 3ab7463..e89ca0a 100644 --- a/libgcobol/libgcobol.cc +++ b/libgcobol/libgcobol.cc @@ -65,14 +65,11 @@ #include "gfileio.h" #include "charmaps.h" #include "valconv.h" - #include <sys/mman.h> #include <sys/resource.h> #include <sys/stat.h> #include <sys/types.h> - #include <execinfo.h> - #include "exceptl.h" /* BSD extension. */ @@ -196,7 +193,7 @@ size_t __gg__unique_prog_id = 0 ; // location information are established in the "last_exception..." variables. // This is in accordance with the ISO requirements of "14.6.13.1.1 General" that // describe how a "last exception status" is maintained. -// other "location" information +// other "location" information static int last_exception_code; static const char *last_exception_program_id; static const char *last_exception_section; @@ -240,36 +237,43 @@ void *__gg__exit_address = NULL; * 4. handled, where handled == type * * If the statement includes some kind of ON ERROR - * clause that covers it, the generated code does not raise an EC. + * clause that covers it, the generated code does not raise an EC. * * The status is updated by __gg_match_exception if it runs, else - * __gg__check_fatal_exception. + * __gg__check_fatal_exception. * * If a Declarative is matched, its section number is passed to handled_by(), * which does two things: * 1. sets isection to record the declarative * 2. for a nonfatal EC, sets handled, indication no further action is needed * - * A Declarative may use RESUME, which clears ec_status, which is a "handled" state. - * - * Default processing ensures return to initial state. + * A Declarative may use RESUME, which clears ec_status, which is a "handled" state. + * + * Default processing ensures return to initial state. */ class ec_status_t { public: struct file_status_t { - size_t ifile; - cblc_file_prior_op_t operation; - cbl_file_mode_t mode; + size_t ifile; + cblc_file_prior_op_t operation; + cbl_file_mode_t mode; cblc_field_t *user_status; const char * filename; - file_status_t() : ifile(0) , operation(file_op_none), mode(file_mode_none_e) {} - file_status_t( cblc_file_t *file ) - : ifile(file->symbol_table_index) - , operation(file->prior_op) - , mode(cbl_file_mode_t(file->mode_char)) - , user_status(file->user_status) - , filename(file->filename) - {} + file_status_t() + : ifile(0) + , operation(file_op_none) + , mode(file_mode_none_e) + , user_status(nullptr) + , filename(nullptr) + {} +// cppcheck-suppress noExplicitConstructor + file_status_t( const cblc_file_t *file ) + : ifile(file->symbol_table_index) + , operation(file->prior_op) + , mode(cbl_file_mode_t(file->mode_char)) + , user_status(file->user_status) + , filename(file->filename) + {} const char * op_str() const { switch( operation ) { case file_op_none: return "none"; @@ -284,7 +288,7 @@ class ec_status_t { return "???"; } }; - private: + private: char msg[132]; ec_type_t type, handled; size_t isection; @@ -308,13 +312,13 @@ class ec_status_t { bool is_fatal() const; ec_status_t& update(); - + bool is_enabled() const { return enabled.match(type); } bool is_enabled( ec_type_t ec) const { return enabled.match(ec); } ec_status_t& handled_by( size_t declarative_section ) { isection = declarative_section; - // A fatal exception remains unhandled unless RESUME clears it. - if( ! is_fatal() ) { + // A fatal exception remains unhandled unless RESUME clears it. + if( ! is_fatal() ) { handled = type; } return *this; @@ -326,10 +330,10 @@ class ec_status_t { return *this; } bool unset() const { return isection == 0 && lineno == 0; } - + void reset_environment() const; ec_status_t& copy_environment(); - + // Return the EC's type if it is *not* handled. ec_type_t unhandled() const { bool was_handled = ec_cmp(type, handled); @@ -428,8 +432,17 @@ ec_status_t::reset_environment() const { ::declaratives = declaratives; } + +// This is the default truncation mode static cbl_truncation_mode truncation_mode = trunc_std_e; +extern "C" +void +__gg__set_truncation_mode(cbl_truncation_mode trunc_mode) + { + truncation_mode = trunc_mode; + } + struct program_state { // These are the run-time values of these characters. @@ -535,7 +548,6 @@ void *malloc(size_t a) void *retval = malloc(a); fprintf(stderr, " --malloc(%p)-- ", retval); return retval; - return retval; } #endif @@ -546,6 +558,12 @@ __gg__abort(const char *msg) abort(); } +void +__gg__mabort() + { + __gg__abort("Memory allocation error\n"); + } + extern "C" char __gg__get_decimal_point() @@ -576,7 +594,7 @@ __gg__resize_int_p( size_t *size, if( new_size > *size ) { *size = new_size; - *block = (int *)realloc(*block, new_size * sizeof(int)); + *block = static_cast<int *>(realloc(*block, new_size * sizeof(int))); } } @@ -591,36 +609,36 @@ __gg__resize_treeplet(int ngroup, if( new_size > treeplet_1_size ) { treeplet_1_size = new_size; - __gg__treeplet_1f = (cblc_field_t **)realloc(__gg__treeplet_1f, new_size * sizeof(cblc_field_t *)); - __gg__treeplet_1o = (size_t *)realloc(__gg__treeplet_1o, new_size * sizeof(size_t)); - __gg__treeplet_1s = (size_t *)realloc(__gg__treeplet_1s, new_size * sizeof(size_t)); + __gg__treeplet_1f = static_cast<cblc_field_t **>(realloc(__gg__treeplet_1f, new_size * sizeof(cblc_field_t *))); + __gg__treeplet_1o = static_cast<size_t *>(realloc(__gg__treeplet_1o, new_size * sizeof(size_t))); + __gg__treeplet_1s = static_cast<size_t *>(realloc(__gg__treeplet_1s, new_size * sizeof(size_t))); } break; case 2: if( new_size > treeplet_2_size ) { treeplet_2_size = new_size; - __gg__treeplet_2f = (cblc_field_t **)realloc(__gg__treeplet_2f, new_size * sizeof(cblc_field_t *)); - __gg__treeplet_2o = (size_t *)realloc(__gg__treeplet_2o, new_size * sizeof(size_t)); - __gg__treeplet_2s = (size_t *)realloc(__gg__treeplet_2s, new_size * sizeof(size_t)); + __gg__treeplet_2f = static_cast<cblc_field_t **>(realloc(__gg__treeplet_2f, new_size * sizeof(cblc_field_t *))); + __gg__treeplet_2o = static_cast<size_t *>(realloc(__gg__treeplet_2o, new_size * sizeof(size_t))); + __gg__treeplet_2s = static_cast<size_t *>(realloc(__gg__treeplet_2s, new_size * sizeof(size_t))); } break; case 3: if( new_size > treeplet_3_size ) { treeplet_3_size = new_size; - __gg__treeplet_3f = (cblc_field_t **)realloc(__gg__treeplet_3f, new_size * sizeof(cblc_field_t *)); - __gg__treeplet_3o = (size_t *)realloc(__gg__treeplet_3o, new_size * sizeof(size_t)); - __gg__treeplet_3s = (size_t *)realloc(__gg__treeplet_3s, new_size * sizeof(size_t)); + __gg__treeplet_3f = static_cast<cblc_field_t **>(realloc(__gg__treeplet_3f, new_size * sizeof(cblc_field_t *))); + __gg__treeplet_3o = static_cast<size_t *>(realloc(__gg__treeplet_3o, new_size * sizeof(size_t))); + __gg__treeplet_3s = static_cast<size_t *>(realloc(__gg__treeplet_3s, new_size * sizeof(size_t))); } break; case 4: if( new_size > treeplet_4_size ) { treeplet_4_size = new_size; - __gg__treeplet_4f = (cblc_field_t **)realloc(__gg__treeplet_4f, new_size * sizeof(cblc_field_t *)); - __gg__treeplet_4o = (size_t *)realloc(__gg__treeplet_4o, new_size * sizeof(size_t)); - __gg__treeplet_4s = (size_t *)realloc(__gg__treeplet_4s, new_size * sizeof(size_t)); + __gg__treeplet_4f = static_cast<cblc_field_t **>(realloc(__gg__treeplet_4f, new_size * sizeof(cblc_field_t *))); + __gg__treeplet_4o = static_cast<size_t *>(realloc(__gg__treeplet_4o, new_size * sizeof(size_t))); + __gg__treeplet_4s = static_cast<size_t *>(realloc(__gg__treeplet_4s, new_size * sizeof(size_t))); } break; } @@ -738,7 +756,7 @@ __gg__init_program_state() } static int -var_is_refmod( cblc_field_t *var ) +var_is_refmod( const cblc_field_t *var ) { return (var->attr & refmod_e) != 0; } @@ -907,9 +925,9 @@ __gg__binary_to_string_internal(char *result, int digits, __int128 value) } static bool -value_is_too_big( cblc_field_t *var, - __int128 value, - int source_rdigits) +value_is_too_big(const cblc_field_t *var, + __int128 value, + int source_rdigits) { // This routine is in support of arithmetic ON SIZE ERROR. It returns // TRUE if var hasn't enough bytes to hold the decimal representation @@ -1046,12 +1064,13 @@ is_sign_bit_on(char ch) extern "C" void -__gg__string_to_alpha_edited_ascii( char *dest, - char *source, - int slength, - char *picture) +__gg__string_to_alpha_edited_ascii( char *dest, + const char *source, + int slength, + const char *picture) { - char *dupe = (char *)malloc(slength); + char *dupe = static_cast<char *>(malloc(slength)); + massert(dupe); memcpy(dupe, source, slength); ascii_to_internal_str(dupe, slength); __gg__string_to_alpha_edited(dest, dupe, slength, picture); @@ -1406,7 +1425,7 @@ int128_to_field(cblc_field_t *var, { float tvalue = (float)value; tvalue /= (float)__gg__power_of_ten(source_rdigits); - *(float *)location = tvalue; + *PTRCAST(float, location) = tvalue; break; } @@ -1414,7 +1433,7 @@ int128_to_field(cblc_field_t *var, { double tvalue = (double)value; tvalue /= (double)__gg__power_of_ten(source_rdigits); - *(double *)location = tvalue; + *PTRCAST(double, location) = tvalue; break; } @@ -1478,8 +1497,6 @@ int128_to_field(cblc_field_t *var, default: { - bool size_error = false; - int target_rdigits = var->rdigits; if( var->attr & intermediate_e && var->type == FldNumericBin5) { @@ -1569,6 +1586,7 @@ int128_to_field(cblc_field_t *var, else { // Value is now scaled to the target's target_rdigits + bool size_error = false; int is_negative = value < 0 ; @@ -1598,8 +1616,9 @@ int128_to_field(cblc_field_t *var, // Note that sending a signed value to an alphanumeric strips off // any plus or minus signs. - size_error = __gg__binary_to_string_internal( (char *)location, - length, value); + size_error = __gg__binary_to_string_internal( + PTRCAST(char, location), + length, value); break; case FldNumericDisplay: @@ -1615,7 +1634,7 @@ int128_to_field(cblc_field_t *var, { // The sign character goes into the first location size_error = - __gg__binary_to_string_internal((char *)(location+1), + __gg__binary_to_string_internal(PTRCAST(char, location+1), length-1, value); location[0] = sign_ch; } @@ -1623,8 +1642,8 @@ int128_to_field(cblc_field_t *var, { // The sign character goes into the last location size_error = - __gg__binary_to_string_internal( (char *)location, - length-1, value); + __gg__binary_to_string_internal(PTRCAST(char, location), + length-1, value); location[length-1] = sign_ch; } } @@ -1633,7 +1652,7 @@ int128_to_field(cblc_field_t *var, // The sign information is not separate, so we put it into // the number size_error = - __gg__binary_to_string_internal(( char *)location, + __gg__binary_to_string_internal(PTRCAST(char, location), length, value); if( size_error && is_negative ) @@ -1669,7 +1688,8 @@ int128_to_field(cblc_field_t *var, else { // It's a simple positive number - size_error = __gg__binary_to_string_internal( (char *)location, + size_error = __gg__binary_to_string_internal( PTRCAST(char, + location), length, value); } @@ -1692,12 +1712,12 @@ int128_to_field(cblc_field_t *var, // Convert that string according to the PICTURE clause size_error |= __gg__string_to_numeric_edited( - (char *)location, + PTRCAST(char, location), ach, target_rdigits, is_negative, var->picture); - ascii_to_internal_str((char *)location, var->capacity); + ascii_to_internal_str( PTRCAST(char, location), var->capacity); } break; @@ -1733,7 +1753,7 @@ int128_to_field(cblc_field_t *var, // Convert that string according to the PICTURE clause __gg__string_to_alpha_edited( - (char *)location, + PTRCAST(char, location), ach, strlen(ach), var->picture); @@ -1849,11 +1869,11 @@ int128_to_field(cblc_field_t *var, } static __int128 -edited_to_binary( const char *ps_, +edited_to_binary( char *ps_, int length, int *rdigits) { - const unsigned char *ps = (const unsigned char *)ps_; + const unsigned char *ps = const_cast<const unsigned char *>(PTRCAST(unsigned char, ps_)); // This routine is used for converting NumericEdited strings to // binary. @@ -1879,8 +1899,6 @@ edited_to_binary( const char *ps_, __int128 result = 0; - unsigned char ch; - // We need to check the last two characters. If CR or DB, then the result // is negative: if( length >= 2) @@ -1901,7 +1919,7 @@ edited_to_binary( const char *ps_, while( index < length ) { - ch = ps[index++] & 0xFF; + unsigned char ch = ps[index++] & 0xFF; if( ch == ascii_to_internal(__gg__decimal_point) ) { delta_r = 1; @@ -1923,11 +1941,7 @@ edited_to_binary( const char *ps_, } } - if( result == 0 ) - { - hyphen = 0; - } - else if( hyphen ) + if( hyphen ) { result = -result; } @@ -1957,7 +1971,7 @@ big_endian_to_binary_signed( } // move the bytes of psource into retval, flipping them end-to-end - unsigned char *dest = (unsigned char *)&retval; + unsigned char *dest = PTRCAST(unsigned char, &retval); while(capacity > 0) { *dest++ = psource[--capacity]; @@ -2021,7 +2035,7 @@ big_endian_to_binary_unsigned( __int128 retval = 0 ; // move the bytes of psource into retval, flipping them end-to-end - unsigned char *dest = (unsigned char *)&retval; + unsigned char *dest = PTRCAST(unsigned char, &retval); while(capacity > 0) { *dest++ = psource[--capacity]; @@ -2031,10 +2045,10 @@ big_endian_to_binary_unsigned( static __int128 -get_binary_value_local( int *rdigits, - cblc_field_t *resolved_var, - unsigned char *resolved_location, - size_t resolved_length) +get_binary_value_local( int *rdigits, + const cblc_field_t *resolved_var, + unsigned char *resolved_location, + size_t resolved_length) { __int128 retval = 0; @@ -2055,7 +2069,8 @@ get_binary_value_local( int *rdigits, case FldGroup : case FldAlphanumeric : // Read the data area as a dirty string: - retval = __gg__dirty_to_binary_internal( (const char *)resolved_location, + retval = __gg__dirty_to_binary_internal( PTRCAST(const char, + resolved_location), resolved_length, rdigits ); break; @@ -2082,8 +2097,8 @@ get_binary_value_local( int *rdigits, // Turn all the bits on memset( &retval, 0xFF, sizeof(retval) ); - // Make it positive - ((unsigned char *)&retval)[sizeof(retval)-1] = 0x3F; + // Make it positive by turning off the highest order bit: + (PTRCAST(unsigned char, &retval))[sizeof(retval)-1] = 0x3F; *rdigits = resolved_var->rdigits; } else @@ -2120,7 +2135,8 @@ get_binary_value_local( int *rdigits, // We know where the decimal point is because of rdigits. Because // we know that it a clean string of ASCII digits, we can use the // dirty converter: - retval = __gg__dirty_to_binary_internal((const char *)resolved_location, + retval = __gg__dirty_to_binary_internal(PTRCAST(const char, + resolved_location), resolved_length, rdigits ); *rdigits = resolved_var->rdigits; @@ -2136,7 +2152,7 @@ get_binary_value_local( int *rdigits, break; case FldNumericEdited : - retval = edited_to_binary( (const char *)resolved_location, + retval = edited_to_binary( PTRCAST(char, resolved_location), resolved_length, rdigits); break; @@ -2145,13 +2161,13 @@ get_binary_value_local( int *rdigits, if( resolved_var->attr & signable_e) { retval = big_endian_to_binary_signed( - (const unsigned char *)resolved_location, + PTRCAST(const unsigned char, resolved_location), resolved_length); } else { retval = big_endian_to_binary_unsigned( - (const unsigned char *)resolved_location, + PTRCAST(const unsigned char, resolved_location), resolved_length); } *rdigits = resolved_var->rdigits; @@ -2179,13 +2195,13 @@ get_binary_value_local( int *rdigits, if( resolved_var->attr & signable_e) { retval = little_endian_to_binary_signed( - (const unsigned char *)resolved_location, + PTRCAST(const unsigned char, resolved_location), resolved_length); } else { retval = little_endian_to_binary_unsigned( - (const unsigned char *)resolved_location, + PTRCAST(const unsigned char, resolved_location), resolved_length); } *rdigits = resolved_var->rdigits; @@ -2273,7 +2289,7 @@ get_binary_value_local( int *rdigits, static time_t cobol_time() { - struct timespec tp; + struct cbl_timespec tp; __gg__clock_gettime(CLOCK_REALTIME, &tp); return tp.tv_sec; } @@ -2285,7 +2301,7 @@ __gg__get_date_yymmdd() char ach[32]; time_t t = cobol_time(); - struct tm *local = localtime(&t); + const struct tm *local = localtime(&t); sprintf(ach, "%2.2d%2.2d%2.2d", @@ -2304,7 +2320,7 @@ __gg__get_date_yyyymmdd() char ach[32]; time_t t = cobol_time(); - struct tm *local = localtime(&t); + const struct tm *local = localtime(&t); sprintf(ach, "%4.4d%2.2d%2.2d", @@ -2323,7 +2339,7 @@ __gg__get_date_yyddd() char ach[32]; time_t t = cobol_time(); - struct tm *local = localtime(&t); + const struct tm *local = localtime(&t); sprintf(ach, "%2.2d%3.3d", @@ -2341,7 +2357,7 @@ __gg__get_yyyyddd() char ach[32]; time_t t = cobol_time(); - struct tm *local = localtime(&t); + const struct tm *local = localtime(&t); sprintf(ach, "%4.4d%3.3d", @@ -2359,7 +2375,7 @@ __gg__get_date_dow() char ach[32]; time_t t = cobol_time(); - struct tm *local = localtime(&t); + const struct tm *local = localtime(&t); sprintf(ach, "%1.1d", @@ -2386,10 +2402,32 @@ int_from_digits(const char * &p, int ndigits) return retval; } +uint64_t +get_time_nanoseconds() +{ + // This code was unabashedly stolen from gcc/timevar.cc. + // It returns the Unix epoch with nine decimal places. + + uint64_t retval = 0; + +#ifdef HAVE_CLOCK_GETTIME + struct timespec ts; + clock_gettime (CLOCK_REALTIME, &ts); + retval = ts.tv_sec * 1000000000 + ts.tv_nsec; + return retval; +#endif +#ifdef HAVE_GETTIMEOFDAY + struct timeval tv; + gettimeofday (&tv, NULL); + retval = tv.tv_sec * 1000000000 + tv.tv_usec * 1000; + return retval; +#endif + return retval; +} extern "C" void -__gg__clock_gettime(clockid_t clk_id, struct timespec *tp) +__gg__clock_gettime(clockid_t clk_id, struct cbl_timespec *tp) { const char *p = getenv("GCOBOL_CURRENT_DATE"); @@ -2419,7 +2457,11 @@ __gg__clock_gettime(clockid_t clk_id, struct timespec *tp) } else { - clock_gettime(clk_id, tp); + timespec tm; + clock_gettime(clk_id, &tm); + uint64_t ns = get_time_nanoseconds(); + tp->tv_sec = ns/1000000000; + tp->tv_nsec = ns%1000000000; } } @@ -2429,7 +2471,7 @@ __gg__get_date_hhmmssff() { char ach[32]; - struct timespec tv; + struct cbl_timespec tv; __gg__clock_gettime(CLOCK_REALTIME, &tv); struct tm tm; @@ -2459,20 +2501,19 @@ int __gg__setop_compare( const char *candidate, int capacity, - const char *domain) + char *domain) { // This routine is called to compare the characters of 'candidate' // against the list of character pairs in 'domain' int retval = 0; - int ch; int l; int h; - const char *d; + char *d; for(int i=0; i<capacity; i++) { - ch = (*candidate++ & 0xFF); + int ch = (*candidate++ & 0xFF); d = domain; while(*d) { @@ -2484,7 +2525,7 @@ __gg__setop_compare( // See the comments in genapi.cc::get_class_condition_string // to see how this string was encoded. - l = (int)strtoll(d, (char **)&d, 16); + l = (int)strtoll(d, reinterpret_cast<char **>(&d), 16); if( l < 0 ) { l = -l; @@ -2493,7 +2534,7 @@ __gg__setop_compare( if( *d == '/' ) { d += 1; - h = (int)strtoll(d, (char **)&d, 16); + h = (int)strtoll(d, reinterpret_cast<char **>(&d), 16); if( h < 0 ) { h = -h; @@ -2943,7 +2984,7 @@ void psz_to_internal(char *psz) } static int -get_scaled_rdigits(cblc_field_t *field) +get_scaled_rdigits(const cblc_field_t *field) { int retval; if( !(field->attr & scaled_e) ) @@ -3048,7 +3089,7 @@ format_for_display_internal(char **dest, break; } - unsigned char *running_location = actual_location; + const unsigned char *running_location = actual_location; // We need the counts of digits to the left and right of the decimal point int rdigits = get_scaled_rdigits(var); @@ -3063,7 +3104,6 @@ format_for_display_internal(char **dest, rdigits += ldigits; } - int index = 0; // This is the running index into our output destination if( rdigits ) { // We need room for the inside decimal point @@ -3080,6 +3120,7 @@ format_for_display_internal(char **dest, if( actual_location ) { + int index = 0; // This is the running index into our output destination if( var->attr & signable_e ) { if( var->attr & separate_e ) @@ -3124,7 +3165,7 @@ format_for_display_internal(char **dest, // the user. if( (*dest)[index-1] != (char)DEGENERATE_HIGH_VALUE ) { - turn_sign_bit_off((unsigned char *)&ch); + turn_sign_bit_off( PTRCAST(unsigned char, &ch)); } (*dest)[index++] = ch; } @@ -3148,7 +3189,7 @@ format_for_display_internal(char **dest, char ch = *running_location++; if( (*dest)[index-1] != (char)DEGENERATE_HIGH_VALUE ) { - turn_sign_bit_off((unsigned char *)&ch); + turn_sign_bit_off(PTRCAST(unsigned char, &ch)); } (*dest)[index++] = ch; } @@ -3257,11 +3298,9 @@ format_for_display_internal(char **dest, } __gg__realloc_if_necessary(dest, dest_size, nsize); - bool is_signed = value < 0; - if( var->attr & signable_e ) { - if( is_signed ) + if( value < 0 ) { (*dest)[index++] = internal_minus; } @@ -3293,7 +3332,7 @@ format_for_display_internal(char **dest, actual_location, actual_length); char ach[64]; - sprintf(ach, "%lu", (size_t)value); + sprintf(ach, "%lu", (unsigned long)value); __gg__realloc_if_necessary(dest, dest_size, strlen(ach)+1); strcpy(*dest, ach); } @@ -3349,7 +3388,7 @@ format_for_display_internal(char **dest, // side, and 9999999 and then 1E+7 on the high side // 10,000,000 = 1E7 char ach[64]; - _Float32 floatval = *(_Float32 *)actual_location; + _Float32 floatval = *PTRCAST(_Float32, actual_location); strfromf32(ach, sizeof(ach), "%.9E", floatval); char *p = strchr(ach, 'E'); if( !p ) @@ -3389,7 +3428,7 @@ format_for_display_internal(char **dest, // We will also format numbers so that we produce 0.01 and 1E-3 on the low // side, and 9999999 and then 1E+15 on the high side char ach[64]; - _Float64 floatval = *(_Float64 *)actual_location; + _Float64 floatval = *PTRCAST(_Float64, actual_location); strfromf64(ach, sizeof(ach), "%.17E", floatval); char *p = strchr(ach, 'E'); if( !p ) @@ -3483,7 +3522,8 @@ format_for_display_internal(char **dest, if( var->attr & scaled_e && var->type != FldNumericDisplay ) { static size_t buffer_size = MINIMUM_ALLOCATION_SIZE; - static char * buffer = (char *)malloc(buffer_size); + static char *buffer = static_cast<char *>(malloc(buffer_size)); + massert(buffer); if( var->rdigits > 0) { // We have something like 123 or +123. We need to insert a decimal @@ -3542,7 +3582,7 @@ format_for_display_internal(char **dest, { p2 += 1; } - strcpy((char *)p1, (char *)p2); + strcpy(PTRCAST(char, p1), PTRCAST(char, p2)); } done: @@ -3591,7 +3631,8 @@ compare_88( const char *list, { // We are working with a figurative constant - test = (char *)malloc(conditional_length); + test = static_cast<char *>(malloc(conditional_length)); + massert(test); test_len = conditional_length; // This is where we handle the zero-length strings that // nonetheless can magically be expanded into figurative @@ -3628,14 +3669,16 @@ compare_88( const char *list, else if( list_len < conditional_length ) { // 'list' is too short; we have to right-fill with spaces: - test = (char *)malloc(conditional_length); + test = static_cast<char *>(malloc(conditional_length)); + massert(test); test_len = conditional_length; memset(test, internal_space, conditional_length); memcpy(test, list, list_len); } else { - test = (char *)malloc(list_len); + test = static_cast<char *>(malloc(list_len)); + massert(test); test_len = list_len; memcpy(test, list, list_len); } @@ -3648,7 +3691,9 @@ compare_88( const char *list, } else { - cmpval = cstrncmp(test, (char *)conditional_location, conditional_length); + cmpval = cstrncmp (test, + PTRCAST(char, conditional_location), + conditional_length); if( cmpval == 0 && (int)strlen(test) != conditional_length ) { // When strncmp returns 0, the actual smaller string is the @@ -3671,7 +3716,7 @@ compare_88( const char *list, } static GCOB_FP128 -get_float128( cblc_field_t *field, +get_float128( const cblc_field_t *field, unsigned char *location ) { GCOB_FP128 retval=0; @@ -3680,10 +3725,10 @@ get_float128( cblc_field_t *field, switch( field->capacity ) { case 4: - retval = *(_Float32 *)location; + retval = *PTRCAST(_Float32 , location); break; case 8: - retval = *(_Float64 *)location; + retval = *PTRCAST(_Float64 , location); break; case 16: // retval = *(_Float128 *)location; doesn't work, because the SSE @@ -3703,12 +3748,13 @@ get_float128( cblc_field_t *field, { // We need to replace any commas with periods static size_t size = 128; - static char *buffer = (char *)malloc(size); + static char *buffer = static_cast<char *>(malloc(size)); while( strlen(field->initial)+1 > size ) { size *= 2; - buffer = (char *)malloc(size); + buffer = static_cast<char *>(malloc(size)); } + massert(buffer); strcpy(buffer, field->initial); char *p = strchr(buffer, ','); if(p) @@ -3753,7 +3799,7 @@ compare_field_class(cblc_field_t *conditional, conditional, conditional_location, conditional_length); - char *walker = list->initial; + const char *walker = list->initial; while(*walker) { char left_flag; @@ -3899,8 +3945,8 @@ compare_field_class(cblc_field_t *conditional, case FldFloat: { - GCOB_FP128 value = get_float128(conditional, conditional_location) ; - char *walker = list->initial; + GCOB_FP128 fp128 = get_float128(conditional, conditional_location) ; + const char *walker = list->initial; while(*walker) { char left_flag; @@ -3945,7 +3991,7 @@ compare_field_class(cblc_field_t *conditional, right_len); } - if( left_value <= value && value <= right_value ) + if( left_value <= fp128 && fp128 <= right_value ) { retval = 0; break; @@ -4025,12 +4071,12 @@ local_is_alpha(int type, bool address_of) static int -compare_strings(char *left_string, - size_t left_length, - bool left_all, - char *right_string, - size_t right_length, - bool right_all) +compare_strings(const char *left_string, + size_t left_length, + bool left_all, + const char *right_string, + size_t right_length, + bool right_all) { int retval = 0; size_t i = 0; @@ -4284,6 +4330,7 @@ __gg__compare_2(cblc_field_t *left_side, retval = 0; retval = value < 0 ? -1 : retval; retval = value > 0 ? 1 : retval; + compare = true; break; } @@ -4294,6 +4341,7 @@ __gg__compare_2(cblc_field_t *left_side, retval = 0; retval = value < 0 ? -1 : retval; retval = value > 0 ? 1 : retval; + compare = true; break; } @@ -4312,9 +4360,7 @@ __gg__compare_2(cblc_field_t *left_side, compare = true; break; } - compare = true; goto fixup_retval; - break; } } } @@ -4329,10 +4375,10 @@ __gg__compare_2(cblc_field_t *left_side, if( local_is_alpha(left_side->type, left_address_of) && local_is_alpha(right_side->type, right_address_of) ) { - retval = compare_strings( (char *)left_location, + retval = compare_strings( reinterpret_cast<char *>(left_location), left_length, left_all, - (char *)right_location, + reinterpret_cast<char *>(right_location), right_length, right_all ); @@ -4368,12 +4414,13 @@ __gg__compare_2(cblc_field_t *left_side, // literal to be the same flavor as the left side: // We need to replace any commas with periods static size_t size = 128; - static char *buffer = (char *)malloc(size); + static char *buffer = static_cast<char *>(malloc(size)); while( strlen(right_side->initial)+1 > size ) { size *= 2; - buffer = (char *)malloc(size); + buffer = static_cast<char *>(malloc(size)); } + massert(buffer); strcpy(buffer, right_side->initial); if( __gg__decimal_point == ',' ) { @@ -4391,31 +4438,31 @@ __gg__compare_2(cblc_field_t *left_side, { case 4: { - _Float32 left_value = *(_Float32 *)left_location; - _Float32 right_value = strtof(buffer, NULL); + _Float32 left_value4 = *PTRCAST(_Float32, left_location); + _Float32 right_value4 = strtof(buffer, NULL); retval = 0; - retval = left_value < right_value ? -1 : retval; - retval = left_value > right_value ? 1 : retval; + retval = left_value4 < right_value4 ? -1 : retval; + retval = left_value4 > right_value4 ? 1 : retval; break; } case 8: { - _Float64 left_value = *(_Float64 *)left_location; - _Float64 right_value = strtod(buffer, NULL); + _Float64 left_value8 = *PTRCAST(_Float64, left_location); + _Float64 right_value8 = strtod(buffer, NULL); retval = 0; - retval = left_value < right_value ? -1 : retval; - retval = left_value > right_value ? 1 : retval; + retval = left_value8 < right_value8 ? -1 : retval; + retval = left_value8 > right_value8 ? 1 : retval; break; } case 16: { //_Float128 left_value = *(_Float128 *)left_location; - GCOB_FP128 left_value; - memcpy(&left_value, left_location, 16); - GCOB_FP128 right_value = strtofp128(buffer, NULL); + GCOB_FP128 left_value16; + memcpy(&left_value16, left_location, 16); + GCOB_FP128 right_value16 = strtofp128(buffer, NULL); retval = 0; - retval = left_value < right_value ? -1 : retval; - retval = left_value > right_value ? 1 : retval; + retval = left_value16 < right_value16 ? -1 : retval; + retval = left_value16 > right_value16 ? 1 : retval; break; } } @@ -4500,10 +4547,10 @@ __gg__compare_2(cblc_field_t *left_side, if( right_refmod ) { - retval = compare_strings( (char *)left_location, + retval = compare_strings( reinterpret_cast<char *>(left_location), left_length, left_all, - (char *)right_location, + reinterpret_cast<char *>(right_location), right_length, right_all); compare = true; @@ -4521,12 +4568,13 @@ __gg__compare_2(cblc_field_t *left_side, // VAL5 EQUAL "005" is TRUE if( left_side->type == FldLiteralA ) { - left_location = (unsigned char *)left_side->data; + left_location = reinterpret_cast<unsigned char *>(left_side->data); left_length = left_side->capacity; } static size_t right_string_size = MINIMUM_ALLOCATION_SIZE; - static char *right_string = (char *)malloc(right_string_size); + static char *right_string + = static_cast<char *>(malloc(right_string_size)); right_string = format_for_display_internal( &right_string, @@ -4550,7 +4598,7 @@ __gg__compare_2(cblc_field_t *left_side, left_length -= 1; } - char *right_fixed; + const char *right_fixed; if( *right_string == internal_plus || *right_string == internal_minus ) { right_fixed = right_string + 1; @@ -4560,7 +4608,7 @@ __gg__compare_2(cblc_field_t *left_side, right_fixed = right_string; } - retval = compare_strings( (char *)left_location, + retval = compare_strings( reinterpret_cast<char *>(left_location), left_length, left_all, right_fixed, @@ -4793,16 +4841,16 @@ sort_contents(unsigned char *contents, extern "C" void -__gg__sort_table( cblc_field_t *table, - size_t table_o, - size_t depending_on, - size_t nkeys, - cblc_field_t **keys, - size_t *ascending, - int duplicates ) +__gg__sort_table( const cblc_field_t *table, + size_t table_o, + size_t depending_on, + size_t nkeys, + cblc_field_t **keys, + size_t *ascending, + int duplicates ) { size_t buffer_size = 128; - unsigned char *contents = (unsigned char *)malloc(buffer_size); + unsigned char *contents = static_cast<unsigned char *>(malloc(buffer_size)); size_t offset = 0; std::vector<size_t>offsets; size_t record_size = table->capacity; @@ -4814,7 +4862,7 @@ __gg__sort_table( cblc_field_t *table, while( offset + sizeof(size_t) + record_size > buffer_size ) { buffer_size *= 2; - contents = (unsigned char *)realloc(contents, buffer_size); + contents = static_cast<unsigned char *>(realloc(contents, buffer_size)); } offsets.push_back(offset); memcpy(contents+offset, &record_size, sizeof(size_t)); @@ -4894,7 +4942,7 @@ init_var_both(cblc_field_t *var, { //fprintf(stderr, "ABORTING on %2.2d %s %d\n", var->level, var->name, var->type); //abort(); - var->data = (unsigned char *)malloc(var->capacity); + var->data = static_cast<unsigned char *>(malloc(var->capacity)); } // Set the "initialized" bit, which is tested in parser_symbol_add to make @@ -4920,11 +4968,11 @@ init_var_both(cblc_field_t *var, // We need to convert the options to the internal native codeset size_t buffer_size = 4; - char *buffer = (char *)malloc(buffer_size); + char *buffer = static_cast<char *>(malloc(buffer_size)); size_t index = 0; - cblc_field_t *parent = var->parent; + const cblc_field_t *parent = var->parent; switch(parent->type) { case FldGroup: @@ -4934,9 +4982,9 @@ init_var_both(cblc_field_t *var, while(*walker) { static size_t first_size = MINIMUM_ALLOCATION_SIZE; - static char *first = (char *)malloc(first_size); + static char *first = static_cast<char *>(malloc(first_size)); static size_t last_size = MINIMUM_ALLOCATION_SIZE; - static char *last = (char *)malloc(last_size); + static char *last = static_cast<char *>(malloc(last_size)); if( (*walker & 0xFF) == 0xFF ) { strcpy(first, walker); @@ -4959,7 +5007,7 @@ init_var_both(cblc_field_t *var, while(index + strlen(first) + strlen(last) + 3 > buffer_size) { buffer_size *= 2; - buffer = (char *)realloc(buffer, buffer_size); + buffer = static_cast<char *>(realloc(buffer, buffer_size)); } strcpy(buffer+index, first); index += strlen(first) + 1; @@ -4972,7 +5020,7 @@ init_var_both(cblc_field_t *var, } if( index > 0 ) { - buffer = (char *)realloc(buffer, index); + buffer = static_cast<char *>(realloc(buffer, index)); local_initial = buffer; } } @@ -5012,7 +5060,7 @@ init_var_both(cblc_field_t *var, // memory to the default. But if a parent has been initialized, we must not // touch our memory: bool a_parent_initialized = false; - if( var->data && !explicitly ) + if( !explicitly ) { while(parent) { @@ -5228,7 +5276,7 @@ init_var_both(cblc_field_t *var, __gg__abort("Unknown variable type"); } - char *location = (char *)save_the_location; + char *location = reinterpret_cast<char *>(save_the_location); there_is_more = false; size_t i=0; @@ -5254,7 +5302,7 @@ init_var_both(cblc_field_t *var, } } - outer_location = (unsigned char *)location; + outer_location = reinterpret_cast<unsigned char *>(location); } while(there_is_more); var->data = save_the_location; @@ -5301,7 +5349,7 @@ alpha_to_alpha_move_from_location(cblc_field_t *field, // and dest are alphanumeric dest_length = dest_length ? dest_length : field->capacity; - char *to = (char *)field->data + dest_offset; + char *to = reinterpret_cast<char *>(field->data + dest_offset); const char *from = source_location; size_t count = std::min(dest_length, source_length); @@ -5397,7 +5445,7 @@ static void alpha_to_alpha_move(cblc_field_t *dest, size_t dest_offset, size_t dest_size, - cblc_field_t *source, + const cblc_field_t *source, size_t source_offset, size_t source_size, bool source_move_all) @@ -5405,7 +5453,7 @@ alpha_to_alpha_move(cblc_field_t *dest, alpha_to_alpha_move_from_location( dest, dest_offset, dest_size, - (char *)(source->data + source_offset), + reinterpret_cast<char *>(source->data + source_offset), source_size, source_move_all); } @@ -5439,13 +5487,9 @@ __gg__move( cblc_field_t *fdest, { int size_error = 0; // This is the return value - bool moved = true; - __int128 value; int rdigits; - size_t min_length; - cbl_figconst_t source_figconst = (cbl_figconst_t)(fsource->attr & FIGCONST_MASK); cbl_field_type_t dest_type = (cbl_field_type_t)fdest->type; @@ -5489,7 +5533,7 @@ __gg__move( cblc_field_t *fdest, * standard COBOL and its use should be avoided */ - int special_char; + int special_char = 0; // quiets cppcheck if( source_figconst == low_value_e ) { special_char = ascii_to_internal(__gg__low_value_character); @@ -5512,6 +5556,8 @@ __gg__move( cblc_field_t *fdest, } else { + size_t min_length; + bool moved = true; switch( dest_type ) { case FldGroup: @@ -5592,9 +5638,6 @@ __gg__move( cblc_field_t *fdest, // alphanumeric. We ignore any sign bit, and just // move the characters: - int rdigits; - __int128 value; - size_t source_digits = fsource->digits + ( fsource->rdigits < 0 @@ -5760,7 +5803,7 @@ __gg__move( cblc_field_t *fdest, fsource, source_offset, source_size); - sprintf(ach, "%lu", (size_t)value); + sprintf(ach, "%lu", (unsigned long)value); char *pach = ach; @@ -5884,31 +5927,31 @@ __gg__move( cblc_field_t *fdest, { rdigits = get_scaled_rdigits(fdest); bool negative = false; - __int128 value=0; + __int128 value128 = 0; switch(fsource->capacity) { case 4: { - _Float32 val = *(_Float32 *)(fsource->data+source_offset); + _Float32 val = *PTRCAST(_Float32, fsource->data+source_offset); if(val < 0) { negative = true; val = -val; } - val *= (_Float32)__gg__power_of_ten(rdigits); - value = (__int128)val; + val *= static_cast<_Float32>(__gg__power_of_ten(rdigits)); + value128 = (__int128)val; break; } case 8: { - _Float64 val = *(_Float64 *)(fsource->data+source_offset); + _Float64 val = *PTRCAST(_Float64, fsource->data+source_offset); if(val < 0) { negative = true; val = -val; } val *= (_Float32)__gg__power_of_ten(rdigits); - value = (__int128)val; + value128 = (__int128)val; break; } case 16: @@ -5922,19 +5965,19 @@ __gg__move( cblc_field_t *fdest, val = -val; } val *= (_Float32)__gg__power_of_ten(rdigits); - value = (__int128)val; + value128 = (__int128)val; break; } } if( negative ) { - value = -value; + value128 = -value128; } __gg__int128_to_qualified_field( fdest, dest_offset, dest_size, - value, + value128, rdigits, rounded, &size_error ); @@ -6002,30 +6045,30 @@ __gg__move( cblc_field_t *fdest, // We are converted a floating-point value fixed-point rdigits = get_scaled_rdigits(fdest); - GCOB_FP128 value=0; + GCOB_FP128 fp128=0; switch(fsource->capacity) { case 4: { - value = *(_Float32 *)(fsource->data+source_offset); + fp128 = *reinterpret_cast<_Float32 *>(fsource->data+source_offset); break; } case 8: { - value = *(_Float64 *)(fsource->data+source_offset); + fp128 = *reinterpret_cast<_Float64 *>(fsource->data+source_offset); break; } case 16: { // value = *(_Float128 *)(fsource->data+source_offset); - memcpy(&value, fsource->data+source_offset, 16); + memcpy(&fp128, fsource->data+source_offset, 16); break; } } __gg__float128_to_qualified_field( fdest, dest_offset, - value, + fp128, rounded, &size_error); break; @@ -6056,9 +6099,6 @@ __gg__move( cblc_field_t *fdest, case FldNumericDisplay: { - int rdigits; - __int128 value; - int source_digits = fsource->digits + (fsource->rdigits<0 ? -fsource->rdigits : 0) ; // Pick up the absolute value of the source @@ -6079,7 +6119,7 @@ __gg__move( cblc_field_t *fdest, } // And move them into place: - __gg__string_to_alpha_edited( (char *)(fdest->data+dest_offset), + __gg__string_to_alpha_edited( reinterpret_cast<char *>(fdest->data+dest_offset), ach, source_digits, fdest->picture); @@ -6089,7 +6129,7 @@ __gg__move( cblc_field_t *fdest, default: { static size_t display_string_size = MINIMUM_ALLOCATION_SIZE; - static char *display_string = (char *)malloc(display_string_size); + static char *display_string = static_cast<char *>(malloc(display_string_size)); size_t display_string_length = dest_size; __gg__realloc_if_necessary( &display_string, @@ -6122,12 +6162,12 @@ __gg__move( cblc_field_t *fdest, &display_string, &display_string_size, fsource, - (unsigned char *)(fsource->data+source_offset), + reinterpret_cast<unsigned char *>(fsource->data+source_offset), source_size, source_flags && REFER_T_ADDRESS_OF); display_string_length = strlen(display_string); } - __gg__string_to_alpha_edited( (char *)(fdest->data+dest_offset), + __gg__string_to_alpha_edited( reinterpret_cast<char *>(fdest->data+dest_offset), display_string, display_string_length, fdest->picture); @@ -6152,12 +6192,12 @@ __gg__move( cblc_field_t *fdest, { case 4: { - *(float *)(fdest->data+dest_offset) = strtof(ach, NULL); + *PTRCAST(float, fdest->data+dest_offset) = strtod(ach, NULL); break; } case 8: { - *(double *)(fdest->data+dest_offset) = strtod(ach, NULL); + *PTRCAST(double, fdest->data+dest_offset) = strtod(ach, NULL); break; } case 16: @@ -6167,7 +6207,6 @@ __gg__move( cblc_field_t *fdest, memcpy(fdest->data+dest_offset, &t, 16); break; } - break; } break; } @@ -6296,7 +6335,7 @@ __gg__move_literala(cblc_field_t *field, case FldAlphaEdited: { static size_t display_string_size = MINIMUM_ALLOCATION_SIZE; - static char *display_string = (char *)malloc(display_string_size); + static char *display_string = static_cast<char *>(malloc(display_string_size)); __gg__realloc_if_necessary( &display_string, &display_string_size, @@ -6305,7 +6344,7 @@ __gg__move_literala(cblc_field_t *field, memset(display_string, internal_space, display_string_size); size_t len = std::min(display_string_size, strlen); memcpy(display_string, str, len); - __gg__string_to_alpha_edited( (char *)(field->data+field_offset), + __gg__string_to_alpha_edited( reinterpret_cast<char *>(field->data+field_offset), display_string, field_size, field->picture); @@ -6322,12 +6361,12 @@ __gg__move_literala(cblc_field_t *field, { case 4: { - *(float *)(field->data+field_offset) = strtof(ach, NULL); + *PTRCAST(float, field->data+field_offset) = strtod(ach, NULL); break; } case 8: { - *(double *)(field->data+field_offset) = strtod(ach, NULL); + *PTRCAST(double, field->data+field_offset) = strtod(ach, NULL); break; } case 16: @@ -6336,7 +6375,6 @@ __gg__move_literala(cblc_field_t *field, memcpy(field->data+field_offset, &t, 16); break; } - break; } break; } @@ -6457,7 +6495,7 @@ __gg__sort_workfile(cblc_file_t *workfile, // Read the file into memory size_t buffer_size = 128; - unsigned char *contents = (unsigned char *)malloc(buffer_size); + unsigned char *contents = static_cast<unsigned char *>(malloc(buffer_size)); size_t offset = 0; std::vector<size_t>offsets; size_t bytes_read; @@ -6487,7 +6525,7 @@ __gg__sort_workfile(cblc_file_t *workfile, while( offset + sizeof(size_t) + bytes_read > buffer_size ) { buffer_size *= 2; - contents = (unsigned char *)realloc(contents, buffer_size); + contents = static_cast<unsigned char *>(realloc(contents, buffer_size)); } offsets.push_back(offset); @@ -6586,7 +6624,8 @@ __gg__merge_files( cblc_file_t *workfile, return; } - unsigned char *prior_winner = (unsigned char *)malloc(the_biggest); + unsigned char *prior_winner = static_cast<unsigned char *>(malloc(the_biggest)); + massert(prior_winner); *prior_winner = '\0'; for(;;) @@ -6766,7 +6805,7 @@ normalize_id( const cblc_field_t *refer, if( refer ) { - unsigned char *data = refer->data + refer_o; + const unsigned char *data = refer->data + refer_o; cbl_figconst_t figconst = (cbl_figconst_t)(refer->attr & FIGCONST_MASK); @@ -7007,7 +7046,7 @@ the_alpha_and_omega_backward( const normalized_operand &id_before, static void -inspect_backward_format_1(size_t integers[]) +inspect_backward_format_1(const size_t integers[]) { size_t int_index = 0; size_t cblc_index = 0; @@ -7020,9 +7059,9 @@ inspect_backward_format_1(size_t integers[]) std::vector<id_2_result> id_2_results(n_identifier_2); // Pick up identifier_1, which is the string being inspected - cblc_field_t *id1 = __gg__treeplet_1f[cblc_index]; - size_t id1_o = __gg__treeplet_1o[cblc_index]; - size_t id1_s = __gg__treeplet_1s[cblc_index]; + const cblc_field_t *id1 = __gg__treeplet_1f[cblc_index]; + size_t id1_o = __gg__treeplet_1o[cblc_index]; + size_t id1_s = __gg__treeplet_1s[cblc_index]; cblc_index += 1; // normalize it, according to the language specification. normalized_operand normalized_id_1 = normalize_id(id1, id1_o, id1_s); @@ -7055,19 +7094,19 @@ inspect_backward_format_1(size_t integers[]) // We are counting characters. There is no identifier-3, // but we we hard-code the length to one to represent a // single character. - comparand next_comparand; + comparand next_comparand = {}; next_comparand.id_2_index = i; next_comparand.operation = operation; next_comparand.identifier_3.length = 1; - cblc_field_t *id4_before = __gg__treeplet_1f [cblc_index]; - size_t id4_before_o = __gg__treeplet_1o[cblc_index]; - size_t id4_before_s = __gg__treeplet_1s[cblc_index]; + const cblc_field_t *id4_before = __gg__treeplet_1f [cblc_index]; + size_t id4_before_o = __gg__treeplet_1o[cblc_index]; + size_t id4_before_s = __gg__treeplet_1s[cblc_index]; cblc_index += 1; - cblc_field_t *id4_after = __gg__treeplet_1f [cblc_index]; - size_t id4_after_o = __gg__treeplet_1o[cblc_index]; - size_t id4_after_s = __gg__treeplet_1s[cblc_index]; + const cblc_field_t *id4_after = __gg__treeplet_1f [cblc_index]; + size_t id4_after_o = __gg__treeplet_1o[cblc_index]; + size_t id4_after_s = __gg__treeplet_1s[cblc_index]; cblc_index += 1; normalized_operand normalized_id_4_before @@ -7099,23 +7138,23 @@ inspect_backward_format_1(size_t integers[]) for(size_t k=0; k<pair_count; k++) { - comparand next_comparand; + comparand next_comparand = {}; next_comparand.id_2_index = i; next_comparand.operation = operation; - cblc_field_t *id3 = __gg__treeplet_1f[cblc_index]; - size_t id3_o = __gg__treeplet_1o[cblc_index]; - size_t id3_s = __gg__treeplet_1s[cblc_index]; + const cblc_field_t *id3 = __gg__treeplet_1f[cblc_index]; + size_t id3_o = __gg__treeplet_1o[cblc_index]; + size_t id3_s = __gg__treeplet_1s[cblc_index]; cblc_index += 1; - cblc_field_t *id4_before = __gg__treeplet_1f[cblc_index]; - size_t id4_before_o = __gg__treeplet_1o[cblc_index]; - size_t id4_before_s = __gg__treeplet_1s[cblc_index]; + const cblc_field_t *id4_before = __gg__treeplet_1f[cblc_index]; + size_t id4_before_o = __gg__treeplet_1o[cblc_index]; + size_t id4_before_s = __gg__treeplet_1s[cblc_index]; cblc_index += 1; - cblc_field_t *id4_after = __gg__treeplet_1f[cblc_index]; - size_t id4_after_o = __gg__treeplet_1o[cblc_index]; - size_t id4_after_s = __gg__treeplet_1s[cblc_index]; + const cblc_field_t *id4_after = __gg__treeplet_1f[cblc_index]; + size_t id4_after_o = __gg__treeplet_1o[cblc_index]; + size_t id4_after_s = __gg__treeplet_1s[cblc_index]; cblc_index += 1; next_comparand.identifier_3 @@ -7356,9 +7395,9 @@ __gg__inspect_format_1(int backward, size_t integers[]) std::vector<id_2_result> id_2_results(n_identifier_2); // Pick up identifier_1, which is the string being inspected - cblc_field_t *id1 = __gg__treeplet_1f[cblc_index]; - size_t id1_o = __gg__treeplet_1o[cblc_index]; - size_t id1_s = __gg__treeplet_1s[cblc_index]; + const cblc_field_t *id1 = __gg__treeplet_1f[cblc_index]; + size_t id1_o = __gg__treeplet_1o[cblc_index]; + size_t id1_s = __gg__treeplet_1s[cblc_index]; cblc_index += 1; // normalize it, according to the language specification. normalized_operand normalized_id_1 @@ -7392,19 +7431,19 @@ __gg__inspect_format_1(int backward, size_t integers[]) // We are counting characters. There is no identifier-3, // but we we hard-code the length to one to represent a // single character. - comparand next_comparand; + comparand next_comparand = {}; next_comparand.id_2_index = i; next_comparand.operation = operation; next_comparand.identifier_3.length = 1; - cblc_field_t *id4_before = __gg__treeplet_1f [cblc_index]; - size_t id4_before_o = __gg__treeplet_1o[cblc_index]; - size_t id4_before_s = __gg__treeplet_1s[cblc_index]; + const cblc_field_t *id4_before = __gg__treeplet_1f [cblc_index]; + size_t id4_before_o = __gg__treeplet_1o[cblc_index]; + size_t id4_before_s = __gg__treeplet_1s[cblc_index]; cblc_index += 1; - cblc_field_t *id4_after = __gg__treeplet_1f [cblc_index]; - size_t id4_after_o = __gg__treeplet_1o[cblc_index]; - size_t id4_after_s = __gg__treeplet_1s[cblc_index]; + const cblc_field_t *id4_after = __gg__treeplet_1f [cblc_index]; + size_t id4_after_o = __gg__treeplet_1o[cblc_index]; + size_t id4_after_s = __gg__treeplet_1s[cblc_index]; cblc_index += 1; normalized_operand normalized_id_4_before @@ -7436,23 +7475,23 @@ __gg__inspect_format_1(int backward, size_t integers[]) for(size_t k=0; k<pair_count; k++) { - comparand next_comparand; + comparand next_comparand = {}; next_comparand.id_2_index = i; next_comparand.operation = operation; - cblc_field_t *id3 = __gg__treeplet_1f[cblc_index]; - size_t id3_o = __gg__treeplet_1o[cblc_index]; - size_t id3_s = __gg__treeplet_1s[cblc_index]; + const cblc_field_t *id3 = __gg__treeplet_1f[cblc_index]; + size_t id3_o = __gg__treeplet_1o[cblc_index]; + size_t id3_s = __gg__treeplet_1s[cblc_index]; cblc_index += 1; - cblc_field_t *id4_before = __gg__treeplet_1f[cblc_index]; - size_t id4_before_o = __gg__treeplet_1o[cblc_index]; - size_t id4_before_s = __gg__treeplet_1s[cblc_index]; + const cblc_field_t *id4_before = __gg__treeplet_1f[cblc_index]; + size_t id4_before_o = __gg__treeplet_1o[cblc_index]; + size_t id4_before_s = __gg__treeplet_1s[cblc_index]; cblc_index += 1; - cblc_field_t *id4_after = __gg__treeplet_1f[cblc_index]; - size_t id4_after_o = __gg__treeplet_1o[cblc_index]; - size_t id4_after_s = __gg__treeplet_1s[cblc_index]; + const cblc_field_t *id4_after = __gg__treeplet_1f[cblc_index]; + size_t id4_after_o = __gg__treeplet_1o[cblc_index]; + size_t id4_after_s = __gg__treeplet_1s[cblc_index]; cblc_index += 1; next_comparand.identifier_3 @@ -7681,7 +7720,7 @@ __gg__inspect_format_1(int backward, size_t integers[]) static void -inspect_backward_format_2(size_t integers[]) +inspect_backward_format_2(const size_t integers[]) { size_t int_index = 0; size_t cblc_index = 0; @@ -7711,22 +7750,22 @@ inspect_backward_format_2(size_t integers[]) { case bound_characters_e: { - comparand next_comparand; + comparand next_comparand = {}; next_comparand.operation = operation; - cblc_field_t *id5 = __gg__treeplet_1f[cblc_index]; - size_t id5_o = __gg__treeplet_1o[cblc_index]; - size_t id5_s = __gg__treeplet_1s[cblc_index]; + const cblc_field_t *id5 = __gg__treeplet_1f[cblc_index]; + size_t id5_o = __gg__treeplet_1o[cblc_index]; + size_t id5_s = __gg__treeplet_1s[cblc_index]; cblc_index += 1; - cblc_field_t *id4_before = __gg__treeplet_1f[cblc_index]; - size_t id4_before_o = __gg__treeplet_1o[cblc_index]; - size_t id4_before_s = __gg__treeplet_1s[cblc_index]; + const cblc_field_t *id4_before = __gg__treeplet_1f[cblc_index]; + size_t id4_before_o = __gg__treeplet_1o[cblc_index]; + size_t id4_before_s = __gg__treeplet_1s[cblc_index]; cblc_index += 1; - cblc_field_t *id4_after = __gg__treeplet_1f [cblc_index]; - size_t id4_after_o = __gg__treeplet_1o[cblc_index]; - size_t id4_after_s = __gg__treeplet_1s[cblc_index]; + const cblc_field_t *id4_after = __gg__treeplet_1f [cblc_index]; + size_t id4_after_o = __gg__treeplet_1o[cblc_index]; + size_t id4_after_s = __gg__treeplet_1s[cblc_index]; cblc_index += 1; next_comparand.identifier_5 @@ -7762,27 +7801,27 @@ inspect_backward_format_2(size_t integers[]) for(size_t k=0; k<pair_count; k++) { - comparand next_comparand; + comparand next_comparand = {}; next_comparand.operation = operation; - cblc_field_t *id3 = __gg__treeplet_1f[cblc_index]; - size_t id3_o = __gg__treeplet_1o[cblc_index]; - size_t id3_s = __gg__treeplet_1s[cblc_index]; + const cblc_field_t *id3 = __gg__treeplet_1f[cblc_index]; + size_t id3_o = __gg__treeplet_1o[cblc_index]; + size_t id3_s = __gg__treeplet_1s[cblc_index]; cblc_index += 1; - cblc_field_t *id5 = __gg__treeplet_1f[cblc_index]; - size_t id5_o = __gg__treeplet_1o[cblc_index]; - size_t id5_s = __gg__treeplet_1s[cblc_index]; + const cblc_field_t *id5 = __gg__treeplet_1f[cblc_index]; + size_t id5_o = __gg__treeplet_1o[cblc_index]; + size_t id5_s = __gg__treeplet_1s[cblc_index]; cblc_index += 1; - cblc_field_t *id4_before = __gg__treeplet_1f[cblc_index]; - size_t id4_before_o = __gg__treeplet_1o[cblc_index]; - size_t id4_before_s = __gg__treeplet_1s[cblc_index]; + const cblc_field_t *id4_before = __gg__treeplet_1f[cblc_index]; + size_t id4_before_o = __gg__treeplet_1o[cblc_index]; + size_t id4_before_s = __gg__treeplet_1s[cblc_index]; cblc_index += 1; - cblc_field_t *id4_after = __gg__treeplet_1f[cblc_index]; - size_t id4_after_o = __gg__treeplet_1o[cblc_index]; - size_t id4_after_s = __gg__treeplet_1s[cblc_index]; + const cblc_field_t *id4_after = __gg__treeplet_1f[cblc_index]; + size_t id4_after_o = __gg__treeplet_1o[cblc_index]; + size_t id4_after_s = __gg__treeplet_1s[cblc_index]; cblc_index += 1; next_comparand.identifier_3 = normalize_id(id3, id3_o, id3_s); @@ -8059,22 +8098,22 @@ __gg__inspect_format_2(int backward, size_t integers[]) { case bound_characters_e: { - comparand next_comparand; + comparand next_comparand = {} ; next_comparand.operation = operation; - cblc_field_t *id5 = __gg__treeplet_1f[cblc_index]; - size_t id5_o = __gg__treeplet_1o[cblc_index]; - size_t id5_s = __gg__treeplet_1s[cblc_index]; + const cblc_field_t *id5 = __gg__treeplet_1f[cblc_index]; + size_t id5_o = __gg__treeplet_1o[cblc_index]; + size_t id5_s = __gg__treeplet_1s[cblc_index]; cblc_index += 1; - cblc_field_t *id4_before = __gg__treeplet_1f[cblc_index]; - size_t id4_before_o = __gg__treeplet_1o[cblc_index]; - size_t id4_before_s = __gg__treeplet_1s[cblc_index]; + const cblc_field_t *id4_before = __gg__treeplet_1f[cblc_index]; + size_t id4_before_o = __gg__treeplet_1o[cblc_index]; + size_t id4_before_s = __gg__treeplet_1s[cblc_index]; cblc_index += 1; - cblc_field_t *id4_after = __gg__treeplet_1f [cblc_index]; - size_t id4_after_o = __gg__treeplet_1o[cblc_index]; - size_t id4_after_s = __gg__treeplet_1s[cblc_index]; + const cblc_field_t *id4_after = __gg__treeplet_1f [cblc_index]; + size_t id4_after_o = __gg__treeplet_1o[cblc_index]; + size_t id4_after_s = __gg__treeplet_1s[cblc_index]; cblc_index += 1; next_comparand.identifier_5 @@ -8110,27 +8149,27 @@ __gg__inspect_format_2(int backward, size_t integers[]) for(size_t k=0; k<pair_count; k++) { - comparand next_comparand; + comparand next_comparand = {}; next_comparand.operation = operation; - cblc_field_t *id3 = __gg__treeplet_1f[cblc_index]; - size_t id3_o = __gg__treeplet_1o[cblc_index]; - size_t id3_s = __gg__treeplet_1s[cblc_index]; + const cblc_field_t *id3 = __gg__treeplet_1f[cblc_index]; + size_t id3_o = __gg__treeplet_1o[cblc_index]; + size_t id3_s = __gg__treeplet_1s[cblc_index]; cblc_index += 1; - cblc_field_t *id5 = __gg__treeplet_1f[cblc_index]; - size_t id5_o = __gg__treeplet_1o[cblc_index]; - size_t id5_s = __gg__treeplet_1s[cblc_index]; + const cblc_field_t *id5 = __gg__treeplet_1f[cblc_index]; + size_t id5_o = __gg__treeplet_1o[cblc_index]; + size_t id5_s = __gg__treeplet_1s[cblc_index]; cblc_index += 1; - cblc_field_t *id4_before = __gg__treeplet_1f[cblc_index]; - size_t id4_before_o = __gg__treeplet_1o[cblc_index]; - size_t id4_before_s = __gg__treeplet_1s[cblc_index]; + const cblc_field_t *id4_before = __gg__treeplet_1f[cblc_index]; + size_t id4_before_o = __gg__treeplet_1o[cblc_index]; + size_t id4_before_s = __gg__treeplet_1s[cblc_index]; cblc_index += 1; - cblc_field_t *id4_after = __gg__treeplet_1f[cblc_index]; - size_t id4_after_o = __gg__treeplet_1o[cblc_index]; - size_t id4_after_s = __gg__treeplet_1s[cblc_index]; + const cblc_field_t *id4_after = __gg__treeplet_1f[cblc_index]; + size_t id4_after_o = __gg__treeplet_1o[cblc_index]; + size_t id4_after_s = __gg__treeplet_1s[cblc_index]; cblc_index += 1; next_comparand.identifier_3 = normalize_id(id3, id3_o, id3_s); @@ -8405,12 +8444,12 @@ __gg__inspect_format_4( int backward, static size_t psz_before_size = MINIMUM_ALLOCATION_SIZE; static size_t psz_figstring_size = MINIMUM_ALLOCATION_SIZE; - static char *psz_input = (char *)malloc(psz_input_size ); - static char *psz_original = (char *)malloc(psz_original_size ); - static char *psz_replacement = (char *)malloc(psz_replacement_size); - static char *psz_after = (char *)malloc(psz_after_size ); - static char *psz_before = (char *)malloc(psz_before_size ); - static char *psz_figstring = (char *)malloc(psz_figstring_size ); + static char *psz_input = static_cast<char *>(malloc(psz_input_size )); + static char *psz_original = static_cast<char *>(malloc(psz_original_size )); + static char *psz_replacement = static_cast<char *>(malloc(psz_replacement_size)); + static char *psz_after = static_cast<char *>(malloc(psz_after_size )); + static char *psz_before = static_cast<char *>(malloc(psz_before_size )); + static char *psz_figstring = static_cast<char *>(malloc(psz_figstring_size )); bool all = replacement_size == (size_t)(-1LL); if( all ) @@ -8504,7 +8543,7 @@ __gg__inspect_format_4( int backward, } char *pstart = NULL; - char *pend = NULL; + const char *pend = NULL; if( backward ) { if( strlen(psz_before) ) @@ -8597,7 +8636,7 @@ move_string(cblc_field_t *field, case FldAlphanumeric: case FldAlphaEdited: { - char *to = (char *)(field->data + offset); + char *to = reinterpret_cast<char *>(field->data + offset); size_t dest_length = length ? length : field->capacity; size_t source_length = strlen_from; size_t count = std::min(dest_length, source_length); @@ -8706,7 +8745,7 @@ brute_force_trim(char *str) extern "C" int -__gg__string(size_t integers[]) +__gg__string(const size_t integers[]) { // The first integer is the count of identifier-2 values. Call it N // The following N integers are the counts of each of the identifier-1 values, @@ -8720,12 +8759,11 @@ __gg__string(size_t integers[]) // And so on cblc_field_t **ref = __gg__treeplet_1f; - size_t *ref_o = __gg__treeplet_1o; - size_t *ref_s = __gg__treeplet_1s; + const size_t *ref_o = __gg__treeplet_1o; + const size_t *ref_s = __gg__treeplet_1s; static const int INDEX_OF_POINTER = 1; - size_t index_int = 0; size_t index_cblc = 0 ; char figlow[2] = {ascii_to_internal(__gg__low_value_character), 0x00}; @@ -8743,15 +8781,13 @@ __gg__string(size_t integers[]) fighigh[0] = ascii_to_internal(__gg__high_value_character); } - // Pick up the number of identifier-2 values - size_t N = integers[index_int++]; // Pick up the target - cblc_field_t *tgt = ref[index_cblc]; - size_t tgt_o = ref_o[index_cblc]; - size_t tgt_s = ref_s[index_cblc]; + const cblc_field_t *tgt = ref[index_cblc]; + size_t tgt_o = ref_o[index_cblc]; + size_t tgt_s = ref_s[index_cblc]; index_cblc += 1; - char *dest = (char *)(tgt->data + tgt_o); + char *dest = reinterpret_cast<char *>(tgt->data + tgt_o); ssize_t dest_length = tgt_s; // Skip over the index of POINTER: @@ -8778,18 +8814,23 @@ __gg__string(size_t integers[]) { // We are go for looping through identifier-2 values: + size_t index_int = 0; + + // Pick up the number of identifier-2 values + size_t N = integers[index_int++]; + for( size_t i=0; i<N; i++ ) { size_t M = integers[index_int++]; // Pick up the identifier_2 DELIMITED BY value - cblc_field_t *id2 = ref[index_cblc]; - size_t id2_o = ref_o[index_cblc]; - size_t id2_s = ref_s[index_cblc]; + const cblc_field_t *id2 = ref[index_cblc]; + size_t id2_o = ref_o[index_cblc]; + size_t id2_s = ref_s[index_cblc]; index_cblc += 1; char *piece; - char *piece_end; + const char *piece_end; cbl_figconst_t figconst = (cbl_figconst_t) ( id2 ? (id2->attr & FIGCONST_MASK) : 0 ); @@ -8816,24 +8857,24 @@ __gg__string(size_t integers[]) piece_end = piece + 1; break; default: - piece = id2 ? (char *)(id2->data + id2_o) : NULL; + piece = id2 ? reinterpret_cast<char *>(id2->data + id2_o) : NULL; piece_end = id2 ? piece + id2_s : NULL; break; } - for(size_t i=0; i<M; i++) + for(size_t j=0; j<M; j++) { // Pick up the next identifier-1 source string: - cblc_field_t *id1 = ref[index_cblc]; + const cblc_field_t *id1 = ref[index_cblc]; size_t id1_o = ref_o[index_cblc]; size_t id1_s = ref_s[index_cblc]; index_cblc += 1; - const char *whole = id1 ? (const char *)(id1->data + id1_o): NULL ; + const char *whole = id1 ? reinterpret_cast<char *>(id1->data + id1_o): NULL ; const char *whole_end = id1 ? whole + id1_s : NULL; // As usual, we need to cope with figurative constants: - cbl_figconst_t figconst = (cbl_figconst_t) ( id1 ? (id1->attr & FIGCONST_MASK) : 0 ); + figconst = (cbl_figconst_t) ( id1 ? (id1->attr & FIGCONST_MASK) : 0 ); switch( figconst ) { case low_value_e: @@ -8866,11 +8907,7 @@ __gg__string(size_t integers[]) whole, whole_end); if(found) { -#pragma GCC diagnostic push -#pragma GCC diagnostic ignored "-Wcast-qual" - char *wfound = (char *)found; -#pragma GCC diagnostic pop - whole_end = wfound; + whole_end = found; } } while(whole < whole_end) @@ -8920,7 +8957,7 @@ display_both(cblc_field_t *field, int advance ) { static size_t display_string_size = MINIMUM_ALLOCATION_SIZE; - static char *display_string = (char *)malloc(display_string_size); + static char *display_string = static_cast<char *>(malloc(display_string_size)); format_for_display_internal(&display_string, &display_string_size, @@ -8931,7 +8968,7 @@ display_both(cblc_field_t *field, // Let's honor the locale of the system, as best we can: static size_t converted_size = MINIMUM_ALLOCATION_SIZE; - static char *converted = (char *)malloc(converted_size); + static char *converted = static_cast<char *>(malloc(converted_size)); internal_to_console(&converted, &converted_size, display_string, strlen(display_string)); @@ -8941,7 +8978,7 @@ display_both(cblc_field_t *field, if(ss == -1) { fprintf(stderr, "__gg__display() %s %p\n", field->name, qual_data); - fprintf(stderr, "__gg__display() %zd\n", converted_size); + fprintf(stderr, "__gg__display() %ld\n", static_cast<long>(converted_size)); fprintf(stderr, "__gg__display() "); for(size_t i=0; i<converted_size; i++) { @@ -8953,9 +8990,9 @@ display_both(cblc_field_t *field, if( advance ) { - ss = write( file_descriptor, - "\n", - 1); + write( file_descriptor, + "\n", + 1); } } @@ -8994,20 +9031,20 @@ __gg__display_clean(cblc_field_t *field, extern "C" void -__gg__display_string( int file_descriptor, - char *str, - size_t length, - int advance ) +__gg__display_string( int file_descriptor, + const char *str, + size_t length, + int advance ) { // Let's honor the locale of the system, as best we can: static size_t converted_size = MINIMUM_ALLOCATION_SIZE; - static char *converted = (char *)malloc(converted_size); + static char *converted = static_cast<char *>(malloc(converted_size)); size_t max_possible = 2 * length; if( max_possible > converted_size ) { converted_size = max_possible; - converted = (char *)realloc(converted, converted_size); + converted = static_cast<char *>(realloc(converted, converted_size)); } __gg__ascii_to_console(&converted, &converted_size, str, length); @@ -9143,7 +9180,8 @@ __gg__accept( enum special_name_t special_e, } } - char *buffer = (char *)malloc(max_chars+1); + char *buffer = static_cast<char *>(malloc(max_chars+1)); + massert(buffer); memset(buffer, ascii_space, max_chars); buffer[max_chars] = NULLCH; size_t i = 0; @@ -9309,7 +9347,7 @@ __gg__binary_value_from_field( int *rdigits, extern "C" __int128 __gg__binary_value_from_qualified_field(int *rdigits, - cblc_field_t *var, + const cblc_field_t *var, size_t offset, size_t size) { @@ -9342,7 +9380,7 @@ __gg__float128_from_field( cblc_field_t *field ) extern "C" GCOB_FP128 -__gg__float128_from_qualified_field( cblc_field_t *field, size_t offset, size_t size) +__gg__float128_from_qualified_field(const cblc_field_t *field, size_t offset, size_t size) { GCOB_FP128 retval=0; if( field->type == FldFloat || field->type == FldLiteralN ) @@ -9419,11 +9457,11 @@ __gg__int128_to_qualified_field(cblc_field_t *tgt, } static __int128 -float128_to_int128( int *rdigits, - cblc_field_t *field, - GCOB_FP128 value, - cbl_round_t rounded, - int *compute_error) +float128_to_int128( int *rdigits, + const cblc_field_t *field, + GCOB_FP128 value, + cbl_round_t rounded, + int *compute_error) { __int128 retval = 0; if( value == INFINITY ) @@ -9505,16 +9543,16 @@ float128_to_location( cblc_field_t *tgt, } if( value < 0 ) { - *(float *)(data) = -INFINITY; + *PTRCAST(float, data) = -INFINITY; } else { - *(float *)(data) = INFINITY; + *PTRCAST(float, data) = INFINITY; } } else { - *(float *)(data) = (float)value; + *PTRCAST(float, data) = static_cast<float>(value); } break; @@ -9528,16 +9566,16 @@ float128_to_location( cblc_field_t *tgt, } if( value < 0 ) { - *(double *)(data) = -INFINITY; + *PTRCAST(double, data) = -INFINITY; } else { - *(double *)(data) = INFINITY; + *PTRCAST(double, data) = INFINITY; } } else { - *(double *)(data) = (double)value; + *PTRCAST(double, data) = static_cast<double>(value); } break; @@ -9738,7 +9776,7 @@ __gg__set_initial_switch_value( ) __int128 bit = 1; char ach[129]; memset(ach, 0, sizeof(ach)); - char *p = getenv("UPSI"); + const char *p = getenv("UPSI"); if( p ) { snprintf(ach, sizeof(ach), "%s", p); @@ -9771,7 +9809,7 @@ is_numeric_display_numeric(cblc_field_t *field, size_t offset, size_t size) bool leading = !!(field->attr & leading_e); bool separate = !!(field->attr & separate_e); - char *digits = (char *)(field->data + offset); + char *digits = reinterpret_cast<char *>(field->data + offset); char *digits_e = digits + size; if( leading && separate && signable ) @@ -9843,13 +9881,13 @@ is_numeric_display_numeric(cblc_field_t *field, size_t offset, size_t size) } static int -is_packed_numeric(cblc_field_t *field, size_t offset, size_t size) +is_packed_numeric(const cblc_field_t *field, size_t offset, size_t size) { int retval = 1; bool is_comp6 = !!(field->attr&packed_no_sign_e); int digits = field->digits; bool signable = !!(field->attr & signable_e); - unsigned char *bytes = field->data + offset; + const unsigned char *bytes = field->data + offset; int nybble = 0; int nybble_e = nybble + digits; @@ -9918,10 +9956,12 @@ is_packed_numeric(cblc_field_t *field, size_t offset, size_t size) } static int -is_alpha_a_number(cblc_field_t *field, size_t offset, size_t size) +is_alpha_a_number(const cblc_field_t *field, + size_t offset, + size_t size) { int retval = 1; - unsigned char *bytes = (field->data + offset); + const unsigned char *bytes = (field->data + offset); for( size_t i=0; i<size; i++ ) { unsigned char ch = bytes[i]; @@ -9945,7 +9985,7 @@ __gg__classify( classify_t type, // The default answer is TRUE int retval = 1; - const unsigned char *alpha = (unsigned char *)(field->data+offset); + const unsigned char *alpha = reinterpret_cast<unsigned char *>(field->data+offset); size_t str_length = size; @@ -10095,7 +10135,7 @@ __gg__accept_envar( cblc_field_t *tgt, if( env_length < name_length+1 ) { env_length = name_length+1; - env = (char *)realloc(env, env_length); + env = static_cast<char *>(realloc(env, env_length)); } memcpy(env, name->data + name_offset, name_length); env[name_length] = '\0'; @@ -10107,7 +10147,7 @@ __gg__accept_envar( cblc_field_t *tgt, __gg__internal_to_console_in_place(trimmed_env, strlen(trimmed_env)); // Pick up the environment variable, and convert it to the internal codeset - char *p = getenv(trimmed_env); + const char *p = getenv(trimmed_env); if(p) { char *pp = strdup(p); @@ -10146,14 +10186,17 @@ __gg__set_envar(cblc_field_t *name, if( env_length < name_length+1 ) { env_length = name_length+1; - env = (char *)realloc(env, env_length); + env = static_cast<char *>(realloc(env, env_length)); } if( val_length < value_length+1 ) { val_length = value_length+1; - val = (char *)realloc(val, val_length); + val = static_cast<char *>(realloc(val, val_length)); } + massert(val); + massert(env); + // The name and the value arrive in the internal codeset: memcpy(env, name->data+name_offset , name_length); env[name_length] = '\0'; @@ -10222,15 +10265,15 @@ command_line_plan_b() if( bytes_read ) { char *p = input; - char *p_end = p + bytes_read; + const char *p_end = p + bytes_read; char prior_char = '\0'; while( p < p_end ) { if( prior_char == '\0' ) { stashed_argc += 1; - stashed_argv = (char **)realloc(stashed_argv, - stashed_argc * sizeof(char *)); + stashed_argv = static_cast<char **>(realloc(stashed_argv, + stashed_argc * sizeof(char *))); stashed_argv[stashed_argc-1] = p; } prior_char = *p++; @@ -10301,7 +10344,8 @@ __gg__get_command_line( cblc_field_t *field, int retcode; command_line_plan_b(); size_t length = 1; - char *retval = (char *)malloc(length); + char *retval = static_cast<char *>(malloc(length)); + massert(retval); *retval = NULLCH; for( int i=1; i<stashed_argc; i++ ) @@ -10309,7 +10353,8 @@ __gg__get_command_line( cblc_field_t *field, while( strlen(retval) + strlen(stashed_argv[i]) + 2 > length ) { length *= 2; - retval = (char *)realloc(retval, length); + retval = static_cast<char *>(realloc(retval, length)); + massert(retval); } if( *retval ) { @@ -10337,12 +10382,12 @@ __gg__get_command_line( cblc_field_t *field, extern "C" void -__gg__set_pointer(cblc_field_t *target, - size_t target_o, - int target_flags, - cblc_field_t *source, - size_t source_o, - int source_flags) +__gg__set_pointer(cblc_field_t *target, + size_t target_o, + int target_flags, + const cblc_field_t *source, + size_t source_o, + int source_flags) { void *source_address; if( source_flags & REFER_T_ADDRESS_OF ) @@ -10355,7 +10400,7 @@ __gg__set_pointer(cblc_field_t *target, // This is SET <something> TO POINTER if( source ) { - source_address = *(void **)(source->data + source_o); + source_address = *reinterpret_cast<void **>(source->data + source_o); } else { @@ -10368,7 +10413,7 @@ __gg__set_pointer(cblc_field_t *target, { // This is SET ADDRESS OF target TO .... // We know it has to be an unqualified LINKAGE level 01 or level 77 - target->data = (unsigned char *)source_address; + target->data = reinterpret_cast<unsigned char *>(source_address); // The caller will propogate data + offset to their children. } else @@ -10379,12 +10424,12 @@ __gg__set_pointer(cblc_field_t *target, // This is [almost certainly] INITIALIZE <pointer> when -fdefaultbyte // was specified. memset( target->data+target_o, - *(unsigned char *)source_address, + *reinterpret_cast<unsigned char *>(source_address), target->capacity); } else { - *(void **)(target->data+target_o) = source_address; + *reinterpret_cast<void **>(target->data+target_o) = source_address; } } } @@ -10467,7 +10512,7 @@ extern "C" void __gg__ascii_to_internal_field(cblc_field_t *var) { - ascii_to_internal_str((char *)var->data, var->capacity); + ascii_to_internal_str(reinterpret_cast<char *>(var->data), var->capacity); } extern "C" @@ -10519,7 +10564,7 @@ void __gg__internal_to_console_in_place(char *loc, size_t length) { static size_t dest_size = MINIMUM_ALLOCATION_SIZE; - static char *dest = (char *)malloc(dest_size); + static char *dest = static_cast<char *>(malloc(dest_size)); internal_to_console(&dest, &dest_size, loc, length); memcpy(loc, dest, length); @@ -10527,8 +10572,8 @@ __gg__internal_to_console_in_place(char *loc, size_t length) extern "C" int -__gg__routine_to_call(char *name, - int program_id) +__gg__routine_to_call(const char *name, + int program_id) { // The list of names is sorted, so at the very least this should be replaced // with a binary search: @@ -10544,10 +10589,10 @@ __gg__routine_to_call(char *name, char **names = *(it->second); int retval = -1; - int i=0; if( names ) { + int i=0; while(*names) { if( strstr(*names, name) ) @@ -10569,14 +10614,14 @@ __gg__routine_to_call(char *name, extern "C" __int128 -__gg__fetch_call_by_value_value(cblc_field_t *field, +__gg__fetch_call_by_value_value(const cblc_field_t *field, size_t field_o, size_t field_s) { int rdigits; - unsigned char *data = field->data + field_o; - size_t length = field_s; + unsigned char *data = field->data + field_o; + const size_t length = field_s; __int128 retval = 0; switch(field->type) @@ -10585,7 +10630,7 @@ __gg__fetch_call_by_value_value(cblc_field_t *field, case FldAlphanumeric: case FldAlphaEdited: case FldLiteralA: - retval = *(char *)data; + retval = *reinterpret_cast<char *>(data); break; case FldFloat: @@ -10593,11 +10638,11 @@ __gg__fetch_call_by_value_value(cblc_field_t *field, switch(length) { case 4: - *(float *)(&retval) = *(float *)data; + *PTRCAST(float, &retval) = *PTRCAST(float, data); break; case 8: - *(double *)(&retval) = *(double *)data; + *PTRCAST(double, &retval) = *PTRCAST(double, data); break; case 16: @@ -10654,11 +10699,11 @@ __gg__assign_value_from_stack(cblc_field_t *dest, __int128 parameter) switch(dest->capacity) { case 4: - *(float *)(dest->data) = *(float *)¶meter; + *PTRCAST(float, dest->data) = *PTRCAST(float, (¶meter)); break; case 8: - *(double *)(dest->data) = *(double *)¶meter; + *PTRCAST(double, dest->data) = *PTRCAST(double, (¶meter)); break; case 16: @@ -10692,28 +10737,31 @@ __gg__assign_value_from_stack(cblc_field_t *dest, __int128 parameter) extern "C" int -__gg__literaln_alpha_compare(char *left_side, - cblc_field_t *right, - size_t offset, - size_t length, - int flags) +__gg__literaln_alpha_compare(const char *left_side, + const cblc_field_t *right, + size_t offset, + size_t length, + int flags) { int retval; if( length == 0 ) { length = right->capacity; } - retval = compare_strings( (char *)left_side, + retval = compare_strings( left_side, strlen(left_side), false, - (char *)right->data + offset, + reinterpret_cast<char *>((right->data + offset)), length, !!(flags & REFER_T_MOVE_ALL) ); return retval; } static char * -string_in(char *str, char *str_e, char *frag, char *frag_e) +string_in( char *str, + const char *str_e, + const char *frag, + const char *frag_e) { // This simple routine could be improved. Instead of using memcmp, we could // use established, albeit complex, techniques of string searching: @@ -10743,11 +10791,11 @@ string_in(char *str, char *str_e, char *frag, char *frag_e) extern "C" int -__gg__unstring( cblc_field_t *id1, // The string being unstring - size_t id1_o, - size_t id1_s, +__gg__unstring( const cblc_field_t *id1, // The string being unstring + size_t id1_o, + size_t id1_s, size_t ndelimiteds, // The number of DELIMITED entries - char *all_flags, // The number of ALL flags, one per ndelimiteds + const char *all_flags, // The number of ALL flags, one per ndelimiteds size_t nreceivers, // The number of DELIMITER receivers cblc_field_t *id7, // The index of characters, both for starting updated at end size_t id7_o, @@ -10766,18 +10814,22 @@ __gg__unstring( cblc_field_t *id1, // The string being unstring // resolved. Each might have an identifier-5 delimiter, and each might have // an identifier-6 count. - cblc_field_t **id2 = __gg__treeplet_1f; // The delimiting strings; one per ndelimiteds - size_t *id2_o = __gg__treeplet_1o; - size_t *id2_s = __gg__treeplet_1s; - cblc_field_t **id4 = __gg__treeplet_2f; // The delimited string; one per nreceiver - size_t *id4_o = __gg__treeplet_2o; - size_t *id4_s = __gg__treeplet_2s; - cblc_field_t **id5 = __gg__treeplet_3f; // The delimiting string; one per receiver - size_t *id5_o = __gg__treeplet_3o; - size_t *id5_s = __gg__treeplet_3s; - cblc_field_t **id6 = __gg__treeplet_4f; // The count of characters examined; one per receiver - size_t *id6_o = __gg__treeplet_4o; - size_t *id6_s = __gg__treeplet_4s; + // The delimiting strings; one per ndelimiteds + cblc_field_t **id2 = __gg__treeplet_1f; + const size_t *id2_o = __gg__treeplet_1o; + const size_t *id2_s = __gg__treeplet_1s; + // The delimited string; one per nreceiver + cblc_field_t **id4 = __gg__treeplet_2f; + const size_t *id4_o = __gg__treeplet_2o; + const size_t *id4_s = __gg__treeplet_2s; + // The delimiting string; one per receiver + cblc_field_t **id5 = __gg__treeplet_3f; + const size_t *id5_o = __gg__treeplet_3o; + const size_t *id5_s = __gg__treeplet_3s; + // The count of characters examined; one per receiver + cblc_field_t **id6 = __gg__treeplet_4f; + const size_t *id6_o = __gg__treeplet_4o; + const size_t *id6_s = __gg__treeplet_4s; // Initialize the state variables int overflow = 0; @@ -10820,8 +10872,8 @@ __gg__unstring( cblc_field_t *id1, // The string being unstring goto done; } - left = (char *)(id1->data+id1_o) + pointer-1; - right = (char *)(id1->data+id1_o) + id1_s; + left = reinterpret_cast<char *>(id1->data+id1_o) + pointer-1; + right = reinterpret_cast<char *>(id1->data+id1_o) + id1_s; if( ndelimiteds == 0 ) { @@ -10919,8 +10971,9 @@ __gg__unstring( cblc_field_t *id1, // The string being unstring default: pfound = string_in( left, right, - (char *)(id2[i]->data+id2_o[i]), - (char *)(id2[i]->data+id2_o[i]) + id2_s[i]); + reinterpret_cast<char *>(id2[i]->data+id2_o[i]), + reinterpret_cast<char *>((id2[i]->data+id2_o[i]) + + id2_s[i])); break; } @@ -10997,7 +11050,7 @@ __gg__unstring( cblc_field_t *id1, // The string being unstring else { move_string(id5[nreceiver], id5_o[nreceiver], id5_s[nreceiver], - (char *)(id2[ifound]->data+id2_o[ifound]), + reinterpret_cast<char *>(id2[ifound]->data+id2_o[ifound]), id2_s[ifound]); } } @@ -11092,15 +11145,15 @@ static inline ec_type_t local_ec_type_of( file_status_t status ) { int status10 = (int)status / 10; - assert( 0 <= status10 ); // was enum, can't be negative. - if( 10 < status10 ) + assert( 0 <= status10 ); // was enum, can't be negative. + if( 10 < status10 ) { __gg__abort("local_ec_type_of(): status10 out of range"); } - + static const std::vector<ec_type_t> ec_by_status { /* 0 */ ec_none_e, // ec_io_warning_e if low byte is nonzero - /* 1 */ ec_io_at_end_e, + /* 1 */ ec_io_at_end_e, /* 2 */ ec_io_invalid_key_e, /* 3 */ ec_io_permanent_error_e, /* 4 */ ec_io_logic_error_e, @@ -11122,11 +11175,12 @@ local_ec_type_of( file_status_t status ) */ struct exception_descr_t { bool location; - std::set<size_t> files; + //std::set<size_t> files; }; struct cbl_exception_t { - size_t program, file; +// size_t program, + size_t file; ec_type_t type; cbl_file_mode_t mode; }; @@ -11188,16 +11242,16 @@ default_exception_handler( ec_type_t ec ) { #if HAVE_DECL_PROGRAM_INVOCATION_SHORT_NAME /* Declared in errno.h, when available. */ - const char *ident = program_invocation_short_name; + static const char * const ident = program_invocation_short_name; #elif defined (HAVE_GETPROGNAME) /* Declared in stdlib.h. */ - const char *ident = getprogname(); + static const char * const ident = getprogname(); #else /* Avoid a NULL entry. */ - const char *ident = "unnamed_COBOL_program"; + static const char * const ident = "unnamed_COBOL_program"; #endif static bool first_time = true; - static int priority = LOG_INFO, option = LOG_PERROR, facility = LOG_USER; + static const int priority = LOG_INFO, option = LOG_PERROR, facility = LOG_USER; ec_disposition_t disposition = ec_category_fatal_e; if( first_time ) { @@ -11450,7 +11504,7 @@ cbl_enabled_exception_t::dump( int i ) const { * specific EC. It's matched based on the file's status, irrespective of * whether or not EC-I-O is enabled. USE Format 1 Declaratives are honored * regardless of any >>TURN directive. - * + * * An EC is enabled by the >>TURN directive. The only ECs that can be disabled * are those that were explicitly enabled. If EC-I-O is enabled, and mentioned * in a Declarative with USE Format 3, then it is matched just like any other. @@ -11465,19 +11519,19 @@ __gg__match_exception( cblc_field_t *index ) auto ec = ec_status.update().unhandled(); - if( ec != ec_none_e ) { + if( ec != ec_none_e ) { /* - * An EC was raised and was not handled by the statement. - * We know the EC and, for I/O, the current file and its mode. - * Scan declaratives for a match: + * An EC was raised and was not handled by the statement. + * We know the EC and, for I/O, the current file and its mode. + * Scan declaratives for a match: * - EC is enabled or program has a Format 1 Declarative * - EC matches the Declarative's USE statement - * Format 1 declaratives apply only to EC-I-O, whether or not enabled. + * Format 1 declaratives apply only to EC-I-O, whether or not enabled. * Format 1 may be restricted to a particular mode (for all files). - * Format 1 and 3 may be restricted to a set of files. + * Format 1 and 3 may be restricted to a set of files. */ auto f = ec_status.file_status(); - cbl_exception_t raised = { 0, f.ifile, ec, f.mode }; + cbl_exception_t raised = { /*0,*/ f.ifile, ec, f.mode }; bool enabled = enabled_ECs.match(ec); if( MATCH_DECLARATIVE ) enabled_ECs.dump("match_exception enabled"); @@ -11506,8 +11560,8 @@ __gg__match_exception( cblc_field_t *index ) p->section); } } - assert(ec != ec_none_e); - } // end EC match logic + assert(ec != ec_none_e); + } // end EC match logic // If a declarative matches the raised exception, return its // symbol_table index. @@ -11581,20 +11635,23 @@ __gg__pseudo_return_flush() extern "C" GCOB_FP128 -__gg__float128_from_location(cblc_field_t *var, unsigned char *location) +__gg__float128_from_location( const cblc_field_t *var, + const unsigned char *location) { GCOB_FP128 retval = 0; switch( var->capacity ) { case 4: { - retval = *(_Float32 *)location; + retval = *reinterpret_cast<_Float32 *>( + const_cast<unsigned char *>(location)); break; } case 8: { - retval = *(_Float64 *)location; + retval = *reinterpret_cast<_Float64 *>( + const_cast<unsigned char *>(location)); break; } @@ -11610,7 +11667,7 @@ __gg__float128_from_location(cblc_field_t *var, unsigned char *location) extern "C" __int128 -__gg__integer_from_float128(cblc_field_t *field) +__gg__integer_from_float128(const cblc_field_t *field) { GCOB_FP128 fvalue = __gg__float128_from_location(field, field->data); // we round() to take care of the possible 2.99999999999... problem. @@ -11729,7 +11786,7 @@ __gg__func_exception_status(cblc_field_t *dest) extern "C" void -__gg__set_exception_file(cblc_file_t *file) +__gg__set_exception_file(const cblc_file_t *file) { ec_type_t ec = local_ec_type_of( file->io_status ); if( ec ) @@ -11748,7 +11805,8 @@ __gg__set_exception_file(cblc_file_t *file) extern "C" void -__gg__func_exception_file(cblc_field_t *dest, cblc_file_t *file) +__gg__func_exception_file(cblc_field_t *dest, + const cblc_file_t *file) { char ach[128]; if( !file ) @@ -11833,7 +11891,7 @@ __gg__set_exception_code(ec_type_t ec, int from_raise_statement) last_exception_statement = __gg__exception_statement ; // These are set in __gg__set_exception_file just before this routine is - // called. In cases where the ec is not a file-i-o operation, we clear + // called. In cases where the ec is not a file-i-o operation, we clear // them here: if( !(ec & ec_io_e) ) { @@ -11932,16 +11990,16 @@ __gg__float128_from_int128(cblc_field_t *destination, extern "C" int -__gg__is_float_infinite(cblc_field_t *source, size_t offset) +__gg__is_float_infinite(const cblc_field_t *source, size_t offset) { int retval = 0; switch(source->capacity) { case 4: - retval = fpclassify( *(_Float32*)(source->data+offset)) == FP_INFINITE; + retval = fpclassify( *reinterpret_cast<_Float32*>(source->data+offset)) == FP_INFINITE; break; case 8: - retval = fpclassify( *(_Float64*)(source->data+offset)) == FP_INFINITE; + retval = fpclassify( *reinterpret_cast<_Float64*>(source->data+offset)) == FP_INFINITE; break; case 16: // retval = *(_Float128*)(source->data+offset) == INFINITY; @@ -11955,10 +12013,10 @@ __gg__is_float_infinite(cblc_field_t *source, size_t offset) extern "C" int -__gg__float32_from_128( cblc_field_t *dest, - size_t dest_offset, - cblc_field_t *source, - size_t source_offset) +__gg__float32_from_128( const cblc_field_t *dest, + size_t dest_offset, + const cblc_field_t *source, + size_t source_offset) { int retval = 0; //_Float128 value = *(_Float128*)(source->data+source_offset); @@ -11970,37 +12028,37 @@ __gg__float32_from_128( cblc_field_t *dest, } else { - *(_Float32 *)(dest->data+dest_offset) = (_Float32)value; + *reinterpret_cast<_Float32 *>(dest->data+dest_offset) = (_Float32)value; } return retval; } extern "C" int -__gg__float32_from_64( cblc_field_t *dest, - size_t dest_offset, - cblc_field_t *source, - size_t source_offset) +__gg__float32_from_64( const cblc_field_t *dest, + size_t dest_offset, + const cblc_field_t *source, + size_t source_offset) { int retval = 0; - _Float64 value = *(_Float64*)(source->data+source_offset); + _Float64 value = *reinterpret_cast<_Float64*>(source->data+source_offset); if( FP128_FUNC(fabs)(value) > GCOB_FP128_LITERAL (3.4028235E38) ) { retval = 1; } else { - *(_Float32 *)(dest->data+dest_offset) = (_Float32)value; + *reinterpret_cast<_Float32 *>(dest->data+dest_offset) = (_Float32)value; } return retval; } extern "C" int -__gg__float64_from_128( cblc_field_t *dest, - size_t dest_offset, - cblc_field_t *source, - size_t source_offset) +__gg__float64_from_128( const cblc_field_t *dest, + size_t dest_offset, + const cblc_field_t *source, + size_t source_offset) { int retval = 0; // _Float128 value = *(_Float128*)(source->data+source_offset); @@ -12012,7 +12070,7 @@ __gg__float64_from_128( cblc_field_t *dest, } else { - *(_Float64 *)(dest->data+dest_offset) = (_Float64)value; + *reinterpret_cast<_Float64 *>(dest->data+dest_offset) = (_Float64)value; } return retval; } @@ -12084,7 +12142,8 @@ __gg__pop_local_variables() extern "C" void -__gg__copy_as_big_endian(unsigned char *dest, unsigned char *source) +__gg__copy_as_big_endian( unsigned char *dest, + const unsigned char *source) { // copy eight bytes of source to dest, flipping the endianness for(size_t i=0; i<8; i++) @@ -12107,7 +12166,7 @@ __gg__codeset_figurative_constants() extern "C" unsigned char * -__gg__get_figconst_data(cblc_field_t *field) +__gg__get_figconst_data(const cblc_field_t *field) { unsigned char *retval = NULL; cbl_figconst_t figconst = (cbl_figconst_t)(size_t)(field->initial); @@ -12192,7 +12251,7 @@ find_in_dirs(const char *dirs, char *unmangled_name, char *mangled_name) { while( !retval ) { - dirent *entry = readdir(dir); + const dirent *entry = readdir(dir); if( !entry ) { break; @@ -12248,7 +12307,7 @@ __gg__function_handle_from_cobpath( char *unmangled_name, char *mangled_name) { handle_executable = dlopen(NULL, RTLD_LAZY); } - if( !retval ) + //if( !retval ) { retval = dlsym(handle_executable, unmangled_name); } @@ -12272,14 +12331,17 @@ __gg__function_handle_from_cobpath( char *unmangled_name, char *mangled_name) extern "C" void -__gg__just_mangle_name( cblc_field_t *field, - char **mangled_name +__gg__just_mangle_name( const cblc_field_t *field, + char **mangled_name ) { static char ach_name[1024]; static char ach_unmangled[1024]; static char ach_mangled[1024]; + assert(field); + assert(field->data); + size_t length; length = field->capacity; memcpy(ach_name, field->data, length); @@ -12293,7 +12355,7 @@ __gg__just_mangle_name( cblc_field_t *field, bool is_pointer = false; - if( (field && field->type == FldPointer) ) + if( field->type == FldPointer ) { is_pointer = true; } @@ -12317,8 +12379,8 @@ __gg__just_mangle_name( cblc_field_t *field, extern "C" void * -__gg__function_handle_from_literal(int program_id, - char *literal) +__gg__function_handle_from_literal(int program_id, + const char *literal) { void *retval = NULL; static char ach_unmangled[1024]; @@ -12346,7 +12408,7 @@ __gg__function_handle_from_literal(int program_id, } PFUNC **pointers_p = it->second; PFUNC *pointers = *pointers_p; - retval = (void *)pointers[function_index]; + retval = reinterpret_cast<void *>(pointers[function_index]); } else { @@ -12358,10 +12420,10 @@ __gg__function_handle_from_literal(int program_id, extern "C" void * -__gg__function_handle_from_name(int program_id, - cblc_field_t *field, - size_t offset, - size_t length ) +__gg__function_handle_from_name(int program_id, + const cblc_field_t *field, + size_t offset, + size_t length ) { void *retval = NULL; static char ach_name[1024]; @@ -12399,7 +12461,7 @@ __gg__function_handle_from_name(int program_id, } PFUNC **pointers_p = it->second; PFUNC *pointers = *pointers_p; - retval = (void *)pointers[function_index]; + retval = reinterpret_cast<void *>(pointers[function_index]); } else { @@ -12435,10 +12497,10 @@ __gg__mirror_range( size_t nrows, cblc_field_t *src, // The row size_t src_o, size_t nspans, // The number of spans - size_t *spans, + const size_t *spans, size_t table, size_t ntbl, - size_t *tbls) + const size_t *tbls) { static std::unordered_map<size_t, size_t> rows_in_table; static std::unordered_map<size_t, size_t> widths_of_table; @@ -12459,7 +12521,7 @@ __gg__mirror_range( size_t nrows, // We need to know the width of one row of this table, which is different // depending on type of src: - cblc_field_t *parent = src; + const cblc_field_t *parent = src; while( parent ) { if( parent->occurs_upper ) @@ -12581,7 +12643,7 @@ __gg__mirror_range( size_t nrows, std::vector<size_t> subtable_spans = spans_in_table [subtable_index]; - unsigned char *subtable_source = source + subtable_offset; + const unsigned char *subtable_source = source + subtable_offset; if( subtable_spans.size() == 0 ) { @@ -12666,15 +12728,17 @@ __gg__deallocate( cblc_field_t *target, { // Target is a pointer. Free the data location int rdigits; - void *ptr = (void *)get_binary_value_local(&rdigits, + size_t addrv = get_binary_value_local(&rdigits, target, target->data + offset, sizeof(void *)); + void *ptr = reinterpret_cast<void *>(addrv); if( ptr ) { free(ptr); // And set the data location to zero - *(char **)(target->data + offset) = NULL; + *static_cast<char **>(static_cast<void *>(target->data + offset)) + = NULL; } } } @@ -12716,17 +12780,18 @@ get_the_byte(cblc_field_t *field) extern "C" void -__gg__allocate( cblc_field_t *first, - size_t first_offset, - int initialized, - int default_byte, - cblc_field_t *f_working_byte, - cblc_field_t *f_local_byte, - cblc_field_t *returning, - size_t returning_offset) +__gg__allocate( cblc_field_t *first, + size_t first_offset, + int initialized, + int default_byte, + cblc_field_t *f_working_byte, + cblc_field_t *f_local_byte, + const cblc_field_t *returning, + size_t returning_offset) { int working_byte = get_the_byte(f_working_byte); int local_byte = get_the_byte(f_local_byte); + int fill_char; unsigned char *retval = NULL; if( first->attr & based_e ) @@ -12734,12 +12799,12 @@ __gg__allocate( cblc_field_t *first, // first is the BASED variable we are allocating memory for if( first->capacity ) { - retval = (unsigned char *)malloc(first->capacity); + retval = static_cast<unsigned char *>(malloc(first->capacity)); + fill_char = 0; if( initialized ) { // This is ISO 2023 ALLOCATE rule 7 (ALL TO VALUE) - int fill_char = 0; if( default_byte >= 0 ) { fill_char = default_byte; @@ -12749,7 +12814,6 @@ __gg__allocate( cblc_field_t *first, else { // This is ISO 2023 ALLOCATE rule 9 (pointers NULL, otherwise OPT_INIT) - int fill_char = 0; if( default_byte >= 0 ) { fill_char = default_byte; @@ -12793,9 +12857,13 @@ __gg__allocate( cblc_field_t *first, tsize /= pof10; if( tsize ) { - retval = (unsigned char *)malloc(tsize); + retval = static_cast<unsigned char *>(malloc(tsize)); + if(!retval) + { + abort(); + } - int fill_char = 0; + fill_char = 0; if( initialized ) { // This is ISO 2023 rule 6 (defaultbyte if specified, else zero) @@ -12834,7 +12902,7 @@ __gg__allocate( cblc_field_t *first, if( returning ) { // 'returning' has to be a FldPointer variable; assign the retval to it. - *(unsigned char **)(returning->data + returning_offset) = retval; + *reinterpret_cast<unsigned char **>(returning->data + returning_offset) = retval; } } @@ -12863,7 +12931,8 @@ void __gg__module_name(cblc_field_t *dest, module_type_t type) { static size_t result_size = 64; - static char *result = (char *)malloc(result_size); + static char *result = static_cast<char *>(malloc(result_size)); + massert(result); strcpy(result, ""); @@ -12952,7 +13021,7 @@ __gg__module_name(cblc_field_t *dest, module_type_t type) if( strlen(result) + module_name_stack[i].substr(1).length() + 4 > result_size) { result_size *= 2; - result = (char *)realloc(result, result_size); + result = static_cast<char *>(realloc(result, result_size)); } strcat(result, module_name_stack[i].substr(1).c_str()); strcat(result, ";"); @@ -13101,39 +13170,42 @@ static char *sv_envname = NULL; extern "C" void -__gg__set_env_name( cblc_field_t *var, - size_t offset, - size_t length ) +__gg__set_env_name( const cblc_field_t *var, + size_t offset, + size_t length ) { free(sv_envname); - sv_envname = (char *)malloc(length+1); + sv_envname = static_cast<char *>(malloc(length+1)); + massert(sv_envname); memcpy(sv_envname, var->data+offset, length); sv_envname[length] = '\0'; } extern "C" void -__gg__set_env_value(cblc_field_t *value, - size_t offset, - size_t length ) +__gg__set_env_value(const cblc_field_t *value, + size_t offset, + size_t length ) { size_t name_length = strlen(sv_envname); size_t value_length = length; - static char *env = NULL; - static size_t env_length = 0; - static char *val = NULL; - static size_t val_length = 0; + static size_t env_length = 16; + static char *env = static_cast<char *>(malloc(env_length+1)); + static size_t val_length = 16; + static char *val = static_cast<char *>(malloc(val_length+1)); if( env_length < name_length+1 ) { env_length = name_length+1; - env = (char *)realloc(env, env_length); + env = static_cast<char *>(realloc(env, env_length)); } if( val_length < value_length+1 ) { val_length = value_length+1; - val = (char *)realloc(val, val_length); + val = static_cast<char *>(realloc(val, val_length)); } + massert(env); + massert(val); // The name and the value arrive in the internal codeset: memcpy(env, sv_envname, name_length); diff --git a/libgcobol/libgcobol.h b/libgcobol/libgcobol.h index f35987d..4aa2cff 100644 --- a/libgcobol/libgcobol.h +++ b/libgcobol/libgcobol.h @@ -39,6 +39,21 @@ Some are also called between source code modules in libgcobol, hence the need here for declarations. */ +extern void __gg__mabort(); + + +// The unnecessary abort() that follows is necessary to make cppcheck be +// aware that massert() actually terminates processing after a failed +// malloc(). +#define massert(p) if(!p){__gg__mabort();abort();} + +// This was part of an exercise to make cppcheck shut up about invalid +// pointer type conversions. +// It was also to avoid having reinterpret_cast<> all over the place. +// So, instead of reinterpret_cast<char *>(VALUE) +// I sometimes use PTRCAST(char, VALUE) +#define PTRCAST(TYPE, VALUE) static_cast<TYPE *>(static_cast<void *>(VALUE)) + extern "C" __int128 __gg__power_of_ten(int n); extern "C" __int128 __gg__dirty_to_binary_source( const char *dirty, @@ -89,22 +104,31 @@ extern "C" char __gg__get_decimal_separator(); extern "C" char __gg__get_decimal_point(); extern "C" char * __gg__get_default_currency_string(); -extern "C" void __gg__clock_gettime(clockid_t clk_id, struct timespec *tp); +struct cbl_timespec + { + /* You keep using that word "portability". I do not think it means what + you think it means. */ + time_t tv_sec; // Seconds. + long tv_nsec; // Nanoseconds. + } ; + +extern "C" void __gg__clock_gettime(clockid_t clk_id, struct cbl_timespec *tp); -extern "C" GCOB_FP128 __gg__float128_from_location(cblc_field_t *var, - unsigned char *location); +extern "C" GCOB_FP128 __gg__float128_from_location( + const cblc_field_t *var, + const unsigned char *location); extern "C" void __gg__adjust_dest_size(cblc_field_t *dest, size_t ncount); extern "C" void __gg__realloc_if_necessary( char **dest, size_t *dest_size, size_t new_size); -extern "C" void __gg__set_exception_file(cblc_file_t *file); +extern "C" void __gg__set_exception_file(const cblc_file_t *file); extern "C" void __gg__internal_to_console_in_place(char *loc, size_t length); -extern "C" __int128 __gg__binary_value_from_qualified_field(int *rdigits, - cblc_field_t *var, +extern "C" __int128 __gg__binary_value_from_qualified_field(int *rdigits, + const cblc_field_t *var, size_t offset, size_t size); -extern "C" GCOB_FP128 __gg__float128_from_qualified_field(cblc_field_t *field, +extern "C" GCOB_FP128 __gg__float128_from_qualified_field(const cblc_field_t *field, size_t offset, size_t size); extern "C" __int128 __gg__integer_from_qualified_field(cblc_field_t *var, diff --git a/libgcobol/valconv.cc b/libgcobol/valconv.cc index 8349b76..aaa89f5 100644 --- a/libgcobol/valconv.cc +++ b/libgcobol/valconv.cc @@ -71,7 +71,7 @@ __gg__realloc_if_necessary(char **dest, size_t *dest_size, size_t new_size) new_size |= new_size>>16; new_size |= (new_size>>16)>>16; *dest_size = new_size + 1; - *dest = (char *)realloc(*dest, *dest_size); + *dest = static_cast<char *>(realloc(*dest, *dest_size)); } } @@ -79,7 +79,7 @@ extern "C" void __gg__alphabet_create( cbl_encoding_t encoding, size_t alphabet_index, - unsigned char *alphabet, + const unsigned char *alphabet, int low_char, int high_char ) { @@ -222,7 +222,7 @@ Rindex(const char *dest, int length, char ch) extern "C" bool __gg__string_to_numeric_edited( char * const dest, - char *source, // In source characters + const char *source, // In source characters int rdigits, int is_negative, const char *picture) @@ -1222,9 +1222,9 @@ got_float: extern "C" void __gg__string_to_alpha_edited( char *dest, - char *source, + const char *source, int slength, - char *picture) + const char *picture) { // Put the PICTURE into the data area. If the caller didn't leave enough // room, well, poo on them. Said another way; if they specify disaster, diff --git a/libgcobol/valconv.h b/libgcobol/valconv.h index d907e6f..1efb2b9 100644 --- a/libgcobol/valconv.h +++ b/libgcobol/valconv.h @@ -60,18 +60,18 @@ extern "C" void __gg__realloc_if_necessary(char **dest, size_t *dest_size, size_t new_size); void __gg__alphabet_create(cbl_encoding_t encoding, size_t alphabet_index, - unsigned char *alphabet, + const unsigned char *alphabet, int low_char, int high_char ); bool __gg__string_to_numeric_edited(char * const dest, - char *source, // ASCII + const char *source, // ASCII int rdigits, int is_negative, const char *picture); void __gg__string_to_alpha_edited(char *dest, - char *source, + const char *source, int slength, - char *picture); + const char *picture); void __gg__currency_sign_init(); void __gg__currency_sign(int symbol, const char *sign); void __gg__remove_trailing_zeroes(char *p); diff --git a/libgomp/ChangeLog b/libgomp/ChangeLog index 78bbf26..3e68ecb 100644 --- a/libgomp/ChangeLog +++ b/libgomp/ChangeLog @@ -1,3 +1,43 @@ +2025-06-04 Tobias Burnus <tburnus@baylibre.com> + Sandra Loosemore <sloosemore@baylibre.com> + + * libgomp.texi (omp_interop_{int,ptr,str,rc_desc}): Add note about + the 'ret_code' type change in OpenMP 6. + +2025-06-03 Jakub Jelinek <jakub@redhat.com> + + PR libgomp/120444 + * testsuite/libgomp.c-c++-common/omp_target_memset-3.c (test_it): + Change ptr argument type from void * to int8_t *. + (main): Change ptr variable type from void * to int8_t * and cast + omp_target_alloc result to the latter type. + +2025-06-02 Tobias Burnus <tburnus@baylibre.com> + + PR libgomp/120444 + * libgomp-plugin.h (GOMP_OFFLOAD_memset): Declare. + * libgomp.h (struct gomp_device_descr): Add memset_func. + * libgomp.map (GOMP_6.0.1): Add omp_target_memset{,_async}. + * libgomp.texi (Device Memory Routines): Document them. + * omp.h.in (omp_target_memset, omp_target_memset_async): Declare. + * omp_lib.f90.in (omp_target_memset, omp_target_memset_async): + Add interfaces. + * omp_lib.h.in (omp_target_memset, omp_target_memset_async): Likewise. + * plugin/cuda-lib.def: Add cuMemsetD8. + * plugin/plugin-gcn.c (struct hsa_runtime_fn_info): Add + hsa_amd_memory_fill_fn. + (init_hsa_runtime_functions): DLSYM_OPT_FN load it. + (GOMP_OFFLOAD_memset): New. + * plugin/plugin-nvptx.c (GOMP_OFFLOAD_memset): New. + * target.c (omp_target_memset_int, omp_target_memset, + omp_target_memset_async_helper, omp_target_memset_async): New. + (gomp_load_plugin_for_device): Add DLSYM (memset). + * testsuite/libgomp.c-c++-common/omp_target_memset.c: New test. + * testsuite/libgomp.c-c++-common/omp_target_memset-2.c: New test. + * testsuite/libgomp.c-c++-common/omp_target_memset-3.c: New test. + * testsuite/libgomp.fortran/omp_target_memset.f90: New test. + * testsuite/libgomp.fortran/omp_target_memset-2.f90: New test. + 2025-05-30 Thomas Schwinge <tschwinge@baylibre.com> * testsuite/libgomp.c++/target-std__valarray-1.C: New. diff --git a/libgomp/libgomp.texi b/libgomp/libgomp.texi index 8e487bc..7116fcd 100644 --- a/libgomp/libgomp.texi +++ b/libgomp/libgomp.texi @@ -3130,6 +3130,11 @@ and Fortran or used with @code{NULL} as argument in C and C++. If successful, In GCC, the effect of running this routine in a @code{target} region that is not the initial device is unspecified. +GCC implements the OpenMP 6.0 version of this function for C and C++, which is not +compatible with its type signature in previous versions of the OpenMP specification. +In older versions, the type @code{int*} was used for the @var{ret_code} argument +in place of a pointer to the enumerated type @code{omp_interop_rc_t}. + @c Implementation remark: In GCC, the Fortran interface differs from the one shown @c below: the function has C binding and @var{interop} and @var{property_id} are @c passed by value, which permits use of the same ABI as the C function. This does @@ -3176,6 +3181,11 @@ and Fortran or used with @code{NULL} as argument in C and C++. If successful, In GCC, the effect of running this routine in a @code{target} region that is not the initial device is unspecified. +GCC implements the OpenMP 6.0 version of this function for C and C++, which is not +compatible with its type signature in previous versions of the OpenMP specification. +In older versions, the type @code{int*} was used for the @var{ret_code} argument +in place of a pointer to the enumerated type @code{omp_interop_rc_t}. + @c Implementation remark: In GCC, the Fortran interface differs from the one shown @c below: the function has C binding and @var{interop} and @var{property_id} are @c passed by value, which permits use of the same ABI as the C function. This does @@ -3222,6 +3232,11 @@ and Fortran or used with @code{NULL} as argument in C and C++. If successful, In GCC, the effect of running this routine in a @code{target} region that is not the initial device is unspecified. +GCC implements the OpenMP 6.0 version of this function for C and C++, which is not +compatible with its type signature in previous versions of the OpenMP specification. +In older versions, the type @code{int*} was used for the @var{ret_code} argument +in place of a pointer to the enumerated type @code{omp_interop_rc_t}. + @c Implementation remark: In GCC, the Fortran interface differs from the one shown @c below: @var{interop} and @var{property_id} are passed by value. This does not @c affect the usage of the function when GCC's @code{omp_lib} module or @@ -3348,6 +3363,11 @@ the @var{ret_code} in human-readable form. The behavior is unspecified if value of @var{ret_code} was not set by an interoperability routine invoked for @var{interop}. +GCC implements the OpenMP 6.0 version of this function for C and C++, which is not +compatible with its type signature in previous versions of the OpenMP specification. +In older versions, the type @code{int} was used for the @var{ret_code} argument +in place of the enumerated type @code{omp_interop_rc_t}. + @item @emph{C/C++}: @multitable @columnfractions .20 .80 @item @emph{Prototype}: @tab @code{const char *omp_get_interop_rc_desc(const omp_interop_t interop, diff --git a/libgomp/testsuite/libgomp.c-c++-common/omp_target_memset-3.c b/libgomp/testsuite/libgomp.c-c++-common/omp_target_memset-3.c index 6f25204..c0e4fa9 100644 --- a/libgomp/testsuite/libgomp.c-c++-common/omp_target_memset-3.c +++ b/libgomp/testsuite/libgomp.c-c++-common/omp_target_memset-3.c @@ -24,7 +24,7 @@ check_val (int8_t *ptr, int val, size_t count) } static void -test_it (void *ptr, int lshift, size_t count) +test_it (int8_t *ptr, int lshift, size_t count) { if (N < count + lshift) __builtin_abort (); if (lshift >= 4) __builtin_abort (); @@ -42,7 +42,7 @@ test_it (void *ptr, int lshift, size_t count) int main() { size_t size; - void *ptr = omp_target_alloc (N + 3, omp_get_default_device()); + int8_t *ptr = (int8_t *) omp_target_alloc (N + 3, omp_get_default_device()); ptr += (4 - (uintptr_t) ptr % 4) % 4; if ((uintptr_t) ptr % 4 != 0) __builtin_abort (); diff --git a/libstdc++-v3/ChangeLog b/libstdc++-v3/ChangeLog index 9df2d57..85b4adc 100644 --- a/libstdc++-v3/ChangeLog +++ b/libstdc++-v3/ChangeLog @@ -1,3 +1,203 @@ +2025-06-04 Jonathan Wakely <jwakely@redhat.com> + + * testsuite/std/time/format/empty_spec.cc: Only test time zones + for cxx11 string ABI. + +2025-06-04 Jonathan Wakely <jwakely@redhat.com> + + PR libstdc++/99832 + * include/bits/chrono.h (system_clock::to_time_t): Add + always_inline attribute to be agnostic to the underlying type of + time_t. + (system_clock::from_time_t): Add always_inline for consistency + with to_time_t. + * testsuite/20_util/system_clock/99832.cc: New test. + +2025-06-04 Nathan Myers <ncm@cantrip.org> + + PR libstdc++/119741 + * include/std/sstream: full implementation, really just + decls, requires clause and plumbing. + * include/bits/version.def, include/bits/version.h: + new preprocessor symbol + __cpp_lib_sstream_from_string_view. + * testsuite/27_io/basic_stringbuf/cons/char/string_view.cc: + New tests. + * testsuite/27_io/basic_istringstream/cons/char/string_view.cc: + New tests. + * testsuite/27_io/basic_ostringstream/cons/char/string_view.cc: + New tests. + * testsuite/27_io/basic_stringstream/cons/char/string_view.cc: + New tests. + * testsuite/27_io/basic_stringbuf/cons/wchar_t/string_view.cc: + New tests. + * testsuite/27_io/basic_istringstream/cons/wchar_t/string_view.cc: + New tests. + * testsuite/27_io/basic_ostringstream/cons/wchar_t/string_view.cc: + New tests. + * testsuite/27_io/basic_stringstream/cons/wchar_t/string_view.cc: + New tests. + +2025-06-04 Patrick Palka <ppalka@redhat.com> + + * include/bits/c++config (_GLIBCXX_AUTO_CAST): Define. + * include/bits/iterator_concepts.h (_Decay_copy, __decay_copy): + Remove. + (__member_begin, __adl_begin): Use _GLIBCXX_AUTO_CAST instead of + __decay_copy as per P0849R8. + * include/bits/ranges_base.h (_Begin): Likewise. + (__member_end, __adl_end, _End): Likewise. + (__member_rbegin, __adl_rbegin, _RBegin): Likewise. + (__member_rend, __adl_rend, _Rend): Likewise. + (__member_size, __adl_size, _Size): Likewise. + (_Data): Likewise. + +2025-06-04 Tomasz KamiÅ„ski <tkaminsk@redhat.com> + + * testsuite/std/time/format/empty_spec.cc: New tests. + +2025-06-04 Patrick Palka <ppalka@redhat.com> + + * include/bits/ranges_algo.h (__starts_with_fn, starts_with): + Define. + (__ends_with_fn, ends_with): Define. + * include/bits/version.def (ranges_starts_ends_with): Define. + * include/bits/version.h: Regenerate. + * include/std/algorithm: Provide __cpp_lib_ranges_starts_ends_with. + * src/c++23/std.cc.in (ranges::starts_with): Export. + (ranges::ends_with): Export. + * testsuite/25_algorithms/ends_with/1.cc: New test. + * testsuite/25_algorithms/starts_with/1.cc: New test. + +2025-06-04 Jonathan Wakely <jwakely@redhat.com> + + * include/bits/semaphore_base.h (_S_get_current): Replace with + non-static _M_get_current. + (_S_do_try_acquire): Replace with non-static _M_do_try_acquire. + +2025-06-04 Jonathan Wakely <jwakely@redhat.com> + + PR libstdc++/104928 + * include/bits/semaphore_base.h (_S_do_try_acquire): Take old + value by reference. + (_M_acquire): Move _S_do_try_acquire call out of the predicate + and loop on its result. Make the predicate capture and update + the local copy of the value. + (_M_try_acquire_until, _M_try_acquire_for): Likewise. + (_M_try_acquire): Just call _M_try_acquire_for. + * testsuite/30_threads/semaphore/104928-2.cc: New test. + * testsuite/30_threads/semaphore/104928.cc: New test. + +2025-06-04 Tomasz KamiÅ„ski <tkaminsk@redhat.com> + + * include/bits/chrono_io.h (__formatter_chrono:_M_s): Add missing + __out argument to format_to call. + * testsuite/std/time/format/empty_spec.cc: New test. + +2025-06-03 Jonathan Wakely <jwakely@redhat.com> + + * include/std/stop_token: Check __glibcxx_jthread instead of + __cplusplus. + +2025-06-03 Jonathan Wakely <jwakely@redhat.com> + + * include/std/type_traits (is_destructible, is_destructible_v): + Define using new built-in. + (is_nothrow_destructible, is_nothrow_destructible_v): Likewise. + (is_trivially_destructible, is_trivially_destructible_v): + Likewise. + +2025-06-03 Jonathan Wakely <jwakely@redhat.com> + + * include/bits/atomic_timed_wait.h (__detail::__wait_until): + Remove incorrect comment. + (__atomic_wait_address_until_v): Do not take address of __args in + call to __detail::__wait_until. Fix return statement to refer to + member of __wait_result_type. + (__atomic_wait_address_for_v): Change parameter type from + time_point to duration. + * src/c++20/atomic.cc (__spin_until_impl): Fix incorrect + return value. Reuse result of first call to clock. + +2025-06-03 Jonathan Wakely <jwakely@redhat.com> + + * include/bits/stl_vector.h (~_Vector_base): Add unreachable + hint for negative capacity and cast to size_t explicitly. + * include/bits/vector.tcc (vector::_M_realloc_append): Use + size() instead of end() - begin(). + +2025-06-03 Jonathan Wakely <jwakely@redhat.com> + + * include/std/bit (__rotl, __rotr): Use static_cast for + conversion from int to unsigned. + +2025-06-03 Jonathan Wakely <jwakely@redhat.com> + + * src/c++23/std.cc.in: Remove redundant checks for feature test + macros that are always true. + +2025-06-02 Jonathan Wakely <jwakely@redhat.com> + + * include/bits/basic_string.h (basic_string::size): Remove space + before parameter list. + (basic_string::capacity): Likewise. + * include/bits/stl_deque.h (deque::size): Likewise. + * include/bits/stl_vector.h (vector::size, vector::capacity): + Likewise. + * include/bits/vector.tcc (vector::_M_realloc_insert): Likewise. + (vector::_M_realloc_append): Likewise. + +2025-06-02 Jonathan Wakely <jwakely@redhat.com> + + PR libstdc++/120386 + * include/bits/ranges_algo.h (__unique_copy_fn): Reorder + arguments for third case to match the first two cases. + * include/bits/stl_algo.h (__unique_copy): Replace three + overloads with two, depending only on the iterator category of + the input range. Dispatch to __unique_copy_1 for the + non-forward case. + (__unique_copy_1): New overloads for the case where the input + range uses non-forward iterators. + (unique_copy): Only pass the input range category to + __unique_copy. + * testsuite/25_algorithms/unique_copy/lwg2439.cc: New test. + +2025-06-02 Tomasz KamiÅ„ski <tkaminsk@redhat.com> + + * include/bits/funcwrap.h (__polyfunc::__pass_by_rref): Define. + (__polyfunc::__param_t): Update to use __pass_by_rref. + * include/bits/cpyfunc_impl.h:: Assert that are parameters type + are complete. + * include/bits/funcref_impl.h: Likewise. + * include/bits/mofunc_impl.h: Likewise. + * testsuite/20_util/copyable_function/call.cc: New test. + * testsuite/20_util/function_ref/call.cc: New test. + * testsuite/20_util/move_only_function/call.cc: New test. + * testsuite/20_util/copyable_function/conv.cc: New test. + * testsuite/20_util/function_ref/conv.cc: New test. + * testsuite/20_util/move_only_function/conv.cc: New test. + * testsuite/20_util/copyable_function/incomplete_neg.cc: New test. + * testsuite/20_util/function_ref/incomplete_neg.cc: New test. + * testsuite/20_util/move_only_function/incomplete_neg.cc: New test. + +2025-06-02 Jonathan Wakely <jwakely@redhat.com> + Tomasz KamiÅ„ski <tkaminsk@redhat.com> + + PR libstdc++/119152 + * include/bits/indirect.h (std::polymorphic, pmr::polymorphic) + [__glibcxx_polymorphic]: Define. + * include/bits/version.def (polymorphic): Define. + * include/bits/version.h: Regenerate. + * include/std/memory: Define __cpp_lib_polymorphic. + * testsuite/std/memory/polymorphic/copy.cc: New test. + * testsuite/std/memory/polymorphic/copy_alloc.cc: New test. + * testsuite/std/memory/polymorphic/ctor.cc: New test. + * testsuite/std/memory/polymorphic/ctor_poly.cc: New test. + * testsuite/std/memory/polymorphic/incomplete.cc: New test. + * testsuite/std/memory/polymorphic/invalid_neg.cc: New test. + * testsuite/std/memory/polymorphic/move.cc: New test. + * testsuite/std/memory/polymorphic/move_alloc.cc: New test. + 2025-05-30 Tomasz KamiÅ„ski <tkaminsk@redhat.com> * testsuite/std/time/format/empty_spec.cc: New test. diff --git a/libstdc++-v3/include/bits/atomic_timed_wait.h b/libstdc++-v3/include/bits/atomic_timed_wait.h index 230afbc..bd2e6bf 100644 --- a/libstdc++-v3/include/bits/atomic_timed_wait.h +++ b/libstdc++-v3/include/bits/atomic_timed_wait.h @@ -87,7 +87,6 @@ _GLIBCXX_BEGIN_NAMESPACE_VERSION __wait_until_impl(const void* __addr, __wait_args_base& __args, const __wait_clock_t::duration& __atime); - // Returns {true, val} if wait ended before a timeout. template<typename _Clock, typename _Dur> __wait_result_type __wait_until(const void* __addr, __wait_args_base& __args, @@ -158,8 +157,8 @@ _GLIBCXX_BEGIN_NAMESPACE_VERSION bool __bare_wait = false) noexcept { __detail::__wait_args __args{ __addr, __old, __order, __bare_wait }; - auto __res = __detail::__wait_until(__addr, &__args, __atime); - return __res.first; // C++26 will also return last observed __val + auto __res = __detail::__wait_until(__addr, __args, __atime); + return !__res._M_timeout; // C++26 will also return last observed __val } template<typename _Tp, typename _ValFn, @@ -203,7 +202,7 @@ _GLIBCXX_BEGIN_NAMESPACE_VERSION __atomic_wait_address_for_v(const __detail::__platform_wait_t* __addr, __detail::__platform_wait_t __old, int __order, - const chrono::time_point<_Rep, _Period>& __rtime, + const chrono::duration<_Rep, _Period>& __rtime, bool __bare_wait = false) noexcept { __detail::__wait_args __args{ __addr, __old, __order, __bare_wait }; diff --git a/libstdc++-v3/include/bits/c++config b/libstdc++-v3/include/bits/c++config index 676f5ee..eec3a4a 100644 --- a/libstdc++-v3/include/bits/c++config +++ b/libstdc++-v3/include/bits/c++config @@ -273,6 +273,12 @@ #define _GLIBCXX_NOEXCEPT_QUAL #endif +#if __cpp_auto_cast +# define _GLIBCXX_AUTO_CAST(X) auto(X) +#else +# define _GLIBCXX_AUTO_CAST(X) ::std::__decay_t<decltype((X))>(X) +#endif + // Macro for extern template, ie controlling template linkage via use // of extern keyword on template declaration. As documented in the g++ // manual, it inhibits all implicit instantiations and is used diff --git a/libstdc++-v3/include/bits/chrono.h b/libstdc++-v3/include/bits/chrono.h index fad2162..8de8e75 100644 --- a/libstdc++-v3/include/bits/chrono.h +++ b/libstdc++-v3/include/bits/chrono.h @@ -1244,6 +1244,7 @@ _GLIBCXX_BEGIN_INLINE_ABI_NAMESPACE(_V2) now() noexcept; // Map to C API + [[__gnu__::__always_inline__]] static std::time_t to_time_t(const time_point& __t) noexcept { @@ -1251,6 +1252,7 @@ _GLIBCXX_BEGIN_INLINE_ABI_NAMESPACE(_V2) (__t.time_since_epoch()).count()); } + [[__gnu__::__always_inline__]] static time_point from_time_t(std::time_t __t) noexcept { diff --git a/libstdc++-v3/include/bits/chrono_io.h b/libstdc++-v3/include/bits/chrono_io.h index 346eb8b..9711a83 100644 --- a/libstdc++-v3/include/bits/chrono_io.h +++ b/libstdc++-v3/include/bits/chrono_io.h @@ -785,11 +785,12 @@ namespace __format } static constexpr const _CharT* _S_chars - = _GLIBCXX_WIDEN("0123456789+-:/ {}"); - static constexpr const _CharT* _S_plus_minus = _S_chars + 10; - static constexpr _CharT _S_colon = _S_chars[12]; - static constexpr _CharT _S_slash = _S_chars[13]; - static constexpr _CharT _S_space = _S_chars[14]; + = _GLIBCXX_WIDEN("0123456789:/ +-{}"); + static constexpr _CharT _S_colon = _S_chars[10]; + static constexpr _CharT _S_slash = _S_chars[11]; + static constexpr _CharT _S_space = _S_chars[12]; + static constexpr const _CharT* _S_plus_minus = _S_chars + 13; + static constexpr const _CharT* _S_minus_empty_spec = _S_chars + 14; static constexpr const _CharT* _S_empty_spec = _S_chars + 15; template<typename _OutIter> @@ -941,33 +942,39 @@ namespace __format __conv, __mod); } - basic_string<_CharT> __s; int __yi = (int)__y; const bool __is_neg = __yi < 0; __yi = __builtin_abs(__yi); + int __ci = __yi / 100; + // For floored division -123//100 is -2 and -100//100 is -1 + if (__conv == 'C' && __is_neg && (__ci * 100) != __yi) [[unlikely]] + ++__ci; - if (__conv == 'Y' || __conv == 'C') + if (__conv != 'y' && __ci >= 100) [[unlikely]] { - int __ci = __yi / 100; - if (__is_neg) [[unlikely]] + using _FmtStr = _Runtime_format_string<_CharT>; + __string_view __fs = _S_minus_empty_spec + !__is_neg; + __out = std::format_to(std::move(__out), _FmtStr(__fs), + __conv == 'C' ? __ci : __yi); + } + else + { + _CharT __buf[5]; + __buf[0] = _S_plus_minus[1]; + __string_view __sv(__buf + 3, __buf + 3); + if (__conv != 'y') { - __s.assign(1, _S_plus_minus[1]); - // For floored division -123//100 is -2 and -100//100 is -1 - if (__conv == 'C' && (__ci * 100) != __yi) - ++__ci; + _S_fill_two_digits(__buf + 1, __ci); + __sv = __string_view(__buf + !__is_neg, __buf + 3); } - if (__ci >= 100) [[unlikely]] + if (__conv != 'C') { - __s += std::format(_S_empty_spec, __ci / 100); - __ci %= 100; + _S_fill_two_digits(__buf + 3, __yi % 100); + __sv = __string_view(__sv.data(), __buf + 5); } - __s += _S_two_digits(__ci); + __out = __format::__write(std::move(__out), __sv); } - - if (__conv == 'Y' || __conv == 'y') - __s += _S_two_digits(__yi % 100); - - return __format::__write(std::move(__out), __string_view(__s)); + return std::move(__out); } template<typename _Tp, typename _FormatContext> @@ -976,16 +983,30 @@ namespace __format _FormatContext&) const { auto __ymd = _S_date(__t); - basic_string<_CharT> __s; -#if ! _GLIBCXX_USE_CXX11_ABI - __s.reserve(8); -#endif - __s = _S_two_digits((unsigned)__ymd.month()); - __s += _S_slash; - __s += _S_two_digits((unsigned)__ymd.day()); - __s += _S_slash; - __s += _S_two_digits(__builtin_abs((int)__ymd.year()) % 100); - return __format::__write(std::move(__out), __string_view(__s)); + auto __di = (unsigned)__ymd.day(); + auto __mi = (unsigned)__ymd.month(); + auto __yi = __builtin_abs((int)__ymd.year()) % 100; + + if (__mi >= 100 || __di >= 100) [[unlikely]] + { + using _FmtStr = _Runtime_format_string<_CharT>; + __string_view __fs = _GLIBCXX_WIDEN("{:02d}/{:02d}/{:02d}"); + __out = std::format_to(std::move(__out), _FmtStr(__fs), + __mi, __di, __yi); + } + else + { + _CharT __buf[8]; + __buf[2] = _S_slash; + __buf[5] = _S_slash; + __string_view __sv(__buf, __buf + 8); + + _S_fill_two_digits(__buf, __mi); + _S_fill_two_digits(__buf + 3, __di); + _S_fill_two_digits(__buf + 6, __yi); + __out = __format::__write(std::move(__out), __sv); + } + return std::move(__out); } template<typename _Tp, typename _FormatContext> @@ -1010,12 +1031,12 @@ namespace __format (char)__conv, 'O'); } - auto __sv = _S_two_digits(__i); - _CharT __buf[2]; + _CharT __buf[3]; + auto __sv = _S_str_d2(__buf, __i); if (__conv == _CharT('e') && __i < 10) { - __buf[0] = _S_space; __buf[1] = __sv[1]; + __buf[0] = _S_space; __sv = {__buf, 2}; } return __format::__write(std::move(__out), __sv); @@ -1027,16 +1048,35 @@ namespace __format _FormatContext&) const { auto __ymd = _S_date(__t); - auto __s = std::format(_GLIBCXX_WIDEN("{:04d}- - "), - (int)__ymd.year()); - auto __sv = _S_two_digits((unsigned)__ymd.month()); - __s[__s.size() - 5] = __sv[0]; - __s[__s.size() - 4] = __sv[1]; - __sv = _S_two_digits((unsigned)__ymd.day()); - __s[__s.size() - 2] = __sv[0]; - __s[__s.size() - 1] = __sv[1]; - __sv = __s; - return __format::__write(std::move(__out), __sv); + auto __di = (unsigned)__ymd.day(); + auto __mi = (unsigned)__ymd.month(); + auto __yi = (int)__ymd.year(); + const bool __is_neg = __yi < 0; + __yi = __builtin_abs(__yi); + + if (__yi >= 10000 || __mi >= 100 || __di >= 100) [[unlikely]] + { + using _FmtStr = _Runtime_format_string<_CharT>; + __string_view __fs + = _GLIBCXX_WIDEN("-{:04d}-{:02d}-{:02d}") + !__is_neg; + __out = std::format_to(std::move(__out), _FmtStr(__fs), + __yi, __mi, __di); + } + else + { + _CharT __buf[11]; + __buf[0] = _S_plus_minus[1]; + __buf[5] = _S_plus_minus[1]; + __buf[8] = _S_plus_minus[1]; + __string_view __sv(__buf + !__is_neg, __buf + 11); + + _S_fill_two_digits(__buf + 1, __yi / 100); + _S_fill_two_digits(__buf + 3, __yi % 100); + _S_fill_two_digits(__buf + 6, __mi); + _S_fill_two_digits(__buf + 9, __di); + __out = __format::__write(std::move(__out), __sv); + } + return std::move(__out); } template<typename _Tp, typename _FormatContext> @@ -1079,11 +1119,13 @@ namespace __format if (__conv == _CharT('I')) { + __i %= 12; if (__i == 0) __i = 12; - else if (__i > 12) - __i -= 12; } + else if (__i >= 100) [[unlikely]] + return std::format_to(std::move(__out), _S_empty_spec, __i); + return __format::__write(std::move(__out), _S_two_digits(__i)); } @@ -1136,7 +1178,8 @@ namespace __format 'm', 'O'); } - return __format::__write(std::move(__out), _S_two_digits(__i)); + _CharT __buf[3]; + return __format::__write(std::move(__out), _S_str_d2(__buf, __i)); } template<typename _Tp, typename _FormatContext> @@ -1169,12 +1212,15 @@ namespace __format { // %p The locale's equivalent of the AM/PM designations. auto __hms = _S_hms(__t); + auto __hi = __hms.hours().count(); + if (__hi >= 24) [[unlikely]] + __hi %= 24; + locale __loc = _M_locale(__ctx); const auto& __tp = use_facet<__timepunct<_CharT>>(__loc); const _CharT* __ampm[2]; __tp._M_am_pm(__ampm); - return _M_write(std::move(__out), __loc, - __ampm[__hms.hours().count() >= 12]); + return _M_write(std::move(__out), __loc, __ampm[__hi >= 12]); } template<typename _Tp, typename _FormatContext> @@ -1222,19 +1268,25 @@ namespace __format // %R Equivalent to %H:%M // %T Equivalent to %H:%M:%S auto __hms = _S_hms(__t); + auto __hi = __hms.hours().count(); - auto __s = std::format(_GLIBCXX_WIDEN("{:02d}:00"), - __hms.hours().count()); - auto __sv = _S_two_digits(__hms.minutes().count()); - __s[__s.size() - 2] = __sv[0]; - __s[__s.size() - 1] = __sv[1]; - __sv = __s; - __out = __format::__write(std::move(__out), __sv); - if (__secs) + _CharT __buf[6]; + __buf[2] = _S_colon; + __buf[5] = _S_colon; + __string_view __sv(__buf, 5 + __secs); + + if (__hi >= 100) [[unlikely]] { - *__out++ = _S_colon; - __out = _M_S(__hms, std::move(__out), __ctx); + __out = std::format_to(std::move(__out), _S_empty_spec, __hi); + __sv.remove_prefix(2); } + else + _S_fill_two_digits(__buf, __hi); + + _S_fill_two_digits(__buf + 3, __hms.minutes().count()); + __out = __format::__write(std::move(__out), __sv); + if (__secs) + __out = _M_S(__hms, std::move(__out), __ctx); return __out; } @@ -1296,7 +1348,8 @@ namespace __format else { auto __str = std::format(_S_empty_spec, __ss.count()); - __out = std::format_to(_GLIBCXX_WIDEN("{:0>{}s}"), + __out = std::format_to(std::move(__out), + _GLIBCXX_WIDEN("{:0>{}s}"), __str, __hms.fractional_width); } @@ -1330,8 +1383,8 @@ namespace __format unsigned __wdi = __conv == 'u' ? __wd.iso_encoding() : __wd.c_encoding(); - const _CharT __d = _S_digit(__wdi); - return __format::__write(std::move(__out), __string_view(&__d, 1)); + _CharT __buf[3]; + return __format::__write(std::move(__out), _S_str_d1(__buf, __wdi)); } template<typename _Tp, typename _FormatContext> @@ -1516,12 +1569,12 @@ namespace __format // %% handled in _M_format - // A single digit character in the range '0'..'9'. - static _CharT + // A string view of single digit character, "0".."9". + static basic_string_view<_CharT> _S_digit(int __n) noexcept { // Extra 9s avoid past-the-end read on bad input. - return _GLIBCXX_WIDEN("0123456789999999")[__n & 0xf]; + return { _GLIBCXX_WIDEN("0123456789999999") + (__n & 0xf), 1 }; } // A string view of two digit characters, "00".."99". @@ -1540,6 +1593,41 @@ namespace __format }; } + [[__gnu__::__always_inline__]] + // Fills __buf[0] and __buf[1] with 2 digit value of __n. + static void + _S_fill_two_digits(_CharT* __buf, unsigned __n) + { + auto __sv = _S_two_digits(__n); + __buf[0] = __sv[0]; + __buf[1] = __sv[1]; + } + + [[__gnu__::__always_inline__]] + // Returns decimal representation of __n. + // Returned string_view may point to __buf. + static basic_string_view<_CharT> + _S_str_d1(span<_CharT, 3> __buf, unsigned __n) + { + if (__n < 10) [[likely]] + return _S_digit(__n); + return _S_str_d2(__buf, __n); + } + + [[__gnu__::__always_inline__]] + // Returns decimal representation of __n, padded to 2 digits. + // Returned string_view may point to __buf. + static basic_string_view<_CharT> + _S_str_d2(span<_CharT, 3> __buf, unsigned __n) + { + if (__n < 100) [[likely]] + return _S_two_digits(__n); + + _S_fill_two_digits(__buf.data(), __n / 10); + __buf[2] = _S_digit(__n % 10)[0]; + return __string_view(__buf.data(), 3); + } + // Accessors for the components of chrono types: // Returns a hh_mm_ss. diff --git a/libstdc++-v3/include/bits/iterator_concepts.h b/libstdc++-v3/include/bits/iterator_concepts.h index 3b73ff9..d31e4f1 100644 --- a/libstdc++-v3/include/bits/iterator_concepts.h +++ b/libstdc++-v3/include/bits/iterator_concepts.h @@ -1022,19 +1022,10 @@ namespace ranges { using std::__detail::__class_or_enum; - struct _Decay_copy final - { - template<typename _Tp> - constexpr decay_t<_Tp> - operator()(_Tp&& __t) const - noexcept(is_nothrow_convertible_v<_Tp, decay_t<_Tp>>) - { return std::forward<_Tp>(__t); } - } inline constexpr __decay_copy{}; - template<typename _Tp> concept __member_begin = requires(_Tp& __t) { - { __decay_copy(__t.begin()) } -> input_or_output_iterator; + { _GLIBCXX_AUTO_CAST(__t.begin()) } -> input_or_output_iterator; }; // Poison pill so that unqualified lookup doesn't find std::begin. @@ -1044,7 +1035,7 @@ namespace ranges concept __adl_begin = __class_or_enum<remove_reference_t<_Tp>> && requires(_Tp& __t) { - { __decay_copy(begin(__t)) } -> input_or_output_iterator; + { _GLIBCXX_AUTO_CAST(begin(__t)) } -> input_or_output_iterator; }; // Simplified version of std::ranges::begin that only supports lvalues, diff --git a/libstdc++-v3/include/bits/ranges_algo.h b/libstdc++-v3/include/bits/ranges_algo.h index 7b14084..a62c3cd 100644 --- a/libstdc++-v3/include/bits/ranges_algo.h +++ b/libstdc++-v3/include/bits/ranges_algo.h @@ -438,6 +438,254 @@ namespace ranges inline constexpr __search_n_fn search_n{}; +#if __glibcxx_ranges_starts_ends_with // C++ >= 23 + struct __starts_with_fn + { + template<input_iterator _Iter1, sentinel_for<_Iter1> _Sent1, + input_iterator _Iter2, sentinel_for<_Iter2> _Sent2, + typename _Pred = ranges::equal_to, + typename _Proj1 = identity, typename _Proj2 = identity> + requires indirectly_comparable<_Iter1, _Iter2, _Pred, _Proj1, _Proj2> + constexpr bool + operator()(_Iter1 __first1, _Sent1 __last1, + _Iter2 __first2, _Sent2 __last2, _Pred __pred = {}, + _Proj1 __proj1 = {}, _Proj2 __proj2 = {}) const + { + iter_difference_t<_Iter1> __n1 = -1; + iter_difference_t<_Iter2> __n2 = -1; + if constexpr (sized_sentinel_for<_Sent1, _Iter1>) + __n1 = __last1 - __first1; + if constexpr (sized_sentinel_for<_Sent2, _Iter2>) + __n2 = __last2 - __first2; + return _S_impl(std::move(__first1), __last1, __n1, + std::move(__first2), __last2, __n2, + std::move(__pred), + std::move(__proj1), std::move(__proj2)); + } + + template<input_range _Range1, input_range _Range2, + typename _Pred = ranges::equal_to, + typename _Proj1 = identity, typename _Proj2 = identity> + requires indirectly_comparable<iterator_t<_Range1>, iterator_t<_Range2>, + _Pred, _Proj1, _Proj2> + constexpr bool + operator()(_Range1&& __r1, _Range2&& __r2, _Pred __pred = {}, + _Proj1 __proj1 = {}, _Proj2 __proj2 = {}) const + { + range_difference_t<_Range1> __n1 = -1; + range_difference_t<_Range2> __n2 = -1; + if constexpr (sized_range<_Range1>) + __n1 = ranges::size(__r1); + if constexpr (sized_range<_Range2>) + __n2 = ranges::size(__r2); + return _S_impl(ranges::begin(__r1), ranges::end(__r1), __n1, + ranges::begin(__r2), ranges::end(__r2), __n2, + std::move(__pred), + std::move(__proj1), std::move(__proj2)); + } + + private: + template<typename _Iter1, typename _Sent1, typename _Iter2, typename _Sent2, + typename _Pred, + typename _Proj1, typename _Proj2> + static constexpr bool + _S_impl(_Iter1 __first1, _Sent1 __last1, iter_difference_t<_Iter1> __n1, + _Iter2 __first2, _Sent2 __last2, iter_difference_t<_Iter2> __n2, + _Pred __pred, _Proj1 __proj1, _Proj2 __proj2) + { + if (__first2 == __last2) [[unlikely]] + return true; + else if (__n1 == -1 || __n2 == -1) + return ranges::mismatch(std::move(__first1), __last1, + std::move(__first2), __last2, + std::move(__pred), + std::move(__proj1), std::move(__proj2)).in2 == __last2; + else if (__n1 < __n2) + return false; + else if constexpr (random_access_iterator<_Iter1>) + return ranges::equal(__first1, __first1 + iter_difference_t<_Iter1>(__n2), + std::move(__first2), __last2, + std::move(__pred), + std::move(__proj1), std::move(__proj2)); + else + return ranges::equal(counted_iterator(std::move(__first1), + iter_difference_t<_Iter1>(__n2)), + default_sentinel, + std::move(__first2), __last2, + std::move(__pred), + std::move(__proj1), std::move(__proj2)); + } + + friend struct __ends_with_fn; + }; + + inline constexpr __starts_with_fn starts_with{}; + + struct __ends_with_fn + { + template<input_iterator _Iter1, sentinel_for<_Iter1> _Sent1, + input_iterator _Iter2, sentinel_for<_Iter2> _Sent2, + typename _Pred = ranges::equal_to, + typename _Proj1 = identity, typename _Proj2 = identity> + requires (forward_iterator<_Iter1> || sized_sentinel_for<_Sent1, _Iter1>) + && (forward_iterator<_Iter2> || sized_sentinel_for<_Sent2, _Iter2>) + && indirectly_comparable<_Iter1, _Iter2, _Pred, _Proj1, _Proj2> + constexpr bool + operator()(_Iter1 __first1, _Sent1 __last1, + _Iter2 __first2, _Sent2 __last2, _Pred __pred = {}, + _Proj1 __proj1 = {}, _Proj2 __proj2 = {}) const + { + iter_difference_t<_Iter1> __n1 = -1; + iter_difference_t<_Iter2> __n2 = -1; + if constexpr (sized_sentinel_for<_Sent1, _Iter1>) + __n1 = __last1 - __first1; + if constexpr (sized_sentinel_for<_Sent2, _Iter2>) + __n2 = __last2 - __first2; + return _S_impl(std::move(__first1), __last1, __n1, + std::move(__first2), __last2, __n2, + std::move(__pred), + std::move(__proj1), std::move(__proj2)); + } + + template<input_range _Range1, input_range _Range2, + typename _Pred = ranges::equal_to, + typename _Proj1 = identity, typename _Proj2 = identity> + requires (forward_range<_Range1> || sized_range<_Range1>) + && (forward_range<_Range2> || sized_range<_Range2>) + && indirectly_comparable<iterator_t<_Range1>, iterator_t<_Range2>, + _Pred, _Proj1, _Proj2> + constexpr bool + operator()(_Range1&& __r1, _Range2&& __r2, _Pred __pred = {}, + _Proj1 __proj1 = {}, _Proj2 __proj2 = {}) const + { + range_difference_t<_Range1> __n1 = -1; + range_difference_t<_Range2> __n2 = -1; + if constexpr (sized_range<_Range1>) + __n1 = ranges::size(__r1); + if constexpr (sized_range<_Range2>) + __n2 = ranges::size(__r2); + return _S_impl(ranges::begin(__r1), ranges::end(__r1), __n1, + ranges::begin(__r2), ranges::end(__r2), __n2, + std::move(__pred), + std::move(__proj1), std::move(__proj2)); + } + + private: + template<typename _Iter1, typename _Sent1, + typename _Iter2, typename _Sent2, + typename _Pred, + typename _Proj1, typename _Proj2> + static constexpr bool + _S_impl(_Iter1 __first1, _Sent1 __last1, iter_difference_t<_Iter1> __n1, + _Iter2 __first2, _Sent2 __last2, iter_difference_t<_Iter2> __n2, + _Pred __pred, _Proj1 __proj1, _Proj2 __proj2) + { + if constexpr (!random_access_iterator<_Iter1> + && bidirectional_iterator<_Iter1> && same_as<_Iter1, _Sent1> + && bidirectional_iterator<_Iter2> && same_as<_Iter2, _Sent2>) + return starts_with._S_impl(std::make_reverse_iterator(__last1), + std::make_reverse_iterator(__first1), + __n1, + std::make_reverse_iterator(__last2), + std::make_reverse_iterator(__first2), + __n2, + std::move(__pred), + std::move(__proj1), std::move(__proj2)); + + if (__first2 == __last2) [[unlikely]] + return true; + + if constexpr (forward_iterator<_Iter2>) + if (__n2 == -1) + __n2 = ranges::distance(__first2, __last2); + + // __glibcxx_assert(__n2 != -1); + + if (__n1 != -1) + { + if (__n1 < __n2) + return false; + auto __shift = __n1 - iter_difference_t<_Iter1>(__n2); + if (random_access_iterator<_Iter1> + || !bidirectional_iterator<_Iter1> + || !same_as<_Iter1, _Sent1> + || __shift < __n2) + { + ranges::advance(__first1, __shift); + return ranges::equal(std::move(__first1), __last1, + std::move(__first2), __last2, + std::move(__pred), + std::move(__proj1), std::move(__proj2)); + } + } + + if constexpr (bidirectional_iterator<_Iter1> && same_as<_Iter1, _Sent1>) + { + _Iter1 __it1 = __last1; + if (__n1 != -1) + ranges::advance(__it1, -iter_difference_t<_Iter1>(__n2)); + else + { + // We can't use ranges::advance if the haystack size is + // unknown, since we need to detect and return false if + // it's smaller than the needle. + iter_difference_t<_Iter2> __m = __n2; + while (__m != 0 && __it1 != __first1) + { + --__m; + --__it1; + } + if (__m != 0) + return false; + } + return ranges::equal(__it1, __last1, + std::move(__first2), __last2, + std::move(__pred), + std::move(__proj1), std::move(__proj2)); + } + else if constexpr (forward_iterator<_Iter1>) + { + // __glibcxx_assert(__n1 == -1); + _Iter1 __prev_first1; + __n1 = 0; + while (true) + { + iter_difference_t<_Iter2> __m = __n2; + _Iter1 __it1 = __first1; + while (__m != 0 && __it1 != __last1) + { + ++__n1; + --__m; + ++__it1; + } + if (__m != 0) + { + // __glibcxx_assert(__it1 == __last1); + if (__n1 < __n2) + return false; + __first1 = ranges::next(__prev_first1, + iter_difference_t<_Iter1>(__n2 - __m)); + break; + } + __prev_first1 = __first1; + __first1 = __it1; + } + return ranges::equal(__first1, __last1, + std::move(__first2), __last2, + std::move(__pred), + std::move(__proj1), std::move(__proj2)); + } + else + // If the haystack is non-forward then it must be sized, in which case + // we already returned via the __n1 != 1 case. + __builtin_unreachable(); + } + + }; + + inline constexpr __ends_with_fn ends_with{}; +#endif // __glibcxx_ranges_starts_ends_with + struct __find_end_fn { template<forward_iterator _Iter1, sentinel_for<_Iter1> _Sent1, diff --git a/libstdc++-v3/include/bits/ranges_base.h b/libstdc++-v3/include/bits/ranges_base.h index dde1649..c09f729 100644 --- a/libstdc++-v3/include/bits/ranges_base.h +++ b/libstdc++-v3/include/bits/ranges_base.h @@ -119,9 +119,9 @@ namespace ranges if constexpr (is_array_v<remove_reference_t<_Tp>>) return true; else if constexpr (__member_begin<_Tp>) - return noexcept(__decay_copy(std::declval<_Tp&>().begin())); + return noexcept(_GLIBCXX_AUTO_CAST(std::declval<_Tp&>().begin())); else - return noexcept(__decay_copy(begin(std::declval<_Tp&>()))); + return noexcept(_GLIBCXX_AUTO_CAST(begin(std::declval<_Tp&>()))); } public: @@ -146,7 +146,7 @@ namespace ranges template<typename _Tp> concept __member_end = requires(_Tp& __t) { - { __decay_copy(__t.end()) } -> sentinel_for<__range_iter_t<_Tp>>; + { _GLIBCXX_AUTO_CAST(__t.end()) } -> sentinel_for<__range_iter_t<_Tp>>; }; // Poison pill so that unqualified lookup doesn't find std::end. @@ -156,7 +156,7 @@ namespace ranges concept __adl_end = __class_or_enum<remove_reference_t<_Tp>> && requires(_Tp& __t) { - { __decay_copy(end(__t)) } -> sentinel_for<__range_iter_t<_Tp>>; + { _GLIBCXX_AUTO_CAST(end(__t)) } -> sentinel_for<__range_iter_t<_Tp>>; }; struct _End @@ -169,9 +169,9 @@ namespace ranges if constexpr (is_bounded_array_v<remove_reference_t<_Tp>>) return true; else if constexpr (__member_end<_Tp>) - return noexcept(__decay_copy(std::declval<_Tp&>().end())); + return noexcept(_GLIBCXX_AUTO_CAST(std::declval<_Tp&>().end())); else - return noexcept(__decay_copy(end(std::declval<_Tp&>()))); + return noexcept(_GLIBCXX_AUTO_CAST(end(std::declval<_Tp&>()))); } public: @@ -196,7 +196,7 @@ namespace ranges template<typename _Tp> concept __member_rbegin = requires(_Tp& __t) { - { __decay_copy(__t.rbegin()) } -> input_or_output_iterator; + { _GLIBCXX_AUTO_CAST(__t.rbegin()) } -> input_or_output_iterator; }; void rbegin() = delete; @@ -205,7 +205,7 @@ namespace ranges concept __adl_rbegin = __class_or_enum<remove_reference_t<_Tp>> && requires(_Tp& __t) { - { __decay_copy(rbegin(__t)) } -> input_or_output_iterator; + { _GLIBCXX_AUTO_CAST(rbegin(__t)) } -> input_or_output_iterator; }; template<typename _Tp> @@ -223,9 +223,9 @@ namespace ranges _S_noexcept() { if constexpr (__member_rbegin<_Tp>) - return noexcept(__decay_copy(std::declval<_Tp&>().rbegin())); + return noexcept(_GLIBCXX_AUTO_CAST(std::declval<_Tp&>().rbegin())); else if constexpr (__adl_rbegin<_Tp>) - return noexcept(__decay_copy(rbegin(std::declval<_Tp&>()))); + return noexcept(_GLIBCXX_AUTO_CAST(rbegin(std::declval<_Tp&>()))); else { if constexpr (noexcept(_End{}(std::declval<_Tp&>()))) @@ -258,7 +258,7 @@ namespace ranges template<typename _Tp> concept __member_rend = requires(_Tp& __t) { - { __decay_copy(__t.rend()) } + { _GLIBCXX_AUTO_CAST(__t.rend()) } -> sentinel_for<decltype(_RBegin{}(std::forward<_Tp>(__t)))>; }; @@ -268,7 +268,7 @@ namespace ranges concept __adl_rend = __class_or_enum<remove_reference_t<_Tp>> && requires(_Tp& __t) { - { __decay_copy(rend(__t)) } + { _GLIBCXX_AUTO_CAST(rend(__t)) } -> sentinel_for<decltype(_RBegin{}(std::forward<_Tp>(__t)))>; }; @@ -280,9 +280,9 @@ namespace ranges _S_noexcept() { if constexpr (__member_rend<_Tp>) - return noexcept(__decay_copy(std::declval<_Tp&>().rend())); + return noexcept(_GLIBCXX_AUTO_CAST(std::declval<_Tp&>().rend())); else if constexpr (__adl_rend<_Tp>) - return noexcept(__decay_copy(rend(std::declval<_Tp&>()))); + return noexcept(_GLIBCXX_AUTO_CAST(rend(std::declval<_Tp&>()))); else { if constexpr (noexcept(_Begin{}(std::declval<_Tp&>()))) @@ -316,7 +316,7 @@ namespace ranges concept __member_size = !disable_sized_range<remove_cvref_t<_Tp>> && requires(_Tp& __t) { - { __decay_copy(__t.size()) } -> __detail::__is_integer_like; + { _GLIBCXX_AUTO_CAST(__t.size()) } -> __detail::__is_integer_like; }; void size() = delete; @@ -326,7 +326,7 @@ namespace ranges && !disable_sized_range<remove_cvref_t<_Tp>> && requires(_Tp& __t) { - { __decay_copy(size(__t)) } -> __detail::__is_integer_like; + { _GLIBCXX_AUTO_CAST(size(__t)) } -> __detail::__is_integer_like; }; template<typename _Tp> @@ -351,9 +351,9 @@ namespace ranges if constexpr (is_bounded_array_v<remove_reference_t<_Tp>>) return true; else if constexpr (__member_size<_Tp>) - return noexcept(__decay_copy(std::declval<_Tp&>().size())); + return noexcept(_GLIBCXX_AUTO_CAST(std::declval<_Tp&>().size())); else if constexpr (__adl_size<_Tp>) - return noexcept(__decay_copy(size(std::declval<_Tp&>()))); + return noexcept(_GLIBCXX_AUTO_CAST(size(std::declval<_Tp&>()))); else if constexpr (__sentinel_size<_Tp>) return noexcept(_End{}(std::declval<_Tp&>()) - _Begin{}(std::declval<_Tp&>())); @@ -463,7 +463,7 @@ namespace ranges template<typename _Tp> concept __member_data = requires(_Tp& __t) { - { __decay_copy(__t.data()) } -> __pointer_to_object; + { _GLIBCXX_AUTO_CAST(__t.data()) } -> __pointer_to_object; }; template<typename _Tp> @@ -477,7 +477,7 @@ namespace ranges _S_noexcept() { if constexpr (__member_data<_Tp>) - return noexcept(__decay_copy(std::declval<_Tp&>().data())); + return noexcept(_GLIBCXX_AUTO_CAST(std::declval<_Tp&>().data())); else return noexcept(_Begin{}(std::declval<_Tp&>())); } diff --git a/libstdc++-v3/include/bits/semaphore_base.h b/libstdc++-v3/include/bits/semaphore_base.h index 5b5a1c9..3f7a33c 100644 --- a/libstdc++-v3/include/bits/semaphore_base.h +++ b/libstdc++-v3/include/bits/semaphore_base.h @@ -64,69 +64,100 @@ _GLIBCXX_BEGIN_NAMESPACE_VERSION __semaphore_base(const __semaphore_base&) = delete; __semaphore_base& operator=(const __semaphore_base&) = delete; - static _GLIBCXX_ALWAYS_INLINE __count_type - _S_get_current(__count_type* __counter) noexcept + // Load the current counter value. + _GLIBCXX_ALWAYS_INLINE __count_type + _M_get_current() const noexcept + { return __atomic_impl::load(&_M_counter, memory_order::acquire); } + + // Try to acquire the semaphore (i.e. decrement the counter). + // Returns false if the current counter is zero, or if another thread + // decrements the value first. In the latter case, __cur is set to the + // new value. + _GLIBCXX_ALWAYS_INLINE bool + _M_do_try_acquire(__count_type& __cur) noexcept { - return __atomic_impl::load(__counter, memory_order::acquire); - } - - static _GLIBCXX_ALWAYS_INLINE bool - _S_do_try_acquire(__count_type* __counter, __count_type __old) noexcept - { - if (__old == 0) - return false; + if (__cur == 0) + return false; // Cannot decrement when it's already zero. - return __atomic_impl::compare_exchange_strong(__counter, - __old, __old - 1, + return __atomic_impl::compare_exchange_strong(&_M_counter, + __cur, __cur - 1, memory_order::acquire, memory_order::relaxed); } - _GLIBCXX_ALWAYS_INLINE void + void _M_acquire() noexcept { - auto const __vfn = [this]{ return _S_get_current(&this->_M_counter); }; - auto const __pred = [this](__count_type __cur) { - return _S_do_try_acquire(&this->_M_counter, __cur); + auto const __vfn = [this]{ return _M_get_current(); }; + auto __val = __vfn(); + auto const __pred = [&__val](__count_type __cur) { + if (__cur > 0) + { + __val = __cur; + return true; + } + return false; }; - std::__atomic_wait_address(&_M_counter, __pred, __vfn, true); + while (!_M_do_try_acquire(__val)) + if (__val == 0) + std::__atomic_wait_address(&_M_counter, __pred, __vfn, true); } bool _M_try_acquire() noexcept { - auto const __vfn = [this]{ return _S_get_current(&this->_M_counter); }; - auto const __pred = [this](__count_type __cur) { - return _S_do_try_acquire(&this->_M_counter, __cur); - }; - using __detail::__wait_clock_t; - return std::__atomic_wait_address_for(&_M_counter, __pred, __vfn, - __wait_clock_t::duration(), - true); + // The fastest implementation of this function is just _M_do_try_acquire + // but that can fail under contention even when _M_count > 0. + // Using _M_try_acquire_for(0ns) will retry a few times in a loop. + return _M_try_acquire_for(__detail::__wait_clock_t::duration{}); } template<typename _Clock, typename _Duration> - _GLIBCXX_ALWAYS_INLINE bool + bool _M_try_acquire_until(const chrono::time_point<_Clock, _Duration>& __atime) noexcept { - auto const __vfn = [this]{ return _S_get_current(&this->_M_counter); }; - auto const __pred = [this](__count_type __cur) { - return _S_do_try_acquire(&this->_M_counter, __cur); + auto const __vfn = [this]{ return _M_get_current(); }; + auto __val = __vfn(); + auto const __pred = [&__val](__count_type __cur) { + if (__cur > 0) + { + __val = __cur; + return true; + } + return false; }; - return std::__atomic_wait_address_until(&_M_counter, __pred, __vfn, - __atime, true); + while (!_M_do_try_acquire(__val)) + if (__val == 0) + { + if (!std::__atomic_wait_address_until(&_M_counter, __pred, + __vfn, __atime, true)) + return false; // timed out + } + return true; } template<typename _Rep, typename _Period> - _GLIBCXX_ALWAYS_INLINE bool + bool _M_try_acquire_for(const chrono::duration<_Rep, _Period>& __rtime) noexcept { - auto const __vfn = [this]{ return _S_get_current(&this->_M_counter); }; - auto const __pred = [this](__count_type __cur) { - return _S_do_try_acquire(&this->_M_counter, __cur); + auto const __vfn = [this]{ return _M_get_current(); }; + auto __val = __vfn(); + auto const __pred = [&__val](__count_type __cur) { + if (__cur > 0) + { + __val = __cur; + return true; + } + return false; }; - return std::__atomic_wait_address_for(&_M_counter, __pred, __vfn, - __rtime, true); + while (!_M_do_try_acquire(__val)) + if (__val == 0) + { + if (!std::__atomic_wait_address_for(&_M_counter, __pred, + __vfn, __rtime, true)) + return false; // timed out + } + return true; } _GLIBCXX_ALWAYS_INLINE ptrdiff_t diff --git a/libstdc++-v3/include/bits/stl_vector.h b/libstdc++-v3/include/bits/stl_vector.h index 5c0c227..f2c1bce 100644 --- a/libstdc++-v3/include/bits/stl_vector.h +++ b/libstdc++-v3/include/bits/stl_vector.h @@ -372,8 +372,10 @@ _GLIBCXX_BEGIN_NAMESPACE_CONTAINER _GLIBCXX20_CONSTEXPR ~_Vector_base() _GLIBCXX_NOEXCEPT { - _M_deallocate(_M_impl._M_start, - _M_impl._M_end_of_storage - _M_impl._M_start); + ptrdiff_t __n = _M_impl._M_end_of_storage - _M_impl._M_start; + if (__n < 0) + __builtin_unreachable(); + _M_deallocate(_M_impl._M_start, size_t(__n)); } public: diff --git a/libstdc++-v3/include/bits/vector.tcc b/libstdc++-v3/include/bits/vector.tcc index 801d9f0..70ead1d 100644 --- a/libstdc++-v3/include/bits/vector.tcc +++ b/libstdc++-v3/include/bits/vector.tcc @@ -576,7 +576,7 @@ _GLIBCXX_BEGIN_NAMESPACE_CONTAINER __builtin_unreachable(); pointer __old_start = this->_M_impl._M_start; pointer __old_finish = this->_M_impl._M_finish; - const size_type __elems = end() - begin(); + const size_type __elems = size(); pointer __new_start(this->_M_allocate(__len)); pointer __new_finish(__new_start); diff --git a/libstdc++-v3/include/bits/version.def b/libstdc++-v3/include/bits/version.def index 5efe4d1..9ab22cc 100644 --- a/libstdc++-v3/include/bits/version.def +++ b/libstdc++-v3/include/bits/version.def @@ -1661,6 +1661,14 @@ ftms = { }; ftms = { + name = ranges_starts_ends_with; + values = { + v = 202106; + cxxmin = 23; + }; +}; + +ftms = { name = constexpr_bitset; values = { v = 202202; diff --git a/libstdc++-v3/include/bits/version.h b/libstdc++-v3/include/bits/version.h index 5e905da..371a7ba 100644 --- a/libstdc++-v3/include/bits/version.h +++ b/libstdc++-v3/include/bits/version.h @@ -1848,6 +1848,16 @@ #endif /* !defined(__cpp_lib_ranges_find_last) && defined(__glibcxx_want_ranges_find_last) */ #undef __glibcxx_want_ranges_find_last +#if !defined(__cpp_lib_ranges_starts_ends_with) +# if (__cplusplus >= 202100L) +# define __glibcxx_ranges_starts_ends_with 202106L +# if defined(__glibcxx_want_all) || defined(__glibcxx_want_ranges_starts_ends_with) +# define __cpp_lib_ranges_starts_ends_with 202106L +# endif +# endif +#endif /* !defined(__cpp_lib_ranges_starts_ends_with) && defined(__glibcxx_want_ranges_starts_ends_with) */ +#undef __glibcxx_want_ranges_starts_ends_with + #if !defined(__cpp_lib_constexpr_bitset) # if (__cplusplus >= 202100L) && _GLIBCXX_HOSTED && (__cpp_constexpr_dynamic_alloc) # define __glibcxx_constexpr_bitset 202202L diff --git a/libstdc++-v3/include/std/algorithm b/libstdc++-v3/include/std/algorithm index 321a5e2..1563cdf 100644 --- a/libstdc++-v3/include/std/algorithm +++ b/libstdc++-v3/include/std/algorithm @@ -74,6 +74,7 @@ #define __glibcxx_want_ranges_contains #define __glibcxx_want_ranges_find_last #define __glibcxx_want_ranges_fold +#define __glibcxx_want_ranges_starts_ends_with #define __glibcxx_want_robust_nonmodifying_seq_ops #define __glibcxx_want_sample #define __glibcxx_want_shift diff --git a/libstdc++-v3/include/std/bit b/libstdc++-v3/include/std/bit index 5187c96..fd75edf 100644 --- a/libstdc++-v3/include/std/bit +++ b/libstdc++-v3/include/std/bit @@ -166,7 +166,7 @@ _GLIBCXX_BEGIN_NAMESPACE_VERSION // Variant for power of two _Nd which the compiler can // easily pattern match. constexpr unsigned __uNd = _Nd; - const unsigned __r = __s; + const auto __r = static_cast<unsigned>(__s); return (__x << (__r % __uNd)) | (__x >> ((-__r) % __uNd)); } const int __r = __s % _Nd; @@ -188,7 +188,7 @@ _GLIBCXX_BEGIN_NAMESPACE_VERSION // Variant for power of two _Nd which the compiler can // easily pattern match. constexpr unsigned __uNd = _Nd; - const unsigned __r = __s; + const auto __r = static_cast<unsigned>(__s); return (__x >> (__r % __uNd)) | (__x << ((-__r) % __uNd)); } const int __r = __s % _Nd; diff --git a/libstdc++-v3/include/std/format b/libstdc++-v3/include/std/format index b4929d5..ec76ab0 100644 --- a/libstdc++-v3/include/std/format +++ b/libstdc++-v3/include/std/format @@ -2398,9 +2398,16 @@ namespace __format const size_t __r = __str.size() - __e; // Length of remainder. auto __overwrite = [&](_CharT* __p, size_t) { // Apply grouping to the digits before the radix or exponent. - auto __end = std::__add_grouping(__p, __np.thousands_sep(), + int __off = 0; + if (auto __c = __str.front(); __c == '-' || __c == '+' || __c == ' ') + { + *__p = __c; + __off = 1; + } + auto __end = std::__add_grouping(__p + __off, __np.thousands_sep(), __grp.data(), __grp.size(), - __str.data(), __str.data() + __e); + __str.data() + __off, + __str.data() + __e); if (__r) // If there's a fractional part or exponent { if (__d != __str.npos) diff --git a/libstdc++-v3/include/std/stop_token b/libstdc++-v3/include/std/stop_token index 1225b3a..775ec6a 100644 --- a/libstdc++-v3/include/std/stop_token +++ b/libstdc++-v3/include/std/stop_token @@ -34,8 +34,7 @@ #define __glibcxx_want_jthread #include <bits/version.h> -#if __cplusplus > 201703L - +#ifdef __glibcxx_jthread // C++ >= 20 #include <atomic> #include <bits/std_thread.h> @@ -650,6 +649,6 @@ _GLIBCXX_BEGIN_NAMESPACE_VERSION stop_callback(stop_token, _Callback) -> stop_callback<_Callback>; _GLIBCXX_END_NAMESPACE_VERSION -} // namespace -#endif // __cplusplus > 201703L +} // namespace std +#endif // __glibcxx_jthread #endif // _GLIBCXX_STOP_TOKEN diff --git a/libstdc++-v3/include/std/type_traits b/libstdc++-v3/include/std/type_traits index 6bf355d..c8907fe 100644 --- a/libstdc++-v3/include/std/type_traits +++ b/libstdc++-v3/include/std/type_traits @@ -1039,6 +1039,13 @@ _GLIBCXX_BEGIN_NAMESPACE_VERSION // Destructible and constructible type properties. +#if _GLIBCXX_USE_BUILTIN_TRAIT(__is_destructible) + /// is_destructible + template<typename _Tp> + struct is_destructible + : public __bool_constant<__is_destructible(_Tp)> + { }; +#else // In N3290 is_destructible does not say anything about function // types and abstract types, see LWG 2049. This implementation // describes function types as non-destructible and all complete @@ -1090,7 +1097,15 @@ _GLIBCXX_BEGIN_NAMESPACE_VERSION static_assert(std::__is_complete_or_unbounded(__type_identity<_Tp>{}), "template argument must be a complete class or an unbounded array"); }; +#endif +#if _GLIBCXX_USE_BUILTIN_TRAIT(__is_nothrow_destructible) + /// is_nothrow_destructible + template<typename _Tp> + struct is_nothrow_destructible + : public __bool_constant<__is_nothrow_destructible(_Tp)> + { }; +#else /// @cond undocumented // is_nothrow_destructible requires that is_destructible is @@ -1144,6 +1159,7 @@ _GLIBCXX_BEGIN_NAMESPACE_VERSION static_assert(std::__is_complete_or_unbounded(__type_identity<_Tp>{}), "template argument must be a complete class or an unbounded array"); }; +#endif /// @cond undocumented template<typename _Tp, typename... _Args> @@ -1451,6 +1467,13 @@ _GLIBCXX_BEGIN_NAMESPACE_VERSION "template argument must be a complete class or an unbounded array"); }; +#if _GLIBCXX_USE_BUILTIN_TRAIT(__is_trivially_destructible) + /// is_trivially_destructible + template<typename _Tp> + struct is_trivially_destructible + : public __bool_constant<__is_trivially_destructible(_Tp)> + { }; +#else /// is_trivially_destructible template<typename _Tp> struct is_trivially_destructible @@ -1460,7 +1483,7 @@ _GLIBCXX_BEGIN_NAMESPACE_VERSION static_assert(std::__is_complete_or_unbounded(__type_identity<_Tp>{}), "template argument must be a complete class or an unbounded array"); }; - +#endif /// has_virtual_destructor template<typename _Tp> @@ -3581,8 +3604,13 @@ template <typename _Tp> inline constexpr bool is_move_assignable_v = __is_assignable(__add_lval_ref_t<_Tp>, __add_rval_ref_t<_Tp>); +#if _GLIBCXX_USE_BUILTIN_TRAIT(__is_destructible) +template <typename _Tp> + inline constexpr bool is_destructible_v = __is_destructible(_Tp); +#else template <typename _Tp> inline constexpr bool is_destructible_v = is_destructible<_Tp>::value; +#endif template <typename _Tp, typename... _Args> inline constexpr bool is_trivially_constructible_v @@ -3609,7 +3637,11 @@ template <typename _Tp> = __is_trivially_assignable(__add_lval_ref_t<_Tp>, __add_rval_ref_t<_Tp>); -#if __cpp_concepts +#if _GLIBCXX_USE_BUILTIN_TRAIT(__is_trivially_destructible) +template <typename _Tp> + inline constexpr bool is_trivially_destructible_v + = __is_trivially_destructible(_Tp); +#elif __cpp_concepts template <typename _Tp> inline constexpr bool is_trivially_destructible_v = false; @@ -3654,9 +3686,15 @@ template <typename _Tp> inline constexpr bool is_nothrow_move_assignable_v = __is_nothrow_assignable(__add_lval_ref_t<_Tp>, __add_rval_ref_t<_Tp>); +#if _GLIBCXX_USE_BUILTIN_TRAIT(__is_nothrow_destructible) +template <typename _Tp> + inline constexpr bool is_nothrow_destructible_v + = __is_nothrow_destructible(_Tp); +#else template <typename _Tp> inline constexpr bool is_nothrow_destructible_v = is_nothrow_destructible<_Tp>::value; +#endif template <typename _Tp> inline constexpr bool has_virtual_destructor_v diff --git a/libstdc++-v3/src/c++20/atomic.cc b/libstdc++-v3/src/c++20/atomic.cc index a3ec92a..4120e1a 100644 --- a/libstdc++-v3/src/c++20/atomic.cc +++ b/libstdc++-v3/src/c++20/atomic.cc @@ -397,17 +397,18 @@ __cond_wait_until(__condvar& __cv, mutex& __mx, } #endif // ! HAVE_PLATFORM_TIMED_WAIT -// Like __spin_impl, always returns _M_has_val == true. +// Unlike __spin_impl, does not always return _M_has_val == true. +// If the deadline has already passed then no fresh value is loaded. __wait_result_type __spin_until_impl(const __platform_wait_t* __addr, const __wait_args_base& __args, const __wait_clock_t::time_point& __deadline) { - auto __t0 = __wait_clock_t::now(); using namespace literals::chrono_literals; - __platform_wait_t __val{}; - auto __now = __wait_clock_t::now(); + __wait_result_type __res{}; + auto __t0 = __wait_clock_t::now(); + auto __now = __t0; for (; __now < __deadline; __now = __wait_clock_t::now()) { auto __elapsed = __now - __t0; @@ -422,16 +423,21 @@ __spin_until_impl(const __platform_wait_t* __addr, __thread_yield(); else { - auto __res = __detail::__spin_impl(__addr, __args); + __res = __detail::__spin_impl(__addr, __args); if (!__res._M_timeout) return __res; } - __atomic_load(__addr, &__val, __args._M_order); - if (__val != __args._M_old) - return { ._M_val = __val, ._M_has_val = true, ._M_timeout = false }; + __atomic_load(__addr, &__res._M_val, __args._M_order); + __res._M_has_val = true; + if (__res._M_val != __args._M_old) + { + __res._M_timeout = false; + return __res; + } } - return { ._M_val = __val, ._M_has_val = true, ._M_timeout = true }; + __res._M_timeout = true; + return __res; } } // namespace diff --git a/libstdc++-v3/src/c++23/std.cc.in b/libstdc++-v3/src/c++23/std.cc.in index ba46853..4cd3e52 100644 --- a/libstdc++-v3/src/c++23/std.cc.in +++ b/libstdc++-v3/src/c++23/std.cc.in @@ -507,11 +507,14 @@ export namespace std using ranges::find_last_if; using ranges::find_last_if_not; #endif +#if __cpp_lib_ranges_starts_ends_with + using ranges::starts_with; + using ranges::ends_with; +#endif } } // 22.7.2 <any> -#if __cpp_lib_any export namespace std { using std::any; @@ -520,7 +523,6 @@ export namespace std using std::make_any; using std::swap; } -#endif // 24.3.2 <array> export namespace std @@ -698,7 +700,6 @@ export namespace std } // 29.2 <chrono> -#if __cpp_lib_chrono export namespace std { namespace chrono @@ -852,7 +853,6 @@ export namespace std::inline literals::inline chrono_literals export namespace std::chrono { using namespace literals::chrono_literals; } -#endif // __cpp_lib_chrono // <codecvt>: deprecated C++17, removed C++26 export namespace std @@ -864,7 +864,6 @@ export namespace std } // 17.11.1 <compare> -#if __cpp_lib_three_way_comparison export namespace std { using std::common_comparison_category; @@ -890,7 +889,6 @@ export namespace std using std::strong_order; using std::weak_order; } -#endif // __cpp_lib_three_way_comparison // 28.4 <complex> export namespace std @@ -944,7 +942,6 @@ export namespace std::inline literals::inline complex_literals } // 18 <concepts> -#if __cpp_lib_concepts export namespace std { using std::assignable_from; @@ -983,7 +980,6 @@ export namespace std using std::totally_ordered; using std::totally_ordered_with; } -#endif // 33.7 <condition_variable> export namespace std @@ -1960,6 +1956,14 @@ export namespace std using std::out_ptr; using std::inout_ptr; #endif +#if __cpp_lib_indirect + using std::indirect; + namespace pmr { using std::pmr::indirect; } +#endif +#if __cpp_lib_polymorphic + using std::polymorphic; + namespace pmr { using std::pmr::polymorphic; } +#endif } // 20.4 <memory_resource> diff --git a/libstdc++-v3/testsuite/20_util/system_clock/99832.cc b/libstdc++-v3/testsuite/20_util/system_clock/99832.cc new file mode 100644 index 0000000..693d4d6 --- /dev/null +++ b/libstdc++-v3/testsuite/20_util/system_clock/99832.cc @@ -0,0 +1,14 @@ +// { dg-options "-O0 -g0" } +// { dg-do compile { target c++20 } } +// { dg-final { scan-assembler-not "system_clock9to_time_t" } } + +// Bug libstdc++/99832 +// std::chrono::system_clock::to_time_t needs ABI tag for 32-bit time_t + +#include <chrono> + +std::time_t +test_pr99832(std::chrono::system_clock::time_point t) +{ + return std::chrono::system_clock::to_time_t(t); +} diff --git a/libstdc++-v3/testsuite/25_algorithms/ends_with/1.cc b/libstdc++-v3/testsuite/25_algorithms/ends_with/1.cc new file mode 100644 index 0000000..612c27a --- /dev/null +++ b/libstdc++-v3/testsuite/25_algorithms/ends_with/1.cc @@ -0,0 +1,165 @@ +// { dg-do run { target c++23 } } + +#include <algorithm> +#include <ranges> + +#include <testsuite_hooks.h> +#include <testsuite_iterators.h> + +namespace ranges = std::ranges; + +template<typename Range1, typename Range2> +void +test01() +{ + int n[] = {1,2,3,4,5,6,7,8,9,10}; + + Range1 haystack(n, n+10); + Range2 needle(n+7, n+10); + VERIFY( ranges::ends_with(haystack, needle) ); + + haystack = Range1(n); + needle = Range2(n, n+10); + VERIFY( ranges::ends_with(haystack, needle) ); + + haystack = Range1(n); + needle = Range2(n+6, n+9); + VERIFY( !ranges::ends_with(haystack, needle) ); + + haystack = Range1(n); + needle = Range2(n+6, n+9); + VERIFY( ranges::ends_with(haystack, needle, + [](int n, int m) { return std::abs(n - m) <= 1; }) ); + + haystack = Range1(n); + needle = Range2(n+6, n+9); + VERIFY( ranges::ends_with(haystack, needle, + ranges::equal_to{}, + [](int n) { return n - 1; }) ); + + haystack = Range1(n); + needle = Range2(n+6, n+9); + VERIFY( ranges::ends_with(haystack, needle, + ranges::equal_to{}, + std::identity{}, + [](int n) { return n + 1; }) ); + + haystack = Range1(n, n+5); + needle = Range2(n, n+10); + VERIFY( !ranges::ends_with(haystack, needle) ); +} + +template<typename Range1, typename Range2> +void +test02() +{ + int n[] = {1,2,3,4,5,6,7,8,9,10}; + + Range1 haystack(n, n+10); + Range2 needle(n+7, n+10); + VERIFY( ranges::ends_with(haystack.begin(), haystack.end(), + needle.begin(), needle.end()) ); + + haystack = Range1(n); + needle = Range2(n, n+10); + VERIFY( ranges::ends_with(haystack.begin(), haystack.end(), + needle.begin(), needle.end()) ); + + haystack = Range1(n); + needle = Range2(n+6, n+9); + VERIFY( !ranges::ends_with(haystack.begin(), haystack.end(), + needle.begin(), needle.end()) ); + + haystack = Range1(n); + needle = Range2(n+6, n+9); + VERIFY( ranges::ends_with(haystack.begin(), haystack.end(), + needle.begin(), needle.end(), + [](int n, int m) { return std::abs(n - m) <= 1; }) ); + + haystack = Range1(n); + needle = Range2(n+6, n+9); + VERIFY( ranges::ends_with(haystack.begin(), haystack.end(), + needle.begin(), needle.end(), + ranges::equal_to{}, + [](int n) { return n - 1; }) ); + + haystack = Range1(n); + needle = Range2(n+6, n+9); + VERIFY( ranges::ends_with(haystack.begin(), haystack.end(), + needle.begin(), needle.end(), + ranges::equal_to{}, + std::identity{}, + [](int n) { return n + 1; }) ); + + haystack = Range1(n, n+5); + needle = Range2(n, n+10); + VERIFY( !ranges::ends_with(haystack.begin(), haystack.end(), + needle.begin(), needle.end()) ); + + haystack = Range1(n, n+5); + needle = Range2(n+10, n+10); + VERIFY( ranges::ends_with(haystack.begin(), haystack.end(), + needle.begin(), needle.end()) ); +} + +void +test03() +{ + auto haystack = std::views::iota(0, 10); + auto needle = std::views::iota(5, 10); + +#if __SIZEOF_INT128__ + auto haystack_ict = std::views::iota(__int128(0), __int128(10)); + auto needle_ict = std::views::iota(__int128(5), __int128(10)); +#else + auto haystack_ict = std::views::iota(0ll, 10ll); + auto needle_ict = std::views::iota(5ll, 10ll); +#endif + + VERIFY( ranges::ends_with(haystack, needle_ict) ); + VERIFY( ranges::ends_with(haystack.begin(), haystack.end(), + needle_ict.begin(), needle_ict.end()) ); + + VERIFY( ranges::ends_with(haystack_ict, needle) ); + VERIFY( ranges::ends_with(haystack_ict.begin(), haystack_ict.end(), + needle.begin(), needle.end()) ); + + VERIFY( ranges::ends_with(haystack_ict, needle_ict) ); + VERIFY( ranges::ends_with(haystack_ict.begin(), haystack_ict.end(), + needle_ict.begin(), needle_ict.end()) ); +} + +int +main() +{ + using namespace __gnu_test; + using forward = test_forward_range<int>; + using bidirectional_common = bidirectional_container<int>; + using input_sized = test_input_sized_range<int>; + using input_sized_sent = test_sized_range_sized_sent<int, input_iterator_wrapper>; + using random_access = test_random_access_range<int>; + using random_access_sized = test_random_access_sized_range<int>; + using random_access_sized_sent = test_sized_range_sized_sent<int, random_access_iterator_wrapper>; + + test01<forward, forward>(); + test01<random_access, random_access>(); + test02<forward, forward>(); + test02<random_access, random_access>(); + + test01<bidirectional_common, bidirectional_common>(); + test02<bidirectional_common, bidirectional_common>(); + test01<bidirectional_common, forward>(); + test02<bidirectional_common, forward>(); + + test01<input_sized, input_sized>(); + test01<random_access_sized, random_access_sized>(); + // test02<input_sized, input_sized>(); constraint violation + test02<random_access_sized, random_access_sized>(); + + test01<input_sized_sent, input_sized_sent>(); + test01<random_access_sized_sent, random_access_sized_sent>(); + test02<input_sized_sent, input_sized_sent>(); + test02<random_access_sized_sent, random_access_sized_sent>(); + + test03(); +} diff --git a/libstdc++-v3/testsuite/25_algorithms/starts_with/1.cc b/libstdc++-v3/testsuite/25_algorithms/starts_with/1.cc new file mode 100644 index 0000000..0c288d8 --- /dev/null +++ b/libstdc++-v3/testsuite/25_algorithms/starts_with/1.cc @@ -0,0 +1,158 @@ +// { dg-do run { target c++23 } } + +#include <algorithm> +#include <ranges> + +#include <testsuite_hooks.h> +#include <testsuite_iterators.h> + +namespace ranges = std::ranges; + +template<typename Range1, typename Range2> +void +test01() +{ + int n[] = {1,2,3,4,5,6,7,8,9,10}; + + Range1 haystack(n, n+10); + Range2 needle(n, n+3); + VERIFY( ranges::starts_with(haystack, needle) ); + + haystack = Range1(n); + needle = Range2(n, n+10); + VERIFY( ranges::starts_with(haystack, needle) ); + + haystack = Range1(n); + needle = Range2(n+1, n+4); + VERIFY( !ranges::starts_with(haystack, needle) ); + + haystack = Range1(n); + needle = Range2(n+1, n+4); + VERIFY( ranges::starts_with(haystack, needle, + [](int n, int m) { return std::abs(n - m) <= 1; }) ); + + haystack = Range1(n); + needle = Range2(n+1, n+4); + VERIFY( ranges::starts_with(haystack, needle, + ranges::equal_to{}, + [](int n) { return n + 1; }) ); + + haystack = Range1(n); + needle = Range2(n+1, n+4); + VERIFY( ranges::starts_with(haystack, needle, + ranges::equal_to{}, + std::identity{}, + [](int n) { return n - 1; }) ); + + haystack = Range1(n, n+5); + needle = Range2(n, n+10); + VERIFY( !ranges::starts_with(haystack, needle) ); + + haystack = Range1(n, n+5); + needle = Range2(n+10, n+10); + VERIFY( ranges::starts_with(haystack, needle) ); +} + +template<typename Range1, typename Range2> +void +test02() +{ + int n[] = {1,2,3,4,5,6,7,8,9,10}; + + Range1 haystack(n, n+10); + Range2 needle(n, n+3); + VERIFY( ranges::starts_with(haystack.begin(), haystack.end(), + needle.begin(), needle.end()) ); + + haystack = Range1(n); + needle = Range2(n, n+10); + VERIFY( ranges::starts_with(haystack.begin(), haystack.end(), + needle.begin(), needle.end()) ); + + haystack = Range1(n); + needle = Range2(n+1, n+4); + VERIFY( !ranges::starts_with(haystack.begin(), haystack.end(), + needle.begin(), needle.end()) ); + + haystack = Range1(n); + needle = Range2(n+1, n+4); + VERIFY( ranges::starts_with(haystack.begin(), haystack.end(), + needle.begin(), needle.end(), + [](int n, int m) { return std::abs(n - m) <= 1; }) ); + + haystack = Range1(n); + needle = Range2(n+1, n+4); + VERIFY( ranges::starts_with(haystack.begin(), haystack.end(), + needle.begin(), needle.end(), + ranges::equal_to{}, + [](int n) { return n + 1; }) ); + + haystack = Range1(n); + needle = Range2(n+1, n+4); + VERIFY( ranges::starts_with(haystack.begin(), haystack.end(), + needle.begin(), needle.end(), + ranges::equal_to{}, + std::identity{}, + [](int n) { return n - 1; }) ); + + haystack = Range1(n, n+5); + needle = Range2(n, n+10); + VERIFY( !ranges::starts_with(haystack.begin(), haystack.end(), + needle.begin(), needle.end()) ); +} + +void +test03() +{ + auto haystack = std::views::iota(0, 10); + auto needle = std::views::iota(0, 5); + +#if __SIZEOF_INT128__ + auto haystack_ict = std::views::iota(__int128(0), __int128(10)); + auto needle_ict = std::views::iota(__int128(0), __int128(5)); +#else + auto haystack_ict = std::views::iota(0ll, 10ll); + auto needle_ict = std::views::iota(0ll, 5ll); +#endif + + VERIFY( ranges::starts_with(haystack, needle_ict) ); + VERIFY( ranges::starts_with(haystack.begin(), haystack.end(), + needle_ict.begin(), needle_ict.end()) ); + + VERIFY( ranges::starts_with(haystack_ict, needle) ); + VERIFY( ranges::starts_with(haystack_ict.begin(), haystack_ict.end(), + needle.begin(), needle.end()) ); + + VERIFY( ranges::starts_with(haystack_ict, needle_ict) ); + VERIFY( ranges::starts_with(haystack_ict.begin(), haystack_ict.end(), + needle_ict.begin(), needle_ict.end()) ); +} + +int +main() +{ + using namespace __gnu_test; + using input = test_input_range<int>; + using input_sized = test_input_sized_range<int>; + using input_sized_sent = test_sized_range_sized_sent<int, input_iterator_wrapper>; + using random_access = test_random_access_range<int>; + using random_access_sized = test_random_access_sized_range<int>; + using random_access_sized_sent = test_sized_range_sized_sent<int, random_access_iterator_wrapper>; + + test01<input, input>(); + test01<random_access, random_access>(); + test02<input, input>(); + test02<random_access, random_access>(); + + test01<input_sized, input_sized>(); + test01<random_access_sized, random_access_sized>(); + test02<input_sized, input_sized>(); + test02<random_access_sized, random_access_sized>(); + + test01<input_sized_sent, input_sized_sent>(); + test01<random_access_sized_sent, random_access_sized_sent>(); + test02<input_sized_sent, input_sized_sent>(); + test02<random_access_sized_sent, random_access_sized_sent>(); + + test03(); +} diff --git a/libstdc++-v3/testsuite/30_threads/semaphore/104928-2.cc b/libstdc++-v3/testsuite/30_threads/semaphore/104928-2.cc new file mode 100644 index 0000000..7b90da8 --- /dev/null +++ b/libstdc++-v3/testsuite/30_threads/semaphore/104928-2.cc @@ -0,0 +1,101 @@ +// { dg-do run { target c++20 } } +// { dg-additional-options "-pthread" { target pthread } } +// { dg-require-gthreads "" } +// { dg-add-options libatomic } + +// Bug libstdc++/104928 - std::counting_semaphore on Linux can sleep forever + +#include <semaphore> +#include <thread> +#include <chrono> +#include <atomic> + +std::binary_semaphore t1(1); +std::binary_semaphore sem2(0); +std::atomic<int> room1 = 0; +int room2 = 0; + +std::atomic<bool> run{true}; + +enum class AcquireKind { Acquire, Try, TryFor }; + +template<std::ptrdiff_t N, AcquireKind Kind> +struct Morris +{ + using Semaphore = std::counting_semaphore<N>; + + Semaphore sem1{1}; + Semaphore sem2{0}; + unsigned counter = 0; + + void operator()() + { + while (run) + { + room1 += 1; + + acquire(sem1); + room2 += 1; + room1 -= 1; + if (room1 == 0) + sem2.release(); + else + sem1.release(); + + acquire(sem2); + room2 -= 1; + + // critical region + ++counter; + // end critical region + + if (room2 == 0) + sem1.release(); + else + sem2.release(); + } + } + + void acquire(Semaphore& sem) + { + using enum AcquireKind; + using namespace std::chrono; + if constexpr (Kind == Acquire) + sem.acquire(); + else if constexpr (Kind == Try) + while (!sem.try_acquire()) { } + else if constexpr (Kind == TryFor) + while (!sem.try_acquire_for(1h)) { } + } +}; + +template<std::ptrdiff_t N, AcquireKind Kind> +void +test_morris_kind() +{ + Morris<N, Kind> algo; + std::thread t1(std::ref(algo)); + std::thread t2(std::ref(algo)); + std::this_thread::sleep_for(std::chrono::seconds(2)); + run = false; + t1.join(); + t2.join(); +} + +template<std::ptrdiff_t N> +void +test_morris() +{ + test_morris_kind<N, AcquireKind::Acquire>(); + test_morris_kind<N, AcquireKind::Try>(); + test_morris_kind<N, AcquireKind::TryFor>(); +} + +int main() +{ + test_morris<1>(); // std::binary_semaphore + test_morris<1000>(); // std::counting_semaphore that can use futex +#if PTRDIFF_MAX > INT_MAX + // test_morris<PTRDIFF_MAX>(); // std::counting_semaphore that cannot use futex +#endif +} diff --git a/libstdc++-v3/testsuite/30_threads/semaphore/104928.cc b/libstdc++-v3/testsuite/30_threads/semaphore/104928.cc new file mode 100644 index 0000000..f360da9 --- /dev/null +++ b/libstdc++-v3/testsuite/30_threads/semaphore/104928.cc @@ -0,0 +1,70 @@ +// { dg-do run { target c++20 } } +// { dg-additional-options "-pthread" { target pthread } } +// { dg-require-gthreads "" } +// { dg-add-options libatomic } +// { dg-options "-DSIMULATOR_TEST" { target simulator } } + +// Bug libstdc++/104928 - std::counting_semaphore on Linux can sleep forever + +#include <semaphore> +#include <thread> +#include <chrono> +#include <climits> + +#ifdef SIMULATOR_TEST +const int loop_count = 100; +const int thread_count = 6; +#else +const int loop_count = 1000000; +const int thread_count = 20; +#endif + +template<std::ptrdiff_t N, typename Acquire> +void +test_acquire(Acquire acq_func) +{ + std::counting_semaphore<N * loop_count> s{0}; + std::thread threads[thread_count]; + for (int i = 0; i < thread_count; i += 2) { + threads[i] = std::thread([&s, &acq_func]() { + for (int i = 0; i < loop_count; ++i) + acq_func(s); + }); + threads[i+1] = std::thread([&s]() { + for (int i = 0; i < loop_count; ++i) + s.release(); + }); + } + for (auto& t : threads) + t.join(); +} + +template<typename Acquire> +void +test_all(Acquire f) +{ + const int max = INT_MAX / loop_count; + test_acquire<max>(f); // can use futex +#if PTRDIFF_MAX > INT_MAX + test_acquire<max * 10>(f); // cannot use futex +#endif +} + +int main() +{ + test_all([](auto& sem) { sem.acquire(); }); + + test_all([](auto& sem) { while (!sem.try_acquire()) { } }); + + using namespace std::chrono; + + test_all([](auto& sem) { while (!sem.try_acquire_for(1h)) { } }); + + auto try_acquire_until = [](auto& sem, auto time) { + while (!sem.try_acquire_until(time + 1h)) + { } + }; + test_all([&](auto& sem) { try_acquire_until(sem, system_clock::now()); }); + test_all([&](auto& sem) { try_acquire_until(sem, steady_clock::now()); }); + test_all([&](auto& sem) { try_acquire_until(sem, utc_clock::now()); }); +} diff --git a/libstdc++-v3/testsuite/std/format/functions/format.cc b/libstdc++-v3/testsuite/std/format/functions/format.cc index e4adf3a..d342114 100644 --- a/libstdc++-v3/testsuite/std/format/functions/format.cc +++ b/libstdc++-v3/testsuite/std/format/functions/format.cc @@ -261,6 +261,16 @@ test_locale() s = std::format(eloc, "{0:Le} {0:Lf} {0:Lg}", -nan); VERIFY( s == "-nan -nan -nan" ); + // PR libstdc++/120548 format confuses a negative sign for a thousands digit + s = std::format(bloc, "{:L}", -123.45); + VERIFY( s == "-123.45" ); + s = std::format(bloc, "{:-L}", -876543.21); + VERIFY( s == "-876,543.21" ); + s = std::format(bloc, "{:+L}", 333.22); + VERIFY( s == "+333.22" ); + s = std::format(bloc, "{: L}", 999.44); + VERIFY( s == " 999.44" ); + // Restore std::locale::global(cloc); } diff --git a/libstdc++-v3/testsuite/std/time/format/empty_spec.cc b/libstdc++-v3/testsuite/std/time/format/empty_spec.cc index 322faa1..48f61ee 100644 --- a/libstdc++-v3/testsuite/std/time/format/empty_spec.cc +++ b/libstdc++-v3/testsuite/std/time/format/empty_spec.cc @@ -1,7 +1,9 @@ // { dg-do run { target c++20 } } +// { dg-require-effective-target hosted } // { dg-timeout-factor 2 } #include <chrono> +#include <ranges> #include <sstream> #include <testsuite_hooks.h> @@ -10,6 +12,46 @@ using namespace std::chrono; #define WIDEN_(C, S) ::std::__format::_Widen<C>(S, L##S) #define WIDEN(S) WIDEN_(_CharT, S) +template<typename CharT, typename T> +void +test_no_empty_spec() +{ + try + { + T t{}; + + if constexpr (std::is_same_v<CharT, char>) + (void)std::vformat("{}", std::make_format_args(t)); +#ifdef _GLIBCXX_USE_WCHAR_T + else + (void)std::vformat(L"{}", std::make_wformat_args(t)); +#endif // _GLIBCXX_USE_WCHAR_T + VERIFY(false); + } + catch (const std::format_error&) + { + VERIFY(true); + } +} + +template<typename T, typename _CharT> +void verify(const T& t, std::basic_string_view<_CharT> str) +{ + std::basic_string<_CharT> res; + + res = std::format(WIDEN("{}"), t); + VERIFY( res == str ); + + std::basic_stringstream<_CharT> os; + os << t; + res = std::move(os).str(); + VERIFY( res == str ); +} + +template<typename T, typename CharT> +void verify(const T& t, const CharT* str) +{ verify(t, std::basic_string_view<CharT>(str)); } + template<typename _CharT> void test_padding() @@ -35,18 +77,272 @@ test_padding() VERIFY( res == WIDEN("==16 is not a valid month==") ); } -template<typename T, typename _CharT> -void verify(const T& t, const _CharT* str) +template<typename Ret = void> +struct Rep +{ + using Return + = std::conditional_t<std::is_void_v<Ret>, Rep, Ret>; + + Rep(long v = 0) : val(v) {} + + operator long() const + { return val; } + + Return + operator+() const + { return val; } + + Rep + operator-() const + { return -val; } + + friend Rep + operator+(Rep lhs, Rep rhs) + { return lhs.val + rhs.val; } + + friend Rep + operator-(Rep lhs, Rep rhs) + { return lhs.val - rhs.val; } + + friend Rep + operator*(Rep lhs, Rep rhs) + { return lhs.val * rhs.val; } + + friend Rep + operator/(Rep lhs, Rep rhs) + { return lhs.val / rhs.val; } + + friend auto operator<=>(Rep, Rep) = default; + + template<typename _CharT> + friend std::basic_ostream<_CharT>& + operator<<(std::basic_ostream<_CharT>& os, const Rep& t) + { return os << t.val << WIDEN("[via <<]"); } + + long val; +}; + +template<typename Ret, typename Other> + requires std::is_integral_v<Other> +struct std::common_type<Rep<Ret>, Other> +{ + using type = Rep<Ret>; +}; + +template<typename Ret, typename Other> + requires std::is_integral_v<Other> +struct std::common_type<Other, Rep<Ret>> + : std::common_type<Rep<Ret>, Other> +{ }; + +template<typename Ret> +struct std::numeric_limits<Rep<Ret>> + : std::numeric_limits<long> +{ }; + +template<typename Ret, typename _CharT> +struct std::formatter<Rep<Ret>, _CharT> + : std::formatter<long, _CharT> +{ + template<typename Out> + typename std::basic_format_context<Out, _CharT>::iterator + format(const Rep<Ret>& t, std::basic_format_context<Out, _CharT>& ctx) const + { + constexpr std::basic_string_view<_CharT> suffix = WIDEN("[via format]"); + auto out = std::formatter<long, _CharT>::format(t.val, ctx); + return std::ranges::copy(suffix, out).out; + } +}; + +using deciseconds = duration<seconds::rep, std::deci>; + +template<typename _CharT> +void +test_duration() { std::basic_string<_CharT> res; - res = std::format(WIDEN("{}"), t); - VERIFY( res == str ); + const milliseconds di(40); + verify( di, WIDEN("40ms") ); + res = std::format(WIDEN("{:>6}"), di); + VERIFY( res == WIDEN(" 40ms") ); - std::basic_stringstream<_CharT> os; - os << t; - res = std::move(os).str(); - VERIFY( res == str ); + verify( -di, WIDEN("-40ms") ); + res = std::format(WIDEN("{:>6}"), -di); + VERIFY( res == WIDEN(" -40ms") ); + + const duration<double> df(11.22); + verify( df, WIDEN("11.22s") ); + res = std::format(WIDEN("{:=^12}"), df); + VERIFY( res == WIDEN("===11.22s===") ); + + verify( -df, WIDEN("-11.22s") ); + res = std::format(WIDEN("{:=^12}"), -df); + VERIFY( res == WIDEN("==-11.22s===") ); +} + +template<typename _CharT> +void +test_duration_cust() +{ + std::basic_string<_CharT> res; + const duration<char, std::ratio<1, 10>> charRep(123); + verify( charRep, WIDEN("123ds") ); + + // +asLong returns long, so formatted as long + const duration<Rep<long>> asLong(20); + verify( asLong, WIDEN("20s") ); + res = std::format(WIDEN("{:>6}"), asLong); + VERIFY( res == WIDEN(" 20s") ); + + verify( -asLong, WIDEN("-20s") ); + res = std::format(WIDEN("{:>6}"), -asLong); + VERIFY( res == WIDEN(" -20s") ); + + res = std::format(WIDEN("{:%Q}"), asLong); + VERIFY( res == WIDEN("20") ); + res = std::format(WIDEN("{:+<7%Q}"), asLong); + VERIFY( res == WIDEN("20+++++") ); + + // +asRep returns Rep<>, so formatted as Rep<> + const duration<Rep<>> asRep(10); + verify( asRep, WIDEN("10[via <<]s") ); + res = std::format(WIDEN("{:=^15}"), asRep); + VERIFY( res == WIDEN("==10[via <<]s==") ); + + verify( -asRep, WIDEN("-10[via <<]s") ); + res = std::format(WIDEN("{:=^15}"), -asRep); + VERIFY( res == WIDEN("=-10[via <<]s==") ); + + res = std::format(WIDEN("{:%Q}"), asRep); + VERIFY( res == WIDEN("10[via format]") ); + res = std::format(WIDEN("{:=^18%Q}"), asRep); + VERIFY( res == WIDEN("==10[via format]==") ); + + const duration<Rep<>, std::milli> milliRep(10); + verify( milliRep, WIDEN("10[via <<]ms") ); + res = std::format(WIDEN("{:=^15}"), milliRep); + VERIFY( res == WIDEN("=10[via <<]ms==") ); + + verify( -milliRep, WIDEN("-10[via <<]ms") ); + res = std::format(WIDEN("{:=^15}"), -milliRep); + VERIFY( res == WIDEN("=-10[via <<]ms=") ); + + res = std::format(WIDEN("{:%Q}"), milliRep); + VERIFY( res == WIDEN("10[via format]") ); + res = std::format(WIDEN("{:=^18%Q}"), milliRep); + VERIFY( res == WIDEN("==10[via format]==") ); +} + +template<typename Ratio, typename Rep, typename Period> +constexpr auto +hms(const duration<Rep, Period>& d) +{ + using Dur = duration<Rep, typename Ratio::period>; + return hh_mm_ss<Dur>(duration_cast<Dur>(d)); +} + +template<typename _CharT> +void +test_hh_mm_ss() +{ + auto dt = 22h + 24min + 54s + 111222333ns; + verify( hms<nanoseconds>(dt), + WIDEN("22:24:54.111222333") ); + verify( hms<microseconds>(dt), + WIDEN("22:24:54.111222") ); + verify( hms<milliseconds>(dt), + WIDEN("22:24:54.111") ); + verify( hms<deciseconds>(dt), + WIDEN("22:24:54.1") ); + verify( hms<seconds>(dt), + WIDEN("22:24:54") ); + verify( hms<minutes>(dt), + WIDEN("22:24:00") ); + verify( hms<hours>(dt), + WIDEN("22:00:00") ); + verify( hms<nanoseconds>(-dt), + WIDEN("-22:24:54.111222333") ); + verify( hms<microseconds>(-dt), + WIDEN("-22:24:54.111222") ); + verify( hms<milliseconds>(-dt), + WIDEN("-22:24:54.111") ); + verify( hms<deciseconds>(-dt), + WIDEN("-22:24:54.1") ); + verify( hms<seconds>(-dt), + WIDEN("-22:24:54") ); + verify( hms<minutes>(-dt), + WIDEN("-22:24:00") ); + verify( hms<hours>(-dt), + WIDEN("-22:00:00") ); + + verify( hms<nanoseconds>(-dt), + WIDEN("-22:24:54.111222333") ); + + dt += 300h; + verify( hms<nanoseconds>(dt), + WIDEN("322:24:54.111222333") ); + verify( hms<nanoseconds>(-dt), + WIDEN("-322:24:54.111222333") ); + + dt += 14000h; + verify( hms<nanoseconds>(dt), + WIDEN("14322:24:54.111222333") ); + verify( hms<nanoseconds>(-dt), + WIDEN("-14322:24:54.111222333") ); +} + +template<typename _CharT> +void +test_hh_mm_ss_cust() +{ + const duration<char, deciseconds::period> charRep(123); + verify( hms<deciseconds>(charRep), + WIDEN("00:00:12.3") ); + verify( hms<seconds>(charRep), + WIDEN("00:00:12") ); + + auto dt = 22h + 24min + 54s + 123ms; + // +plus returns long, so formatted as long + const duration<Rep<long>, std::milli> asLong(dt.count()); + verify( hms<milliseconds>(asLong), + WIDEN("22:24:54.123[via format]") ); + verify( hms<deciseconds>(asLong), + WIDEN("22:24:54.1[via format]") ); + verify( hms<seconds>(asLong), + WIDEN("22:24:54") ); + verify( hms<milliseconds>(-asLong), + WIDEN("-22:24:54.123[via format]") ); + verify( hms<deciseconds>(-asLong), + WIDEN("-22:24:54.1[via format]") ); + verify( hms<seconds>(-asLong), + WIDEN("-22:24:54") ); + + // +asRep returns Rep<>, so formatted as Rep<> + const duration<Rep<>, std::milli> asRep(dt.count()); + verify( hms<milliseconds>(asRep), + WIDEN("22:24:54.123[via format]") ); + verify( hms<deciseconds>(asRep), + WIDEN("22:24:54.1[via format]") ); + verify( hms<seconds>(asLong), + WIDEN("22:24:54") ); + verify( hms<milliseconds>(-asLong), + WIDEN("-22:24:54.123[via format]") ); + verify( hms<deciseconds>(-asLong), + WIDEN("-22:24:54.1[via format]") ); + verify( hms<seconds>(-asLong), + WIDEN("-22:24:54") ); +} + +template<typename CharT> +void +test_durations() +{ + test_duration<CharT>(); + test_duration_cust<CharT>(); + + test_hh_mm_ss<CharT>(); + test_hh_mm_ss_cust<CharT>(); } template<typename _CharT> @@ -196,19 +492,15 @@ test_year_month_day() verify( year(2024)/month(1)/30, WIDEN("2024-01-30") ); verify( year(-100)/month(14)/1, - // Should be -0100-14-01 - WIDEN("-100-14-01 is not a valid date") ); + WIDEN("-0100-14-01 is not a valid date") ); verify( year(2025)/month(11)/100, - // Should be 2025-11-100 ? - WIDEN("2025-11-99 is not a valid date") ); + WIDEN("2025-11-100 is not a valid date") ); verify( year(-32768)/month(2)/10, WIDEN("-32768-02-10 is not a valid date") ); verify( year(-32768)/month(212)/10, - // Should be 32768-212-10? - WIDEN("-32768-84-10 is not a valid date") ); + WIDEN("-32768-212-10 is not a valid date") ); verify( year(-32768)/month(2)/105, - // Should be 32768-02-99? - WIDEN("-32768-02-99 is not a valid date") ); + WIDEN("-32768-02-105 is not a valid date") ); verify( year(-32768)/month(14)/55, WIDEN("-32768-14-55 is not a valid date") ); } @@ -283,12 +575,171 @@ test_calendar() test_year_month_weekday_last<CharT>(); } +template<typename Clock, typename Dur, typename Dur2> +constexpr auto +wall_cast(const local_time<Dur2>& tp) +{ + using TP = time_point<Clock, std::common_type_t<Dur, days>>; + if constexpr (std::is_same_v<Clock, utc_clock> || std::is_same_v<Clock, file_clock>) + return clock_cast<Clock>(wall_cast<system_clock, Dur>(tp)); + else if constexpr (std::is_same_v<Clock, tai_clock>) + return TP(floor<Dur>(tp.time_since_epoch()) + days(4383)); + else if constexpr (std::is_same_v<Clock, gps_clock>) + return TP(floor<Dur>(tp.time_since_epoch()) - days(3657)); + else // system_clock, local_t + return time_point<Clock, Dur>(floor<Dur>(tp.time_since_epoch())); +} + +using decadays = duration<days::rep, std::ratio_multiply<std::deca, days::period>>; +using kilodays = duration<days::rep, std::ratio_multiply<std::kilo, days::period>>; + +template<typename _CharT, typename Clock> +void +test_time_point(bool daysAsTime) +{ + std::basic_string<_CharT> res; + + const auto lt = local_days(2024y/March/22) + 13h + 24min + 54s + 111222333ns; + auto strip_time = [daysAsTime](std::basic_string_view<_CharT> sv) + { return daysAsTime ? sv : sv.substr(0, 10); }; + + verify( wall_cast<Clock, nanoseconds>(lt), + WIDEN("2024-03-22 13:24:54.111222333") ); + verify( wall_cast<Clock, microseconds>(lt), + WIDEN("2024-03-22 13:24:54.111222") ); + verify( wall_cast<Clock, milliseconds>(lt), + WIDEN("2024-03-22 13:24:54.111") ); + verify( wall_cast<Clock, seconds>(lt), + WIDEN("2024-03-22 13:24:54") ); + verify( wall_cast<Clock, minutes>(lt), + WIDEN("2024-03-22 13:24:00") ); + verify( wall_cast<Clock, hours>(lt), + WIDEN("2024-03-22 13:00:00") ); + verify( wall_cast<Clock, days>(lt), + strip_time(WIDEN("2024-03-22 00:00:00")) ); + verify( wall_cast<Clock, decadays>(lt), + strip_time(WIDEN("2024-03-18 00:00:00")) ); + verify( wall_cast<Clock, kilodays>(lt), + strip_time(WIDEN("2022-01-08 00:00:00")) ); +} + +template<typename _CharT> +void +test_leap_second() +{ + std::basic_string<_CharT> res; + + const auto st = sys_days(2012y/June/30) + 23h + 59min + 59s + 111222333ns; + auto tp = clock_cast<utc_clock>(st); + tp += 1s; + + verify( floor<nanoseconds>(tp), + WIDEN("2012-06-30 23:59:60.111222333") ); + verify( floor<microseconds>(tp), + WIDEN("2012-06-30 23:59:60.111222") ); + verify( floor<milliseconds>(tp), + WIDEN("2012-06-30 23:59:60.111") ); + verify( floor<seconds>(tp), + WIDEN("2012-06-30 23:59:60") ); +} + +#if _GLIBCXX_USE_CXX11_ABI +template<typename Dur, typename Dur2> +auto +make_zoned(const sys_time<Dur2>& st, const time_zone* tz) +{ return zoned_time<Dur>(tz, floor<Dur>(st)); } + +template<typename _CharT> +void +test_zoned_time() +{ + const auto st = sys_days(2024y/March/22) + 13h + 24min + 54s + 111222333ns; + const time_zone* tz = locate_zone("Europe/Sofia"); + VERIFY( tz != nullptr ); + + verify( make_zoned<nanoseconds>(st, tz), + WIDEN("2024-03-22 15:24:54.111222333 EET") ); + verify( make_zoned<microseconds>(st, tz), + WIDEN("2024-03-22 15:24:54.111222 EET") ); + verify( make_zoned<milliseconds>(st, tz), + WIDEN("2024-03-22 15:24:54.111 EET") ); + verify( make_zoned<seconds>(st, tz), + WIDEN("2024-03-22 15:24:54 EET") ); + verify( make_zoned<minutes>(st, tz), + WIDEN("2024-03-22 15:24:00 EET") ); + verify( make_zoned<hours>(st, tz), + WIDEN("2024-03-22 15:00:00 EET") ); + verify( make_zoned<days>(st, tz), + WIDEN("2024-03-22 02:00:00 EET") ); + verify( make_zoned<decadays>(st, tz), + WIDEN("2024-03-18 02:00:00 EET") ); + verify( make_zoned<kilodays>(st, tz), + WIDEN("2022-01-08 02:00:00 EET") ); +} +#endif + +template<typename Dur, typename Dur2> +auto +local_fmt(const local_time<Dur2>& lt, std::string* zone) +{ return local_time_format(floor<Dur>(lt), zone); } + +template<typename _CharT> +void +test_local_time_format() +{ + std::basic_string<_CharT> res; + + std::string abbrev = "Zone"; + const auto lt = local_days(2024y/March/22) + 13h + 24min + 54s + 111222333ns; + + res = std::format(WIDEN("{}"), local_fmt<nanoseconds>(lt, &abbrev)); + VERIFY( res == WIDEN("2024-03-22 13:24:54.111222333 Zone") ); + res = std::format(WIDEN("{}"), local_fmt<microseconds>(lt, &abbrev)); + VERIFY( res == WIDEN("2024-03-22 13:24:54.111222 Zone") ); + res = std::format(WIDEN("{}"), local_fmt<milliseconds>(lt, &abbrev)); + VERIFY( res == WIDEN("2024-03-22 13:24:54.111 Zone") ); + res = std::format(WIDEN("{}"), local_fmt<seconds>(lt, &abbrev)); + VERIFY( res == WIDEN("2024-03-22 13:24:54 Zone") ); + res = std::format(WIDEN("{}"), local_fmt<minutes>(lt, &abbrev)); + VERIFY( res == WIDEN("2024-03-22 13:24:00 Zone") ); + res = std::format(WIDEN("{}"), local_fmt<hours>(lt, &abbrev)); + VERIFY( res == WIDEN("2024-03-22 13:00:00 Zone") ); + res = std::format(WIDEN("{}"), local_fmt<days>(lt, &abbrev)); + VERIFY( res == WIDEN("2024-03-22 00:00:00 Zone") ); + res = std::format(WIDEN("{}"), local_fmt<decadays>(lt, &abbrev)); + VERIFY( res == WIDEN("2024-03-18 00:00:00 Zone") ); + res = std::format(WIDEN("{}"), local_fmt<kilodays>(lt, &abbrev)); + VERIFY( res == WIDEN("2022-01-08 00:00:00 Zone") ); +} + +template<typename CharT> +void +test_time_points() +{ + test_time_point<CharT, local_t>(false); + test_time_point<CharT, system_clock>(false); + test_time_point<CharT, utc_clock>(true); + test_time_point<CharT, tai_clock>(true); + test_time_point<CharT, gps_clock>(true); + test_time_point<CharT, file_clock>(true); + test_leap_second<CharT>(); +#if _GLIBCXX_USE_CXX11_ABI + test_zoned_time<CharT>(); +#endif + test_local_time_format<CharT>(); + + test_no_empty_spec<CharT, sys_time<years>>(); + test_no_empty_spec<CharT, sys_time<duration<float>>>(); +} + template<typename CharT> void test_all() { test_padding<CharT>(); + test_durations<CharT>(); test_calendar<CharT>(); + test_time_points<CharT>(); } int main() diff --git a/libstdc++-v3/testsuite/std/time/format/pr120481.cc b/libstdc++-v3/testsuite/std/time/format/pr120481.cc new file mode 100644 index 0000000..5878c5b --- /dev/null +++ b/libstdc++-v3/testsuite/std/time/format/pr120481.cc @@ -0,0 +1,324 @@ +// { dg-do run { target c++23 } } +// { dg-options "-fexec-charset=UTF-8" } +// { dg-timeout-factor 2 } + +#include <algorithm> +#include <chrono> +#include <testsuite_hooks.h> + +#define WIDEN_(C, S) ::std::__format::_Widen<C>(S, L##S) +#define WIDEN(S) WIDEN_(_CharT, S) + +using namespace std::chrono; + +template<typename _CharT> +void +test_year() +{ + std::basic_string<_CharT> res; + + res = std::format(WIDEN("{:%Y}"), year(0)); + VERIFY( res == WIDEN("0000") ); + res = std::format(WIDEN("{:%C}"), year(0)); + VERIFY( res == WIDEN("00") ); + res = std::format(WIDEN("{:%y}"), year(0)); + VERIFY( res == WIDEN("00") ); + + res = std::format(WIDEN("{:%Y}"), year(5)); + VERIFY( res == WIDEN("0005") ); + res = std::format(WIDEN("{:%C}"), year(5)); + VERIFY( res == WIDEN("00") ); + res = std::format(WIDEN("{:%y}"), year(5)); + VERIFY( res == WIDEN("05") ); + res = std::format(WIDEN("{:%Y}"), year(-5)); + VERIFY( res == WIDEN("-0005") ); + res = std::format(WIDEN("{:%C}"), year(-5)); + VERIFY( res == WIDEN("-01") ); + res = std::format(WIDEN("{:%y}"), year(-5)); + VERIFY( res == WIDEN("05") ); + + res = std::format(WIDEN("{:%Y}"), year(213)); + VERIFY( res == WIDEN("0213") ); + res = std::format(WIDEN("{:%C}"), year(213)); + VERIFY( res == WIDEN("02") ); + res = std::format(WIDEN("{:%y}"), year(213)); + VERIFY( res == WIDEN("13") ); + res = std::format(WIDEN("{:%Y}"), year(-213)); + VERIFY( res == WIDEN("-0213") ); + res = std::format(WIDEN("{:%C}"), year(-213)); + VERIFY( res == WIDEN("-03") ); + res = std::format(WIDEN("{:%y}"), year(-213)); + VERIFY( res == WIDEN("13") ); + + res = std::format(WIDEN("{:%Y}"), year(7100)); + VERIFY( res == WIDEN("7100") ); + res = std::format(WIDEN("{:%C}"), year(7100)); + VERIFY( res == WIDEN("71") ); + res = std::format(WIDEN("{:%y}"), year(7100)); + VERIFY( res == WIDEN("00") ); + res = std::format(WIDEN("{:%Y}"), year(-7100)); + VERIFY( res == WIDEN("-7100") ); + res = std::format(WIDEN("{:%C}"), year(-7100)); + VERIFY( res == WIDEN("-71") ); + res = std::format(WIDEN("{:%y}"), year(-7100)); + VERIFY( res == WIDEN("00") ); + + res = std::format(WIDEN("{:%Y}"), year(12101)); + VERIFY( res == WIDEN("12101") ); + res = std::format(WIDEN("{:%C}"), year(12101)); + VERIFY( res == WIDEN("121") ); + res = std::format(WIDEN("{:%y}"), year(12101)); + VERIFY( res == WIDEN("01") ); + res = std::format(WIDEN("{:%Y}"), year(-12101)); + VERIFY( res == WIDEN("-12101") ); + res = std::format(WIDEN("{:%C}"), year(-12101)); + VERIFY( res == WIDEN("-122") ); + res = std::format(WIDEN("{:%y}"), year(-12101)); + VERIFY( res == WIDEN("01") ); +} + +template<typename _CharT> +void +test_month() +{ + std::basic_string<_CharT> res; + + res = std::format(WIDEN("{:%m}"), month(5)); + VERIFY( res == WIDEN("05") ); + res = std::format(WIDEN("{:%m}"), month(50)); + VERIFY( res == WIDEN("50") ); + res = std::format(WIDEN("{:%m}"), month(127)); + VERIFY( res == WIDEN("127") ); + res = std::format(WIDEN("{:%m}"), month(254)); + VERIFY( res == WIDEN("254") ); +} + +template<typename _CharT> +void +test_day() +{ + std::basic_string<_CharT> res; + + res = std::format(WIDEN("{:%d}"), day(3)); + VERIFY( res == WIDEN("03") ); + res = std::format(WIDEN("{:%d}"), day(22)); + VERIFY( res == WIDEN("22") ); + res = std::format(WIDEN("{:%d}"), day(100)); + VERIFY( res == WIDEN("100") ); + res = std::format(WIDEN("{:%d}"), day(207)); + VERIFY( res == WIDEN("207") ); + + res = std::format(WIDEN("{:%e}"), day(5)); + VERIFY( res == WIDEN(" 5") ); + res = std::format(WIDEN("{:%e}"), day(99)); + VERIFY( res == WIDEN("99") ); + res = std::format(WIDEN("{:%e}"), day(183)); + VERIFY( res == WIDEN("183") ); + res = std::format(WIDEN("{:%e}"), day(214)); + VERIFY( res == WIDEN("214") ); +} + +template<typename _CharT> +void +test_date() +{ + std::basic_string<_CharT> res; + + res = std::format(WIDEN("{:%F}"), year(-22)/month(10)/day(20)); + VERIFY( res == WIDEN("-0022-10-20") ); + res = std::format(WIDEN("{:%D}"), year(-22)/month(10)/day(20)); + VERIFY( res == WIDEN("10/20/22") ); + + res = std::format(WIDEN("{:%F}"), year(-2020)/month(123)/day(44)); + VERIFY( res == WIDEN("-2020-123-44") ); + res = std::format(WIDEN("{:%D}"), year(-2020)/month(123)/day(44)); + VERIFY( res == WIDEN("123/44/20") ); + + res = std::format(WIDEN("{:%F}"), year(-23404)/month(99)/day(223)); + VERIFY( res == WIDEN("-23404-99-223") ); + res = std::format(WIDEN("{:%D}"), year(-23404)/month(99)/day(223)); + VERIFY( res == WIDEN("99/223/04") ); + + res = std::format(WIDEN("{:%F}"), year(10000)/month(220)/day(100)); + VERIFY( res == WIDEN("10000-220-100") ); + res = std::format(WIDEN("{:%D}"), year(10000)/month(220)/day(100)); + VERIFY( res == WIDEN("220/100/00") ); +} + +template<typename _CharT> +void +test_weekday() +{ + std::basic_string<_CharT> res; + + res = std::format(WIDEN("{:%w}"), weekday(0)); + VERIFY( res == WIDEN("0") ); + res = std::format(WIDEN("{:%u}"), weekday(0)); + VERIFY( res == WIDEN("7") ); + + res = std::format(WIDEN("{:%w}"), weekday(7)); + VERIFY( res == WIDEN("0") ); + res = std::format(WIDEN("{:%u}"), weekday(7)); + VERIFY( res == WIDEN("7") ); + + res = std::format(WIDEN("{:%w}"), weekday(8)); + VERIFY( res == WIDEN("8") ); + res = std::format(WIDEN("{:%u}"), weekday(8)); + VERIFY( res == WIDEN("8") ); + + res = std::format(WIDEN("{:%w}"), weekday(10)); + VERIFY( res == WIDEN("10") ); + res = std::format(WIDEN("{:%u}"), weekday(10)); + VERIFY( res == WIDEN("10") ); + + res = std::format(WIDEN("{:%w}"), weekday(76)); + VERIFY( res == WIDEN("76") ); + res = std::format(WIDEN("{:%u}"), weekday(76)); + VERIFY( res == WIDEN("76") ); + + res = std::format(WIDEN("{:%w}"), weekday(100)); + VERIFY( res == WIDEN("100") ); + res = std::format(WIDEN("{:%u}"), weekday(100)); + VERIFY( res == WIDEN("100") ); + + res = std::format(WIDEN("{:%w}"), weekday(202)); + VERIFY( res == WIDEN("202") ); + res = std::format(WIDEN("{:%u}"), weekday(202)); + VERIFY( res == WIDEN("202") ); +} + +template<typename _CharT> +void +test_hour() +{ + std::basic_string<_CharT> res; + + res = std::format(WIDEN("{:%H}"), 0h + 5min + 6s); + VERIFY( res == WIDEN("00") ); + res = std::format(WIDEN("{:%R}"), 0h + 5min + 6s); + VERIFY( res == WIDEN("00:05") ); + res = std::format(WIDEN("{:%T}"), 0h + 5min + 6s); + VERIFY( res == WIDEN("00:05:06") ); + res = std::format(WIDEN("{:%I}"), 0h + 5min + 6s); + VERIFY( res == WIDEN("12") ); + res = std::format(WIDEN("{:%p}"), 0h + 5min + 6s); + VERIFY( res == WIDEN("AM") ); + + res = std::format(WIDEN("{:%H}"), 7h + 15min + 6s); + VERIFY( res == WIDEN("07") ); + res = std::format(WIDEN("{:%R}"), 7h + 15min + 6s); + VERIFY( res == WIDEN("07:15") ); + res = std::format(WIDEN("{:%T}"), 7h + 15min + 6s); + VERIFY( res == WIDEN("07:15:06") ); + res = std::format(WIDEN("{:%I}"), 7h + 15min + 6s); + VERIFY( res == WIDEN("07") ); + res = std::format(WIDEN("{:%p}"), 7h + 15min + 6s); + VERIFY( res == WIDEN("AM") ); + + res = std::format(WIDEN("{:%H}"), 15h + 55min + 26s); + VERIFY( res == WIDEN("15") ); + res = std::format(WIDEN("{:%R}"), 15h + 55min + 26s); + VERIFY( res == WIDEN("15:55") ); + res = std::format(WIDEN("{:%T}"), 15h + 55min + 26s); + VERIFY( res == WIDEN("15:55:26") ); + res = std::format(WIDEN("{:%I}"), 15h + 55min + 26s); + VERIFY( res == WIDEN("03") ); + res = std::format(WIDEN("{:%p}"), 15h + 55min + 26s); + VERIFY( res == WIDEN("PM") ); + + res = std::format(WIDEN("{:%H}"), 50h + 33min + 37s); + VERIFY( res == WIDEN("50") ); + res = std::format(WIDEN("{:%R}"), 50h + 33min + 37s); + VERIFY( res == WIDEN("50:33") ); + res = std::format(WIDEN("{:%T}"), 50h + 33min + 37s); + VERIFY( res == WIDEN("50:33:37") ); + res = std::format(WIDEN("{:%I}"), 50h + 33min + 37s); + VERIFY( res == WIDEN("02") ); + res = std::format(WIDEN("{:%p}"), 50h + 33min + 37s); + VERIFY( res == WIDEN("AM") ); + + res = std::format(WIDEN("{:%H}"), 100h + 21min + 48s); + VERIFY( res == WIDEN("100") ); + res = std::format(WIDEN("{:%R}"), 100h + 21min + 48s); + VERIFY( res == WIDEN("100:21") ); + res = std::format(WIDEN("{:%T}"), 100h + 21min + 48s); + VERIFY( res == WIDEN("100:21:48") ); + res = std::format(WIDEN("{:%I}"), 100h + 21min + 48s); + VERIFY( res == WIDEN("04") ); + res = std::format(WIDEN("{:%p}"), 100h + 21min + 48s); + VERIFY( res == WIDEN("AM") ); + + res = std::format(WIDEN("{:%H}"), 228h + 45min + 33s); + VERIFY( res == WIDEN("228") ); + res = std::format(WIDEN("{:%R}"), 228h + 45min + 33s); + VERIFY( res == WIDEN("228:45") ); + res = std::format(WIDEN("{:%T}"), 228h + 45min + 33s); + VERIFY( res == WIDEN("228:45:33") ); + res = std::format(WIDEN("{:%I}"), 228h + 4min + 33s); + VERIFY( res == WIDEN("12") ); + res = std::format(WIDEN("{:%p}"), 228h + 4min + 33s); + VERIFY( res == WIDEN("PM") ); + + res = std::format(WIDEN("{:%H}"), 1024h + 3min); + VERIFY( res == WIDEN("1024") ); + res = std::format(WIDEN("{:%R}"), 1024h + 3min); + VERIFY( res == WIDEN("1024:03") ); + res = std::format(WIDEN("{:%T}"), 1024h + 3min); + VERIFY( res == WIDEN("1024:03:00") ); + res = std::format(WIDEN("{:%I}"), 1024h + 3min); + VERIFY( res == WIDEN("04") ); + res = std::format(WIDEN("{:%p}"), 1024h + 3min); + VERIFY( res == WIDEN("PM") ); + + res = std::format(WIDEN("{:%H}"), 2039h); + VERIFY( res == WIDEN("2039") ); + res = std::format(WIDEN("{:%R}"), 2039h); + VERIFY( res == WIDEN("2039:00") ); + res = std::format(WIDEN("{:%T}"), 2039h); + VERIFY( res == WIDEN("2039:00:00") ); + res = std::format(WIDEN("{:%I}"), 2039h); + VERIFY( res == WIDEN("11") ); + res = std::format(WIDEN("{:%p}"), 2039h); + VERIFY( res == WIDEN("PM") ); + + res = std::format(WIDEN("{:%H}"), 22111h + 59min + 59s); + VERIFY( res == WIDEN("22111") ); + res = std::format(WIDEN("{:%R}"), 22111h + 59min + 59s); + VERIFY( res == WIDEN("22111:59") ); + res = std::format(WIDEN("{:%T}"), 22111h + 59min + 59s); + VERIFY( res == WIDEN("22111:59:59") ); + res = std::format(WIDEN("{:%I}"), 22111h + 59min + 59s); + VERIFY( res == WIDEN("07") ); + res = std::format(WIDEN("{:%p}"), 22111h + 59min + 59s); + VERIFY( res == WIDEN("AM") ); + + res = std::format(WIDEN("{:%H}"), -22111h - 59min - 59s); + VERIFY( res == WIDEN("-22111") ); + res = std::format(WIDEN("{:%R}"), -22111h - 59min - 59s); + VERIFY( res == WIDEN("-22111:59") ); + res = std::format(WIDEN("{:%T}"), -22111h - 59min - 59s); + VERIFY( res == WIDEN("-22111:59:59") ); + res = std::format(WIDEN("{:%I}"), -22111h - 59min - 59s); + VERIFY( res == WIDEN("-07") ); + res = std::format(WIDEN("{:%p}"), -22111h - 59min - 59s); + VERIFY( res == WIDEN("AM") ); +} + +int main() +{ + test_year<char>(); + test_month<char>(); + test_day<char>(); + test_date<char>(); + test_weekday<char>(); + test_hour<char>(); + +#ifdef _GLIBCXX_USE_WCHAR_T + test_year<wchar_t>(); + test_month<wchar_t>(); + test_day<wchar_t>(); + test_date<wchar_t>(); + test_weekday<wchar_t>(); + test_hour<wchar_t>(); +#endif // _GLIBCXX_USE_WCHAR_T +} |