diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index bafa761e5eb..a911edaab6d 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,19 @@ +2011-08-02 Robert Dewar + + * a-direct.adb, sinfo.ads, exp_ch9.adb, scng.adb, sem_util.adb, + sem_util.ads, restrict.ads, par-prag.adb: Minor reformatting and/or + code reorganization. + +2011-08-02 Robert Dewar + + * debug.adb: Debug flag d.P to suppress length comparison optimization + * exp_ch4.adb (Optimize_Length_Comparison): New routine to optimize + comparison of Length by comparing First/Last instead. + +2011-08-02 Matthew Heaney + + * a-cobove.ads: Code clean up. + 2011-08-02 Vincent Celier * adaint.c (file_names_case_sensitive_cache): New static int. diff --git a/gcc/ada/a-cobove.ads b/gcc/ada/a-cobove.ads index 30dc9aabfba..9fc7945da86 100644 --- a/gcc/ada/a-cobove.ads +++ b/gcc/ada/a-cobove.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2011, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -322,7 +322,7 @@ private function "=" (L, R : Elements_Array) return Boolean is abstract; type Vector (Capacity : Count_Type) is tagged record - Elements : Elements_Array (1 .. Capacity); + Elements : Elements_Array (1 .. Capacity) := (others => <>); Last : Extended_Index := No_Index; Busy : Natural := 0; Lock : Natural := 0; diff --git a/gcc/ada/a-direct.adb b/gcc/ada/a-direct.adb index 81b8dd5e860..6bb499ee2e8 100644 --- a/gcc/ada/a-direct.adb +++ b/gcc/ada/a-direct.adb @@ -39,23 +39,23 @@ with Ada.Unchecked_Conversion; with Ada.Unchecked_Deallocation; with Ada.Characters.Handling; use Ada.Characters.Handling; -with System.CRTL; use System.CRTL; -with System.OS_Constants; -with System.OS_Lib; use System.OS_Lib; -with System.Regexp; use System.Regexp; -with System.File_IO; use System.File_IO; -with System; +with System.CRTL; use System.CRTL; +with System.OS_Constants; use System.OS_Constants; +with System.OS_Lib; use System.OS_Lib; +with System.Regexp; use System.Regexp; +with System.File_IO; use System.File_IO; +with System; use System; package body Ada.Directories is Filename_Max : constant Integer := 1024; -- 1024 is the value of FILENAME_MAX in stdio.h - type Dir_Type_Value is new System.Address; + type Dir_Type_Value is new Address; -- This is the low-level address directory structure as returned by the C -- opendir routine. - No_Dir : constant Dir_Type_Value := Dir_Type_Value (System.Null_Address); + No_Dir : constant Dir_Type_Value := Dir_Type_Value (Null_Address); Dir_Separator : constant Character; pragma Import (C, Dir_Separator, "__gnat_dir_separator"); @@ -384,7 +384,7 @@ package body Ada.Directories is end; end if; - -- The implementation uses System.OS_Lib.Copy_File + -- Do actual copy using System.OS_Lib.Copy_File Copy_File (Source_Name, Target_Name, Success, Mode, Preserve); @@ -496,9 +496,7 @@ package body Ada.Directories is Path_Len : Natural := Max_Path; Buffer : String (1 .. 1 + Max_Path + 1); - procedure Local_Get_Current_Dir - (Dir : System.Address; - Length : System.Address); + procedure Local_Get_Current_Dir (Dir : Address; Length : Address); pragma Import (C, Local_Get_Current_Dir, "__gnat_get_current_dir"); begin @@ -563,7 +561,7 @@ package body Ada.Directories is raise Name_Error with "file """ & Name & """ does not exist"; else - -- The implementation uses System.OS_Lib.Delete_File + -- Do actual deletion using System.OS_Lib.Delete_File Delete_File (Name, Success); @@ -602,7 +600,7 @@ package body Ada.Directories is File_Name : constant String := Simple_Name (Dir_Ent); begin - if System.OS_Lib.Is_Directory (File_Name) then + if OS_Lib.Is_Directory (File_Name) then if File_Name /= "." and then File_Name /= ".." then Delete_Tree (File_Name); end if; @@ -698,7 +696,7 @@ package body Ada.Directories is Kind : File_Kind := Ordinary_File; -- Initialized to avoid a compilation warning - Filename_Addr : System.Address; + Filename_Addr : Address; Filename_Len : aliased Integer; Buffer : array (0 .. Filename_Max + 12) of Character; @@ -706,26 +704,24 @@ package body Ada.Directories is -- field for the filename. function readdir_gnat - (Directory : System.Address; - Buffer : System.Address; - Last : not null access Integer) return System.Address; + (Directory : Address; + Buffer : Address; + Last : not null access Integer) return Address; pragma Import (C, readdir_gnat, "__gnat_readdir"); - use System; - begin -- Search.Value.Is_Valid is always True when Fetch_Next_Entry is called loop Filename_Addr := readdir_gnat - (System.Address (Search.Value.Dir), + (Address (Search.Value.Dir), Buffer'Address, Filename_Len'Access); -- If no matching entry is found, set Is_Valid to False - if Filename_Addr = System.Null_Address then + if Filename_Addr = Null_Address then Search.Value.Is_Valid := False; exit; end if; @@ -801,7 +797,7 @@ package body Ada.Directories is ----------------- function File_Exists (Name : String) return Boolean is - function C_File_Exists (A : System.Address) return Integer; + function C_File_Exists (A : Address) return Integer; pragma Import (C, C_File_Exists, "__gnat_file_exists"); C_Name : String (1 .. Name'Length + 1); @@ -848,9 +844,11 @@ package body Ada.Directories is declare -- We need to resolve links because of A.16(47), since we must not - -- return alternative names for files + -- return alternative names for files. + Value : constant String := Normalize_Pathname (Name); subtype Result is String (1 .. Value'Length); + begin return Result (Value); end; @@ -1056,18 +1054,19 @@ package body Ada.Directories is & """ designates a file that already exists"; else - -- The implementation uses System.OS_Lib.Rename_File + -- Do actual rename using System.OS_Lib.Rename_File Rename_File (Old_Name, New_Name, Success); if not Success then + -- AI05-0231-1: Name_Error should be raised in case a directory -- component of New_Name does not exist (as in New_Name => -- "/no-such-dir/new-filename"). ENOENT indicates that. ENOENT -- also indicate that the Old_Name does not exist, but we already -- checked for that above. All other errors are Use_Error. - if Errno = System.OS_Constants.ENOENT then + if Errno = ENOENT then raise Name_Error with "file """ & Containing_Directory (New_Name) & """ not found"; @@ -1154,9 +1153,10 @@ package body Ada.Directories is Cut_End := Path'Last; Check_For_Standard_Dirs : declare - BN : constant String := Path (Cut_Start .. Cut_End); + BN : constant String := Path (Cut_Start .. Cut_End); + Has_Drive_Letter : constant Boolean := - System.OS_Lib.Path_Separator /= ':'; + OS_Lib.Path_Separator /= ':'; -- If Path separator is not ':' then we are on a DOS based OS -- where this character is used as a drive letter separator. @@ -1221,7 +1221,7 @@ package body Ada.Directories is function Size (Name : String) return File_Size is C_Name : String (1 .. Name'Length + 1); - function C_Size (Name : System.Address) return Long_Integer; + function C_Size (Name : Address) return Long_Integer; pragma Import (C, C_Size, "__gnat_named_file_length"); begin diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb index 8f386093957..65af4de796d 100644 --- a/gcc/ada/debug.adb +++ b/gcc/ada/debug.adb @@ -133,7 +133,7 @@ package body Debug is -- d.M -- d.N -- d.O Dump internal SCO tables - -- d.P + -- d.P Previous (non-optimized) handling of length comparisons -- d.Q -- d.R -- d.S Force Optimize_Alignment (Space) @@ -597,6 +597,11 @@ package body Debug is -- the ALI file, the internal SCO tables (SCO_Table/SCO_Unit_Table) -- are dumped for debugging purposes. + -- d.P Previous non-optimized handling of length comparisons. Setting this + -- flag inhibits the effect of Optimize_Length_Comparison in Exp_Ch4. + -- This is there in case we find a situation where the optimization + -- malfunctions, to provide a work around. + -- d.S Force Optimize_Alignment (Space) mode as the default -- d.T Force Optimize_Alignment (Time) mode as the default diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index ebf1a381aaa..abaf676b148 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, 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- -- @@ -202,6 +202,12 @@ package body Exp_Ch4 is -- constrained type (the caller has ensured this by using -- Convert_To_Actual_Subtype if necessary). + procedure Optimize_Length_Comparison (N : Node_Id); + -- Given an expression, if it is of the form X'Length op N (or the other + -- way round), where N is known at compile time to be 0 or 1, and X is a + -- simple entity, and op is a comparison operator, optimizes it into a + -- comparison of First and Last. + procedure Rewrite_Comparison (N : Node_Id); -- If N is the node for a comparison whose outcome can be determined at -- compile time, then the node N can be rewritten with True or False. If @@ -3197,9 +3203,9 @@ package body Exp_Ch4 is if Inside_A_Return_Statement (N) and then (Ekind (PtrT) = E_Anonymous_Access_Type - or else - (Ekind (PtrT) = E_Access_Type - and then No (Associated_Final_Chain (PtrT)))) + or else + (Ekind (PtrT) = E_Access_Type + and then No (Associated_Final_Chain (PtrT)))) then declare Decl : Node_Id; @@ -6055,6 +6061,8 @@ package body Exp_Ch4 is Expand_Vax_Comparison (N); return; end if; + + Optimize_Length_Comparison (N); end Expand_N_Op_Eq; ----------------------- @@ -6415,6 +6423,8 @@ package body Exp_Ch4 is Expand_Vax_Comparison (N); return; end if; + + Optimize_Length_Comparison (N); end Expand_N_Op_Ge; -------------------- @@ -6450,6 +6460,8 @@ package body Exp_Ch4 is Expand_Vax_Comparison (N); return; end if; + + Optimize_Length_Comparison (N); end Expand_N_Op_Gt; -------------------- @@ -6485,6 +6497,8 @@ package body Exp_Ch4 is Expand_Vax_Comparison (N); return; end if; + + Optimize_Length_Comparison (N); end Expand_N_Op_Le; -------------------- @@ -6520,6 +6534,8 @@ package body Exp_Ch4 is Expand_Vax_Comparison (N); return; end if; + + Optimize_Length_Comparison (N); end Expand_N_Op_Lt; ----------------------- @@ -6935,6 +6951,8 @@ package body Exp_Ch4 is Analyze_And_Resolve (N, Standard_Boolean); end; end if; + + Optimize_Length_Comparison (N); end Expand_N_Op_Ne; --------------------- @@ -10157,6 +10175,397 @@ package body Exp_Ch4 is return Func_Body; end Make_Boolean_Array_Op; + -------------------------------- + -- Optimize_Length_Comparison -- + -------------------------------- + + procedure Optimize_Length_Comparison (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Typ : constant Entity_Id := Etype (N); + Result : Node_Id; + + Left : Node_Id; + Right : Node_Id; + -- First and Last attribute reference nodes, which end up as left and + -- right operands of the optimized result. + + Is_Zero : Boolean; + -- True for comparison operand of zero + + Comp : Node_Id; + -- Comparison operand, set only if Is_Zero is false + + Ent : Entity_Id; + -- Entity whose length is being compared + + Index : Node_Id; + -- Integer_Literal node for length attribute expression, or Empty + -- if there is no such expression present. + + Ityp : Entity_Id; + -- Type of array index to which 'Length is applied + + Op : Node_Kind := Nkind (N); + -- Kind of comparison operator, gets flipped if operands backwards + + function Is_Optimizable (N : Node_Id) return Boolean; + -- Tests N to see if it is an optimizable comparison value (defined + -- as constant zero or one, or something else where the value is known + -- to be in range of 32-bits, and where the corresponding Length value + -- is also known to be 32-bits. If result is true, sets Is_Zero, Ityp, + -- and Comp accordingly. + + function Is_Entity_Length (N : Node_Id) return Boolean; + -- Tests if N is a length attribute applied to a simple entity. If so, + -- returns True, and sets Ent to the entity, and Index to the integer + -- literal provided as an attribute expression, or to Empty if none. + -- Also returns True if the expression is a generated type conversion + -- whose expression is of the desired form. This latter case arises + -- when Apply_Universal_Integer_Attribute_Check installs a conversion + -- to check for being in range, which is not needed in this context. + -- Returns False if neither condition holds. + + function Prepare_64 (N : Node_Id) return Node_Id; + -- Given a discrete expression, returns a Long_Long_Integer typed + -- expression representing the underlying value of the expression. + -- This is done with an unchecked conversion to the result type. We + -- use unchecked conversion to handle the enumeration type case. + + ---------------------- + -- Is_Entity_Length -- + ---------------------- + + function Is_Entity_Length (N : Node_Id) return Boolean is + begin + if Nkind (N) = N_Attribute_Reference + and then Attribute_Name (N) = Name_Length + and then Is_Entity_Name (Prefix (N)) + then + Ent := Entity (Prefix (N)); + + if Present (Expressions (N)) then + Index := First (Expressions (N)); + else + Index := Empty; + end if; + + return True; + + elsif Nkind (N) = N_Type_Conversion + and then not Comes_From_Source (N) + then + return Is_Entity_Length (Expression (N)); + + else + return False; + end if; + end Is_Entity_Length; + + -------------------- + -- Is_Optimizable -- + -------------------- + + function Is_Optimizable (N : Node_Id) return Boolean is + Val : Uint; + OK : Boolean; + Lo : Uint; + Hi : Uint; + Indx : Node_Id; + + begin + if Compile_Time_Known_Value (N) then + Val := Expr_Value (N); + + if Val = Uint_0 then + Is_Zero := True; + Comp := Empty; + return True; + + elsif Val = Uint_1 then + Is_Zero := False; + Comp := Empty; + return True; + end if; + end if; + + -- Here we have to make sure of being within 32-bits + + Determine_Range (N, OK, Lo, Hi, Assume_Valid => True); + + if not OK + or else Lo < UI_From_Int (Int'First) + or else Hi > UI_From_Int (Int'Last) + then + return False; + end if; + + -- Comparison value was within 32-bits, so now we must check the + -- index value to make sure it is also within 32-bits. + + Indx := First_Index (Etype (Ent)); + + if Present (Index) then + for J in 2 .. UI_To_Int (Intval (Index)) loop + Next_Index (Indx); + end loop; + end if; + + Ityp := Etype (Indx); + + if Esize (Ityp) > 32 then + return False; + end if; + + Is_Zero := False; + Comp := N; + return True; + end Is_Optimizable; + + ---------------- + -- Prepare_64 -- + ---------------- + + function Prepare_64 (N : Node_Id) return Node_Id is + begin + return Unchecked_Convert_To (Standard_Long_Long_Integer, N); + end Prepare_64; + + -- Start of processing for Optimize_Length_Comparison + + begin + -- Nothing to do if not a comparison + + if Op not in N_Op_Compare then + return; + end if; + + -- Nothing to do if special -gnatd.P debug flag set + + if Debug_Flag_Dot_PP then + return; + end if; + + -- Ent'Length op 0/1 + + if Is_Entity_Length (Left_Opnd (N)) + and then Is_Optimizable (Right_Opnd (N)) + then + null; + + -- 0/1 op Ent'Length + + elsif Is_Entity_Length (Right_Opnd (N)) + and then Is_Optimizable (Left_Opnd (N)) + then + -- Flip comparison to opposite sense + + case Op is + when N_Op_Lt => Op := N_Op_Gt; + when N_Op_Le => Op := N_Op_Ge; + when N_Op_Gt => Op := N_Op_Lt; + when N_Op_Ge => Op := N_Op_Le; + when others => null; + end case; + + -- Else optimization not possible + + else + return; + end if; + + -- Fall through if we will do the optimization + + -- Cases to handle: + + -- X'Length = 0 => X'First > X'Last + -- X'Length = 1 => X'First = X'Last + -- X'Length = n => X'First + (n - 1) = X'Last + + -- X'Length /= 0 => X'First <= X'Last + -- X'Length /= 1 => X'First /= X'Last + -- X'Length /= n => X'First + (n - 1) /= X'Last + + -- X'Length >= 0 => always true, warn + -- X'Length >= 1 => X'First <= X'Last + -- X'Length >= n => X'First + (n - 1) <= X'Last + + -- X'Length > 0 => X'First <= X'Last + -- X'Length > 1 => X'First < X'Last + -- X'Length > n => X'First + (n - 1) < X'Last + + -- X'Length <= 0 => X'First > X'Last (warn, could be =) + -- X'Length <= 1 => X'First >= X'Last + -- X'Length <= n => X'First + (n - 1) >= X'Last + + -- X'Length < 0 => always false (warn) + -- X'Length < 1 => X'First > X'Last + -- X'Length < n => X'First + (n - 1) > X'Last + + -- Note: for the cases of n (not constant 0,1), we require that the + -- corresponding index type be integer or shorter (i.e. not 64-bit), + -- and the same for the comparison value. Then we do the comparison + -- using 64-bit arithmetic (actually long long integer), so that we + -- cannot have overflow intefering with the result. + + -- First deal with warning cases + + if Is_Zero then + case Op is + + -- X'Length >= 0 + + when N_Op_Ge => + Rewrite (N, + Convert_To (Typ, New_Occurrence_Of (Standard_True, Loc))); + Analyze_And_Resolve (N, Typ); + Warn_On_Known_Condition (N); + return; + + -- X'Length < 0 + + when N_Op_Lt => + Rewrite (N, + Convert_To (Typ, New_Occurrence_Of (Standard_False, Loc))); + Analyze_And_Resolve (N, Typ); + Warn_On_Known_Condition (N); + return; + + when N_Op_Le => + if Constant_Condition_Warnings + and then Comes_From_Source (Original_Node (N)) + then + Error_Msg_N ("could replace by ""'=""?", N); + end if; + + Op := N_Op_Eq; + + when others => + null; + end case; + end if; + + -- Build the First reference we will use + + Left := + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Ent, Loc), + Attribute_Name => Name_First); + + if Present (Index) then + Set_Expressions (Left, New_List (New_Copy (Index))); + end if; + + -- If general value case, then do the addition of (n - 1), and + -- also add the needed conversions to type Long_Long_Integer. + + if Present (Comp) then + Left := + Make_Op_Add (Loc, + Left_Opnd => Prepare_64 (Left), + Right_Opnd => + Make_Op_Subtract (Loc, + Left_Opnd => Prepare_64 (Comp), + Right_Opnd => Make_Integer_Literal (Loc, 1))); + end if; + + -- Build the Last reference we will use + + Right := + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Ent, Loc), + Attribute_Name => Name_Last); + + if Present (Index) then + Set_Expressions (Right, New_List (New_Copy (Index))); + end if; + + -- If general operand, convert Last reference to Long_Long_Integer + + if Present (Comp) then + Right := Prepare_64 (Right); + end if; + + -- Check for cases to optimize + + -- X'Length = 0 => X'First > X'Last + -- X'Length < 1 => X'First > X'Last + -- X'Length < n => X'First + (n - 1) > X'Last + + if (Is_Zero and then Op = N_Op_Eq) + or else (not Is_Zero and then Op = N_Op_Lt) + then + Result := + Make_Op_Gt (Loc, + Left_Opnd => Left, + Right_Opnd => Right); + + -- X'Length = 1 => X'First = X'Last + -- X'Length = n => X'First + (n - 1) = X'Last + + elsif not Is_Zero and then Op = N_Op_Eq then + Result := + Make_Op_Eq (Loc, + Left_Opnd => Left, + Right_Opnd => Right); + + -- X'Length /= 0 => X'First <= X'Last + -- X'Length > 0 => X'First <= X'Last + + elsif Is_Zero and (Op = N_Op_Ne or else Op = N_Op_Gt) then + Result := + Make_Op_Le (Loc, + Left_Opnd => Left, + Right_Opnd => Right); + + -- X'Length /= 1 => X'First /= X'Last + -- X'Length /= n => X'First + (n - 1) /= X'Last + + elsif not Is_Zero and then Op = N_Op_Ne then + Result := + Make_Op_Ne (Loc, + Left_Opnd => Left, + Right_Opnd => Right); + + -- X'Length >= 1 => X'First <= X'Last + -- X'Length >= n => X'First + (n - 1) <= X'Last + + elsif not Is_Zero and then Op = N_Op_Ge then + Result := + Make_Op_Le (Loc, + Left_Opnd => Left, + Right_Opnd => Right); + + -- X'Length > 1 => X'First < X'Last + -- X'Length > n => X'First + (n = 1) < X'Last + + elsif not Is_Zero and then Op = N_Op_Gt then + Result := + Make_Op_Lt (Loc, + Left_Opnd => Left, + Right_Opnd => Right); + + -- X'Length <= 1 => X'First >= X'Last + -- X'Length <= n => X'First + (n - 1) >= X'Last + + elsif not Is_Zero and then Op = N_Op_Le then + Result := + Make_Op_Ge (Loc, + Left_Opnd => Left, + Right_Opnd => Right); + + -- Should not happen at this stage + + else + raise Program_Error; + end if; + + -- Rewrite and finish up + + Rewrite (N, Result); + Analyze_And_Resolve (N, Typ); + return; + end Optimize_Length_Comparison; + ------------------------ -- Rewrite_Comparison -- ------------------------ diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index ae92522f874..15db8b9668b 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -11516,7 +11516,7 @@ package body Exp_Ch9 is end if; -- If the type of the dispatching object is an access type then return - -- an explicit dereference + -- an explicit dereference. if Is_Access_Type (Etype (Object)) then Object := Make_Explicit_Dereference (Sloc (N), Object); diff --git a/gcc/ada/par-prag.adb b/gcc/ada/par-prag.adb index 6b5318f3385..f1320ec554e 100644 --- a/gcc/ada/par-prag.adb +++ b/gcc/ada/par-prag.adb @@ -89,13 +89,23 @@ function Prag (Pragma_Node : Node_Id; Semi : Source_Ptr) return Node_Id is procedure Process_Restrictions_Or_Restriction_Warnings; -- Common processing for Restrictions and Restriction_Warnings pragmas. - -- This routine processes the cases of No_Obsolescent_Features and SPARK, - -- which are the only restriction that have syntactic effects. In the case - -- of SPARK, it controls whether the scanner generates a token - -- Tok_SPARK_Hide for HIDE directives formatted as Ada comments. No general - -- error checking is done, since this will be done in Sem_Prag. The other - -- case processed is pragma Restrictions No_Dependence, since otherwise - -- this is done too late. + -- For the most part, restrictions need not be processed at parse time, + -- since they only affect semantic processing. This routine handles the + -- exceptions as follows + -- + -- No_Obsolescent_Features must be processed at parse time, since there + -- are some obsolescent features (e.g. character replacements) which are + -- handled at parse time. + -- + -- SPARK must be processed at parse time, since this restriction controls + -- whether the scanner recognizes a spark HIDE directive formatted as an + -- Ada comment (and generates a Tok_SPARK_Hide token for the directive). + -- + -- No_Dependence must be processed at parse time, since otherwise it gets + -- handled too late. + -- + -- Note that we don't need to do full error checking for badly formed cases + -- of restrictions, since these will be caught during semantic analysis. ---------- -- Arg1 -- @@ -232,10 +242,12 @@ function Prag (Pragma_Node : Node_Id; Semi : Source_Ptr) return Node_Id is Set_Restriction (No_Obsolescent_Features, Pragma_Node); Restriction_Warnings (No_Obsolescent_Features) := Prag_Id = Pragma_Restriction_Warnings; + when SPARK => Set_Restriction (SPARK, Pragma_Node); Restriction_Warnings (SPARK) := Prag_Id = Pragma_Restriction_Warnings; + when others => null; end case; diff --git a/gcc/ada/restrict.ads b/gcc/ada/restrict.ads index 5472d056ee1..92709c93526 100644 --- a/gcc/ada/restrict.ads +++ b/gcc/ada/restrict.ads @@ -178,9 +178,9 @@ package Restrict is -- SPARK Restriction Control -- ------------------------------- - -- SPARK HIDE directives allow turning off SPARK restriction for a - -- specified region of code, and the following tables are the data - -- structures used to keep track of these regions. + -- SPARK HIDE directives allow the effect of the SPARK restriction to be + -- turned off for a specified region of code, and the following tables are + -- the data structures used to keep track of these regions. -- The table contains pairs of source locations, the first being the start -- location for hidden region, and the second being the end location. diff --git a/gcc/ada/scng.adb b/gcc/ada/scng.adb index 73b8f393dca..f0bc9de8b27 100644 --- a/gcc/ada/scng.adb +++ b/gcc/ada/scng.adb @@ -1764,8 +1764,8 @@ package body Scng is return; end if; - -- Generate a token Tok_SPARK_Hide for a SPARK HIDE directive - -- only if the SPARK restriction is set for this unit. + -- If the SPARK restriction is set for this unit, then generate + -- a token Tok_SPARK_Hide for a SPARK HIDE directive. if Restriction_Check_Required (SPARK) and then Source (Start_Of_Comment) = '#' diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index a9a9100b504..8d8980e194b 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -2335,6 +2335,7 @@ package body Sem_Util is procedure Mark_Non_ALFA_Subprogram_Unconditional is Cur_Subp : constant Entity_Id := Current_Subprogram; + begin if Present (Cur_Subp) and then (Is_Subprogram (Cur_Subp) @@ -2344,6 +2345,9 @@ package body Sem_Util is -- then mark the subprogram as not in ALFA. Otherwise, mark the -- subprogram body as not in ALFA. + -- This comment just says what is done, but not why ??? and it + -- just repeats what is in the spec ??? + if In_Pre_Post_Expression then Set_Is_In_ALFA (Cur_Subp, False); else diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 938b03100cd..371afbb9103 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -279,10 +279,14 @@ package Sem_Util is procedure Mark_Non_ALFA_Subprogram; -- If Current_Subprogram is not Empty, mark either its specification or its - -- body as not being in ALFA. If called during the analysis of a - -- precondition or postcondition, as indicated by the flag + -- body as not being in ALFA. If this procedure is called during the + -- analysis of a precondition or postcondition, as indicated by the flag -- In_Pre_Post_Expression, mark the specification as not being in ALFA. -- Otherwise, mark the body as not being in ALFA. + -- + -- I would really like to see more comments on this peculiar processing + -- for precondition/postcondition, the comment above says what is done + -- but not why??? function Defining_Entity (N : Node_Id) return Entity_Id; -- Given a declaration N, returns the associated defining entity. If the diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index 88bcafbd125..48b138e4c7c 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -1116,7 +1116,7 @@ package Sinfo is -- this is required, see Exp_Ch11.Remove_Handler_Entries. -- Has_Dynamic_Length_Check (Flag10-Sem) - -- This flag is present on all expression nodes. It is set to indicate + -- This flag is present in all expression nodes. It is set to indicate -- that one of the routines in unit Checks has generated a length check -- action which has been inserted at the flagged node. This is used to -- avoid the generation of duplicate checks. @@ -1126,7 +1126,8 @@ package Sinfo is -- expression nodes. It is set to indicate that one of the routines in -- unit Checks has generated a range check action which has been inserted -- at the flagged node. This is used to avoid the generation of duplicate - -- checks. + -- checks. Why does this occur on N_Subtype_Declaration nodes, what does + -- it mean in that context??? -- Has_Local_Raise (Flag8-Sem) -- Present in exception handler nodes. Set if the handler can be entered