From 211e7410b32e6cb4b45d414883c5d6d5f37faa31 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Tue, 25 Apr 2017 17:54:39 +0200 Subject: [PATCH] [multiple changes] 2017-04-25 Arnaud Charlet * exp_ch4.adb (Expand_N_Case_Expression): Emit error message when generating C code on complex case expressions. 2017-04-25 Arnaud Charlet * sem_prag.adb (Analyze_Pragma): Generate a warning instead of silently ignoring pragma Ada_xxx in Latest_Ada_Only mode. * directio.ads, ioexcept.ads, sequenio.ads, text_io.ads: Use Ada_2012 instead of Ada_2005 to be compatible with the above change. * bindgen.adb: Silence new warning on pragma Ada_95. 2017-04-25 Hristian Kirtchev * checks.adb (Generate_Range_Check): Revert part of previous change. 2017-04-25 Ed Schonberg * sem_ch4.adb (Try_Container_Indexing): Handle properly a container indexing operation that appears as a an actual in a parameter association in a procedure call. 2017-04-25 Olivier Ramonat * prj-proc.adb, sem_util.adb, s-stposu.adb, sem_attr.adb, prj-conf.ads: Fix spelling mistakes. 2017-04-25 Bob Duff * types.ads, osint.adb, sinput-c.adb, sinput-d.adb, sinput-l.adb, * sinput-p.adb: Use regular fat pointers, with bounds checking, for source buffers. Fix misc obscure bugs. * sinput.ads, sinput.adb: Use regular fat pointers, with bounds checking, for source buffers. Modify representation clause for Source_File_Record as appropriate. Move Source_File_Index_Table from spec to body, because it is not used outside the body. Move Set_Source_File_Index_Table into the private part, because it is used only in the body and in children. Use trickery to modify the dope in the generic instantiation case. It's ugly, but not as ugly as the previous method. Fix documentation. Remove obsolete code. * fname-sf.adb, targparm.adb: Fix misc out-of-bounds indexing in source buffers. * fmap.adb: Avoid conversions from one string type to another. Remove a use of global name buffer. * osint.ads, sfn_scan.ads, sfn_scan.adb, sinput-c.ads: Comment fixes. From-SVN: r247252 --- gcc/ada/ChangeLog | 50 ++++++++ gcc/ada/bindgen.adb | 4 +- gcc/ada/checks.adb | 11 -- gcc/ada/directio.ads | 6 +- gcc/ada/exp_ch4.adb | 12 ++ gcc/ada/fmap.adb | 54 ++++---- gcc/ada/fname-sf.adb | 19 ++- gcc/ada/ioexcept.ads | 6 +- gcc/ada/namet.adb | 17 ++- gcc/ada/namet.ads | 3 +- gcc/ada/osint.adb | 42 ++---- gcc/ada/osint.ads | 7 +- gcc/ada/prj-conf.ads | 4 +- gcc/ada/prj-proc.adb | 4 +- gcc/ada/s-stposu.adb | 4 +- gcc/ada/sem_attr.adb | 4 +- gcc/ada/sem_ch4.adb | 107 ++++++++++------ gcc/ada/sem_prag.adb | 12 +- gcc/ada/sem_util.adb | 2 +- gcc/ada/sequenio.ads | 6 +- gcc/ada/sfn_scan.adb | 4 +- gcc/ada/sfn_scan.ads | 6 +- gcc/ada/sinput-c.adb | 53 +++----- gcc/ada/sinput-c.ads | 7 +- gcc/ada/sinput-d.adb | 25 +++- gcc/ada/sinput-l.adb | 116 +++++++---------- gcc/ada/sinput-p.adb | 47 ++----- gcc/ada/sinput.adb | 297 ++++++++++++++++++++++++------------------- gcc/ada/sinput.ads | 121 +++++++++--------- gcc/ada/targparm.adb | 226 ++++++++++++++++---------------- gcc/ada/text_io.ads | 6 +- gcc/ada/types.ads | 32 ++--- 32 files changed, 668 insertions(+), 646 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index c93ddcbe9b1..c31446dd2c5 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,53 @@ +2017-04-25 Arnaud Charlet + + * exp_ch4.adb (Expand_N_Case_Expression): Emit error message when + generating C code on complex case expressions. + +2017-04-25 Arnaud Charlet + + * sem_prag.adb (Analyze_Pragma): Generate a warning instead + of silently ignoring pragma Ada_xxx in Latest_Ada_Only mode. + * directio.ads, ioexcept.ads, sequenio.ads, text_io.ads: Use + Ada_2012 instead of Ada_2005 to be compatible with the above + change. + * bindgen.adb: Silence new warning on pragma Ada_95. + +2017-04-25 Hristian Kirtchev + + * checks.adb (Generate_Range_Check): Revert part of previous change. + +2017-04-25 Ed Schonberg + + * sem_ch4.adb (Try_Container_Indexing): Handle properly a + container indexing operation that appears as a an actual in a + parameter association in a procedure call. + +2017-04-25 Olivier Ramonat + + * prj-proc.adb, sem_util.adb, s-stposu.adb, sem_attr.adb, prj-conf.ads: + Fix spelling mistakes. + +2017-04-25 Bob Duff + + * types.ads, osint.adb, sinput-c.adb, sinput-d.adb, sinput-l.adb, + * sinput-p.adb: Use regular fat pointers, with bounds checking, + for source buffers. Fix misc obscure bugs. + * sinput.ads, sinput.adb: Use regular fat pointers, with bounds + checking, for source buffers. Modify representation clause for + Source_File_Record as appropriate. Move Source_File_Index_Table + from spec to body, because it is not used outside the body. + Move Set_Source_File_Index_Table into the private part, because + it is used only in the body and in children. Use trickery to + modify the dope in the generic instantiation case. It's ugly, + but not as ugly as the previous method. Fix documentation. + Remove obsolete code. + * fname-sf.adb, targparm.adb: Fix misc out-of-bounds + indexing in source buffers. + * fmap.adb: Avoid conversions from one string type to another. + Remove a use of global name buffer. + * osint.ads, sfn_scan.ads, sfn_scan.adb, sinput-c.ads: Comment + fixes. + 2017-04-25 Gary Dismukes * exp_util.adb, exp_ch4.adb: Minor reformatting. diff --git a/gcc/ada/bindgen.adb b/gcc/ada/bindgen.adb index 1757712e921..59b43e0c27e 100644 --- a/gcc/ada/bindgen.adb +++ b/gcc/ada/bindgen.adb @@ -2083,8 +2083,8 @@ package body Bindgen is -- handle use of Ada 2005 keywords as identifiers in Ada 95 mode. None -- of the Ada 2005 or Ada 2012 constructs are needed by the binder file. - WBI ("pragma Ada_95;"); WBI ("pragma Warnings (Off);"); + WBI ("pragma Ada_95;"); -- If we are operating in Restrictions (No_Exception_Handlers) mode, -- then we need to make sure that the binder program is compiled with @@ -2291,8 +2291,8 @@ package body Bindgen is -- handle use of Ada 2005 keywords as identifiers in Ada 95 mode. None -- of the Ada 2005/2012 constructs are needed by the binder file. - WBI ("pragma Ada_95;"); WBI ("pragma Warnings (Off);"); + WBI ("pragma Ada_95;"); -- Output Source_File_Name pragmas which look like diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 6f0dace3f9c..2833fff87a1 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -6697,20 +6697,9 @@ package body Checks is Set_Etype (N, Target_Base_Type); end Convert_And_Check_Range; - -- Local variables - - Checks_On : constant Boolean := - not Index_Checks_Suppressed (Target_Type) - or else - not Range_Checks_Suppressed (Target_Type); - -- Start of processing for Generate_Range_Check begin - if not Expander_Active or not Checks_On then - return; - end if; - -- First special case, if the source type is already within the range -- of the target type, then no check is needed (probably we should have -- stopped Do_Range_Check from being set in the first place, but better diff --git a/gcc/ada/directio.ads b/gcc/ada/directio.ads index c09f77270b9..6c0f9f50250 100644 --- a/gcc/ada/directio.ads +++ b/gcc/ada/directio.ads @@ -13,10 +13,10 @@ -- -- ------------------------------------------------------------------------------ -pragma Ada_2005; --- Explicit setting of Ada 2005 mode is required here, since we want to with a +pragma Ada_2012; +-- Explicit setting of Ada 2012 mode is required here, since we want to with a -- child unit (not possible in Ada 83 mode), and Direct_IO is not considered --- to be an internal unit that is automatically compiled in Ada 2005 mode +-- to be an internal unit that is automatically compiled in Ada 2012 mode -- (since a user is allowed to redeclare Direct_IO). with Ada.Direct_IO; diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index f54779956fa..e2446e1bfe7 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -4867,6 +4867,18 @@ package body Exp_Ch4 is -- type Ptr_Typ is access all Typ; else + if Generate_C_Code then + + -- We cannot ensure that correct C code will be generated if + -- any temporary is created down the line (to e.g. handle + -- checks or capture values) since we might end up with + -- dangling references to local variables, so better be safe + -- and reject the construct. + + Error_Msg_N + ("case expression too complex, use case statement instead", N); + end if; + Target_Typ := Make_Temporary (Loc, 'P'); Append_To (Acts, diff --git a/gcc/ada/fmap.adb b/gcc/ada/fmap.adb index 738d0acab08..d517c2a4ddc 100644 --- a/gcc/ada/fmap.adb +++ b/gcc/ada/fmap.adb @@ -45,9 +45,6 @@ package body Fmap is -- procedure Initialize, so that no attempt is made to open the mapping -- file in procedure Update_Mapping_File. - function To_Big_String_Ptr is new Unchecked_Conversion - (Source_Buffer_Ptr, Big_String_Ptr); - Max_Buffer : constant := 1_500; Buffer : String (1 .. Max_Buffer); -- Used to buffer output when writing to a new mapping file @@ -180,11 +177,9 @@ package body Fmap is procedure Initialize (File_Name : String) is Src : Source_Buffer_Ptr; Hi : Source_Ptr; - BS : Big_String_Ptr; - SP : String_Ptr; - First : Positive := 1; - Last : Natural := 0; + First : Source_Ptr := 1; + Last : Source_Ptr := 0; Uname : Unit_Name_Type; Fname : File_Name_Type; @@ -204,7 +199,7 @@ package body Fmap is -- the name buffer contains "/". procedure Get_Line; - -- Get a line from the mapping file, where a line is SP (First .. Last) + -- Get a line from the mapping file, where a line is Src (First .. Last) procedure Report_Truncated; -- Report a warning when the mapping file is truncated @@ -263,23 +258,23 @@ package body Fmap is -- If not at the end of file, skip the end of line - while First < SP'Last - and then (SP (First) = CR - or else SP (First) = LF - or else SP (First) = EOF) + while First < Src'Last + and then (Src (First) = CR + or else Src (First) = LF + or else Src (First) = EOF) loop First := First + 1; end loop; -- If not at the end of file, find the end of this new line - if First < SP'Last and then SP (First) /= EOF then + if First < Src'Last and then Src (First) /= EOF then Last := First; - while Last < SP'Last - and then SP (Last + 1) /= CR - and then SP (Last + 1) /= LF - and then SP (Last + 1) /= EOF + while Last < Src'Last + and then Src (Last + 1) /= CR + and then Src (Last + 1) /= LF + and then Src (Last + 1) /= EOF loop Last := Last + 1; end loop; @@ -302,9 +297,7 @@ package body Fmap is begin Empty_Tables; - Name_Len := File_Name'Length; - Name_Buffer (1 .. Name_Len) := File_Name; - Read_Source_File (Name_Enter, 0, Hi, Src, Config); + Read_Source_File (Name_Enter (File_Name), 1, Hi, Src, Config); if Null_Source_Buffer_Ptr (Src) then Write_Str ("warning: could not read mapping file """); @@ -313,9 +306,6 @@ package body Fmap is No_Mapping_File := True; else - BS := To_Big_String_Ptr (Src); - SP := BS (1 .. Natural (Hi))'Unrestricted_Access; - loop -- Get the unit name @@ -325,19 +315,19 @@ package body Fmap is exit when First > Last; - if (Last < First + 2) or else (SP (Last - 1) /= '%') - or else (SP (Last) /= 's' and then SP (Last) /= 'b') + if (Last < First + 2) or else (Src (Last - 1) /= '%') + or else (Src (Last) /= 's' and then Src (Last) /= 'b') then Write_Line ("warning: mapping file """ & File_Name & """ is incorrectly formatted"); - Write_Line ("Line = """ & SP (First .. Last) & '"'); + Write_Line ("Line = """ & String (Src (First .. Last)) & '"'); Empty_Tables; return; end if; - Name_Len := Last - First + 1; - Name_Buffer (1 .. Name_Len) := SP (First .. Last); + Name_Len := Integer (Last - First + 1); + Name_Buffer (1 .. Name_Len) := String (Src (First .. Last)); Uname := Find_Unit_Name; -- Get the file name @@ -352,8 +342,8 @@ package body Fmap is return; end if; - Name_Len := Last - First + 1; - Name_Buffer (1 .. Name_Len) := SP (First .. Last); + Name_Len := Integer (Last - First + 1); + Name_Buffer (1 .. Name_Len) := String (Src (First .. Last)); Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); Fname := Find_File_Name; @@ -369,8 +359,8 @@ package body Fmap is return; end if; - Name_Len := Last - First + 1; - Name_Buffer (1 .. Name_Len) := SP (First .. Last); + Name_Len := Integer (Last - First + 1); + Name_Buffer (1 .. Name_Len) := String (Src (First .. Last)); Pname := Find_File_Name; -- Add the mappings for this unit name diff --git a/gcc/ada/fname-sf.adb b/gcc/ada/fname-sf.adb index ea6a1a22174..be115bca0b7 100644 --- a/gcc/ada/fname-sf.adb +++ b/gcc/ada/fname-sf.adb @@ -34,9 +34,6 @@ with Unchecked_Conversion; package body Fname.SF is - function To_Big_String_Ptr is new Unchecked_Conversion - (Source_Buffer_Ptr, Big_String_Ptr); - ---------------------- -- Local Procedures -- ---------------------- @@ -66,19 +63,19 @@ package body Fname.SF is procedure Read_Source_File_Name_Pragmas is Src : Source_Buffer_Ptr; Hi : Source_Ptr; - BS : Big_String_Ptr; - SP : String_Ptr; begin - Name_Buffer (1 .. 8) := "gnat.adc"; - Name_Len := 8; - Read_Source_File (Name_Enter, 0, Hi, Src); + Read_Source_File (Name_Enter ("gnat.adc"), 1, Hi, Src); if not Null_Source_Buffer_Ptr (Src) then - BS := To_Big_String_Ptr (Src); - SP := BS (1 .. Natural (Hi))'Unrestricted_Access; + -- We need to strip off the trailing EOF that was added by + -- Read_Source_File, because there might be another EOF in + -- the file, and two in a row causes Scan_SFN_Pragmas to give + -- errors. + + pragma Assert (Src (Hi) = EOF); Scan_SFN_Pragmas - (SP.all, + (String (Src (1 .. Hi - 1)), Set_File_Name'Access, Set_File_Name_Pattern'Access); end if; diff --git a/gcc/ada/ioexcept.ads b/gcc/ada/ioexcept.ads index efdadc713c9..da467290814 100644 --- a/gcc/ada/ioexcept.ads +++ b/gcc/ada/ioexcept.ads @@ -13,11 +13,11 @@ -- -- ------------------------------------------------------------------------------ -pragma Ada_2005; --- Explicit setting of Ada 2005 mode is required here, since we want to with a +pragma Ada_2012; +-- Explicit setting of Ada 2012 mode is required here, since we want to with a -- child unit (not possible in Ada 83 mode), and IO_Exceptions is not -- considered to be an internal unit that is automatically compiled in Ada --- 2005 mode (since a user is allowed to redeclare IO_Exceptions). +-- 2012 mode (since a user is allowed to redeclare IO_Exceptions). with Ada.IO_Exceptions; diff --git a/gcc/ada/namet.adb b/gcc/ada/namet.adb index 6b9f61d8aa2..aed85313451 100644 --- a/gcc/ada/namet.adb +++ b/gcc/ada/namet.adb @@ -809,7 +809,7 @@ package body Namet is end Get_Name_String; function Get_Name_String (Id : Name_Id) return String is - Buf : Bounded_String; + Buf : Bounded_String (Max_Length => Natural (Length_Of_Name (Id))); begin Append (Buf, Id); return +Buf; @@ -1020,7 +1020,7 @@ package body Namet is end Is_Internal_Name; function Is_Internal_Name (Id : Name_Id) return Boolean is - Buf : Bounded_String; + Buf : Bounded_String (Max_Length => Natural (Length_Of_Name (Id))); begin if Id in Error_Name_Or_No_Name then return False; @@ -1132,6 +1132,13 @@ package body Namet is return Name_Entries.Last; end Name_Enter; + function Name_Enter (S : String) return Name_Id is + Buf : Bounded_String (Max_Length => S'Length); + begin + Append (Buf, S); + return Name_Enter (Buf); + end Name_Enter; + -------------------------- -- Name_Entries_Address -- -------------------------- @@ -1240,7 +1247,7 @@ package body Namet is end Name_Find; function Name_Find (S : String) return Name_Id is - Buf : Bounded_String; + Buf : Bounded_String (Max_Length => S'Length); begin Append (Buf, S); return Name_Find (Buf); @@ -1743,7 +1750,7 @@ package body Namet is else declare - Buf : Bounded_String; + Buf : Bounded_String (Max_Length => Natural (Length_Of_Name (Id))); begin Append (Buf, Id); Write_Str (Buf.Chars (1 .. Buf.Length)); @@ -1758,7 +1765,7 @@ package body Namet is ---------------- procedure Write_Name (Id : Name_Id) is - Buf : Bounded_String; + Buf : Bounded_String (Max_Length => Natural (Length_Of_Name (Id))); begin if Id >= First_Name_Id then Append (Buf, Id); diff --git a/gcc/ada/namet.ads b/gcc/ada/namet.ads index 0778ebecbfd..b2a2ed5fe81 100644 --- a/gcc/ada/namet.ads +++ b/gcc/ada/namet.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2017, 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- -- @@ -348,6 +348,7 @@ package Namet is function Name_Enter (Buf : Bounded_String := Global_Name_Buffer) return Name_Id; + function Name_Enter (S : String) return Name_Id; -- Name_Enter is similar to Name_Find. The difference is that it does not -- search the table for an existing match, and also subsequent Name_Find -- calls using the same name will not locate the entry created by this diff --git a/gcc/ada/osint.adb b/gcc/ada/osint.adb index 7dbb84cfb2d..8e958c5f8a9 100644 --- a/gcc/ada/osint.adb +++ b/gcc/ada/osint.adb @@ -2651,49 +2651,23 @@ package body Osint is -- Do the actual read operation declare - subtype Actual_Source_Buffer is Source_Buffer (Lo .. Hi); - -- Physical buffer allocated - - type Actual_Source_Ptr is access Actual_Source_Buffer; - -- This is the pointer type for the physical buffer allocated - - Actual_Ptr : constant Actual_Source_Ptr := new Actual_Source_Buffer; - -- And this is the actual physical buffer - - begin + Var_Ptr : constant Source_Buffer_Ptr_Var := + new Source_Buffer (Lo .. Hi); -- Allocate source buffer, allowing extra character at end for EOF - + begin -- Some systems have file types that require one read per line, -- so read until we get the Len bytes or until there are no more -- characters. Hi := Lo; loop - Actual_Len := Read (Source_File_FD, Actual_Ptr (Hi)'Address, Len); + Actual_Len := Read (Source_File_FD, Var_Ptr (Hi)'Address, Len); Hi := Hi + Source_Ptr (Actual_Len); exit when Actual_Len = Len or else Actual_Len <= 0; end loop; - Actual_Ptr (Hi) := EOF; - - -- Now we need to work out the proper virtual origin pointer to - -- return. This is exactly Actual_Ptr (0)'Address, but we have to - -- be careful to suppress checks to compute this address. - - declare - pragma Suppress (All_Checks); - - pragma Warnings (Off); - -- This use of unchecked conversion is aliasing safe - - function To_Source_Buffer_Ptr is new - Unchecked_Conversion (Address, Source_Buffer_Ptr); - - pragma Warnings (On); - - begin - Src := To_Source_Buffer_Ptr (Actual_Ptr (0)'Address); - end; + Var_Ptr (Hi) := EOF; + Src := Var_Ptr.all'Access; end; -- Read is complete, get time stamp and close file and we are done @@ -2703,6 +2677,10 @@ package body Osint is -- The status should never be False. But, if it is, what can we do? -- So, we don't test it. + -- ???We don't really need to return Hi anymore; We could get rid of + -- it. We could also make this into a function. + + pragma Assert (Hi = Src'Last); end Read_Source_File; ------------------- diff --git a/gcc/ada/osint.ads b/gcc/ada/osint.ads index 056b88f51b9..4712b9885f8 100644 --- a/gcc/ada/osint.ads +++ b/gcc/ada/osint.ads @@ -417,11 +417,8 @@ package Osint is -- positions other than the last source character are treated as blanks). -- -- The logical lower bound of the source buffer is the input value of Lo, - -- and on exit Hi is set to the logical upper bound of the source buffer. - -- Note that the returned value in Src points to an array with a physical - -- lower bound of zero. This virtual origin addressing approach means that - -- a constrained array pointer can be used with a low bound of zero which - -- results in more efficient code. + -- and on exit Hi is set to the logical upper bound of the source buffer, + -- which is redundant with Src'Last. -- -- If the given file cannot be opened, then the action depends on whether -- this file is the current main unit (i.e. its name matches the name diff --git a/gcc/ada/prj-conf.ads b/gcc/ada/prj-conf.ads index eae8f528162..41ef5eb858c 100644 --- a/gcc/ada/prj-conf.ads +++ b/gcc/ada/prj-conf.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2006-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2006-2017, 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- -- @@ -107,7 +107,7 @@ package Prj.Conf is -- in another directory. -- -- If specified, On_New_Tree_Loaded is called after each aggregated project - -- has been processed succesfully. + -- has been processed successfully. procedure Process_Project_And_Apply_Config (Main_Project : out Prj.Project_Id; diff --git a/gcc/ada/prj-proc.adb b/gcc/ada/prj-proc.adb index ff68ce79b6b..ec52c2340e2 100644 --- a/gcc/ada/prj-proc.adb +++ b/gcc/ada/prj-proc.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2016, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2017, 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- -- @@ -185,7 +185,7 @@ package body Prj.Proc is -- encapsulated library dependencies. -- -- If specified, On_New_Tree_Loaded is called after each aggregated project - -- has been processed succesfully. + -- has been processed successfully. function Get_Attribute_Index (Tree : Project_Node_Tree_Ref; diff --git a/gcc/ada/s-stposu.adb b/gcc/ada/s-stposu.adb index d017ce3686e..abf2013e48d 100644 --- a/gcc/ada/s-stposu.adb +++ b/gcc/ada/s-stposu.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2011-2016, Free Software Foundation, Inc. -- +-- Copyright (C) 2011-2017, 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- -- @@ -44,7 +44,7 @@ use System.Storage_Pools.Subpools.Finalization; package body System.Storage_Pools.Subpools is Finalize_Address_Table_In_Use : Boolean := False; - -- This flag should be set only when a successfull allocation on a subpool + -- This flag should be set only when a successful allocation on a subpool -- has been performed and the associated Finalize_Address has been added to -- the hash table in System.Finalization_Masters. diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 833cb8ecdc0..cc082e802c5 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2017, 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- -- @@ -4317,7 +4317,7 @@ package body Sem_Attr is begin Attr := N; - -- Set the type of the attribute now to ensure the successfull + -- Set the type of the attribute now to ensure the successful -- continuation of analysis even if the attribute is misplaced. Set_Etype (Attr, P_Type); diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index d7aba502cf2..709bb34440c 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2017, 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- -- @@ -7521,6 +7521,15 @@ package body Sem_Ch4 is is Pref_Typ : constant Entity_Id := Etype (Prefix); + function Expr_Matches_In_Formal + (Subp : Entity_Id; + Par : Node_Id) return Boolean; + -- Find formal corresponding to given indexed component that is an + -- actual in a call. Note that the enclosing subprogram call has not + -- beenanalyzed yet, and the parameter list is not normalized, so + -- that if the argument is a parameter association we must match it + -- by name and not by position. + function Constant_Indexing_OK return Boolean; -- Constant_Indexing is legal if there is no Variable_Indexing defined -- for the type, or else node not a target of assignment, or an actual @@ -7535,6 +7544,56 @@ package body Sem_Ch4 is -- interpretations. Flag Is_Constant should be set when the context is -- constant indexing. + ----------------------------- + -- Expr_Matches_In_Formal -- + ----------------------------- + + function Expr_Matches_In_Formal + (Subp : Entity_Id; + Par : Node_Id) return Boolean + is + Actual : Node_Id; + Formal : Node_Id; + + begin + Formal := First_Formal (Subp); + Actual := First (Parameter_Associations ((Parent (Par)))); + + if Nkind (Par) /= N_Parameter_Association then + + -- Match by position. + + while Present (Actual) and then Present (Formal) loop + exit when Actual = Par; + Next (Actual); + + if Present (Formal) then + Next_Formal (Formal); + + -- Otherwise this is a parameter mismatch, the error is + -- reported elsewhere, or else variable indexing is implied. + + else + return False; + end if; + end loop; + + else + -- Match by name + + while Present (Formal) loop + exit when Chars (Formal) = Chars (Selector_Name (Par)); + Next_Formal (Formal); + + if No (Formal) then + return False; + end if; + end loop; + end if; + + return Present (Formal) and then Ekind (Formal) = E_In_Parameter; + end Expr_Matches_In_Formal; + -------------------------- -- Constant_Indexing_OK -- -------------------------- @@ -7566,8 +7625,6 @@ package body Sem_Ch4 is and then Is_Entity_Name (Name (Parent (Par))) then declare - Actual : Node_Id; - Formal : Entity_Id; Proc : Entity_Id; begin @@ -7582,34 +7639,22 @@ package body Sem_Ch4 is if Is_Overloaded (Name (Parent (Par))) then declare Proc : constant Node_Id := Name (Parent (Par)); - A : Node_Id; - F : Entity_Id; I : Interp_Index; It : Interp; begin Get_First_Interp (Proc, I, It); while Present (It.Nam) loop - F := First_Formal (It.Nam); - A := First (Parameter_Associations (Parent (Par))); - - while Present (F) and then Present (A) loop - if A = Par then - if Ekind (F) /= E_In_Parameter then - return False; - else - exit; -- interpretation is safe - end if; - end if; - - Next_Formal (F); - Next_Actual (A); - end loop; + if not Expr_Matches_In_Formal (It.Nam, Par) then + return False; + end if; Get_Next_Interp (I, It); end loop; end; + -- All interpretations have a matching in-formal. + return True; else @@ -7623,27 +7668,7 @@ package body Sem_Ch4 is end if; end if; - Formal := First_Formal (Proc); - Actual := First_Actual (Parent (Par)); - - -- Find corresponding actual - - while Present (Actual) loop - exit when Actual = Par; - Next_Actual (Actual); - - if Present (Formal) then - Next_Formal (Formal); - - -- Otherwise this is a parameter mismatch, the error is - -- reported elsewhere. - - else - return False; - end if; - end loop; - - return Ekind (Formal) = E_In_Parameter; + return Expr_Matches_In_Formal (Proc, Par); end; elsif Nkind (Parent (Par)) = N_Object_Renaming_Declaration then diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index da8bd89d5a4..c9c18e0038c 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -11486,7 +11486,9 @@ package body Sem_Prag is -- Now set Ada 83 mode - if not Latest_Ada_Only then + if Latest_Ada_Only then + Error_Pragma ("??pragma% ignored"); + else Ada_Version := Ada_83; Ada_Version_Explicit := Ada_83; Ada_Version_Pragma := N; @@ -11520,7 +11522,9 @@ package body Sem_Prag is -- Now set Ada 95 mode - if not Latest_Ada_Only then + if Latest_Ada_Only then + Error_Pragma ("??pragma% ignored"); + else Ada_Version := Ada_95; Ada_Version_Explicit := Ada_95; Ada_Version_Pragma := N; @@ -11582,7 +11586,9 @@ package body Sem_Prag is -- Now set appropriate Ada mode - if not Latest_Ada_Only then + if Latest_Ada_Only then + Error_Pragma ("??pragma% ignored"); + else Ada_Version := Ada_2005; Ada_Version_Explicit := Ada_2005; Ada_Version_Pragma := N; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 5b552bfcb4f..f78ade285da 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -21377,7 +21377,7 @@ package body Sem_Util is procedure Transfer_Entities (From : Entity_Id; To : Entity_Id) is procedure Set_Public_Status_Of (Id : Entity_Id); -- Set the Is_Public attribute of arbitrary entity Id by calling routine - -- Set_Public_Status. If successfull and Id denotes a record type, set + -- Set_Public_Status. If successful and Id denotes a record type, set -- the Is_Public attribute of its fields. -------------------------- diff --git a/gcc/ada/sequenio.ads b/gcc/ada/sequenio.ads index 42522fb9072..ad1d7fa18f5 100644 --- a/gcc/ada/sequenio.ads +++ b/gcc/ada/sequenio.ads @@ -13,11 +13,11 @@ -- -- ------------------------------------------------------------------------------ -pragma Ada_2005; --- Explicit setting of Ada 2005 mode is required here, since we want to with a +pragma Ada_2012; +-- Explicit setting of Ada 2012 mode is required here, since we want to with a -- child unit (not possible in Ada 83 mode), and Sequential_IO is not -- considered to be an internal unit that is automatically compiled in Ada --- 2005 mode (since a user is allowed to redeclare Sequential_IO). +-- 2012 mode (since a user is allowed to redeclare Sequential_IO). with Ada.Sequential_IO; diff --git a/gcc/ada/sfn_scan.adb b/gcc/ada/sfn_scan.adb index 1d24ca227f3..23dc31551ce 100644 --- a/gcc/ada/sfn_scan.adb +++ b/gcc/ada/sfn_scan.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2000-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 2000-2017, 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- -- @@ -102,7 +102,7 @@ package body SFN_Scan is -- immediately following is non-alphabetic, non-numeric. If so, -- P is stepped past the token, and True is returned. If not, -- P is unchanged (except for possibly skipping past whitespace), - -- and False is returned. S may contain only lower-case letters + -- and False is returned. T may contain only lower-case letters -- ('a' .. 'z'). procedure Error (Err : String); diff --git a/gcc/ada/sfn_scan.ads b/gcc/ada/sfn_scan.ads index bc9cbcaa555..9e85994f270 100644 --- a/gcc/ada/sfn_scan.ads +++ b/gcc/ada/sfn_scan.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2000-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 2000-2017, 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- -- @@ -78,7 +78,7 @@ package SFN_Scan is SFN_Ptr : Set_File_Name_Ptr; SFNP_Ptr : Set_File_Name_Pattern_Ptr); -- This is the procedure called to scan a gnat.adc file. The Source - -- parameter points to the full text of the file, with normal line end + -- parameter contains the full text of the file, with normal line end -- characters, in the format normally read by the compiler. The two -- parameters SFN_Ptr and SFNP_Ptr point to procedures that will be -- called to register Source_File_Name pragmas as they are found. @@ -91,6 +91,6 @@ package SFN_Scan is -- that includes only pragmas and comments. It does not do a full -- syntax correctness scan by any means, but if it does find anything -- that it can tell is wrong it will immediately raise the exception - -- to indicate the approximate location of the error + -- to indicate the approximate location of the error. end SFN_Scan; diff --git a/gcc/ada/sinput-c.adb b/gcc/ada/sinput-c.adb index 3ef0f5af35b..fe9285c873e 100644 --- a/gcc/ada/sinput-c.adb +++ b/gcc/ada/sinput-c.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2017, 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- -- @@ -23,7 +23,9 @@ -- -- ------------------------------------------------------------------------------ +with Debug; use Debug; with Opt; use Opt; +with Output; use Output; with System; use System; with Ada.Unchecked_Conversion; @@ -65,6 +67,14 @@ package body Sinput.C is Source_File.Increment_Last; X := Source_File.Last; + if Debug_Flag_L then + Write_Str ("Sinput.C.Load_File: created source "); + Write_Int (Int (X)); + Write_Str (" for "); + Write_Str (Path); + Write_Line (""); + end if; + if X = Source_File.First then Lo := First_Source_Ptr; else @@ -100,50 +110,24 @@ package body Sinput.C is -- Do the actual read operation declare - subtype Actual_Source_Buffer is Source_Buffer (Lo .. Hi); - -- Physical buffer allocated - - type Actual_Source_Ptr is access Actual_Source_Buffer; - -- This is the pointer type for the physical buffer allocated - - Actual_Ptr : constant Actual_Source_Ptr := new Actual_Source_Buffer; - -- And this is the actual physical buffer - - begin + Var_Ptr : constant Source_Buffer_Ptr_Var := + new Source_Buffer (Lo .. Hi); -- Allocate source buffer, allowing extra character at end for EOF + begin -- Some systems have file types that require one read per line, -- so read until we get the Len bytes or until there are no more -- characters. Hi := Lo; loop - Actual_Len := Read (Source_File_FD, Actual_Ptr (Hi)'Address, Len); + Actual_Len := Read (Source_File_FD, Var_Ptr (Hi)'Address, Len); Hi := Hi + Source_Ptr (Actual_Len); exit when Actual_Len = Len or else Actual_Len <= 0; end loop; - Actual_Ptr (Hi) := EOF; - - -- Now we need to work out the proper virtual origin pointer to - -- return. This is exactly Actual_Ptr (0)'Address, but we have to - -- be careful to suppress checks to compute this address. - - declare - pragma Suppress (All_Checks); - - pragma Warnings (Off); - -- The following unchecked conversion is aliased safe, since it - -- is not used to create improperly aliased pointer values. - - function To_Source_Buffer_Ptr is new - Ada.Unchecked_Conversion (Address, Source_Buffer_Ptr); - - pragma Warnings (On); - - begin - Src := To_Source_Buffer_Ptr (Actual_Ptr (0)'Address); - end; + Var_Ptr (Hi) := EOF; + Src := Var_Ptr.all'Access; end; -- Read is complete, close the file and we are done (no need to test @@ -199,7 +183,8 @@ package body Sinput.C is Source_Text => Src, Template => No_Source_File, Unit => No_Unit, - Time_Stamp => Empty_Time_Stamp); + Time_Stamp => Empty_Time_Stamp, + Index => X); Alloc_Line_Tables (S, Opt.Table_Factor * Alloc.Lines_Initial); S.Lines_Table (1) := Lo; diff --git a/gcc/ada/sinput-c.ads b/gcc/ada/sinput-c.ads index 50b729ca1db..432abe277f4 100644 --- a/gcc/ada/sinput-c.ads +++ b/gcc/ada/sinput-c.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2017, 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- -- @@ -25,8 +25,9 @@ -- This child package contains a procedure to load files --- It is used by Sinput.P to load project files, and by GPrep to load --- preprocessor definition files and input files. +-- It is used by Sinput.P to load project files, by GPrep to load preprocessor +-- definition files and input files, and by ALI.Util to compute checksums for +-- source files. package Sinput.C is diff --git a/gcc/ada/sinput-d.adb b/gcc/ada/sinput-d.adb index f150ebf7f0a..c9c128b8bbf 100644 --- a/gcc/ada/sinput-d.adb +++ b/gcc/ada/sinput-d.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2002-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2002-2017, 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- -- @@ -23,8 +23,10 @@ -- -- ------------------------------------------------------------------------------ +with Debug; use Debug; with Osint; use Osint; with Osint.C; use Osint.C; +with Output; use Output; package body Sinput.D is @@ -36,11 +38,8 @@ package body Sinput.D is ------------------------ procedure Close_Debug_Source is - S : Source_File_Record renames Source_File.Table (Dfile); + SFR : Source_File_Record renames Source_File.Table (Dfile); Src : Source_Buffer_Ptr; - - pragma Warnings (Off, S); - begin Trim_Lines_Table (Dfile); Close_Debug_File; @@ -49,8 +48,10 @@ package body Sinput.D is -- subsequent access. Read_Source_File - (S.Full_Debug_Name, S.Source_First, S.Source_Last, Src); - S.Source_Text := Src; + (SFR.Full_Debug_Name, SFR.Source_First, SFR.Source_Last, Src); + SFR.Source_Text := Src; + pragma Assert (SFR.Source_Text'First = SFR.Source_First); + pragma Assert (SFR.Source_Text'Last = SFR.Source_Last); end Close_Debug_Source; ------------------------- @@ -72,8 +73,10 @@ package body Sinput.D is S : Source_File_Record renames Source_File.Table (Dfile); begin + S.Index := Dfile; S.Full_Debug_Name := Create_Debug_File (S.File_Name); S.Debug_Source_Name := Strip_Directory (S.Full_Debug_Name); + S.Source_Text := null; S.Source_First := Loc; S.Source_Last := Loc; S.Lines_Table := null; @@ -85,6 +88,14 @@ package body Sinput.D is Alloc_Line_Tables (S, Int (Source_File.Table (Source).Last_Source_Line * 3)); S.Lines_Table (1) := Loc; + + if Debug_Flag_L then + Write_Str ("Sinput.D.Create_Debug_Source: created source "); + Write_Int (Int (Dfile)); + Write_Str (" for "); + Write_Str (Get_Name_String (S.Full_Debug_Name)); + Write_Line (""); + end if; end; end Create_Debug_Source; diff --git a/gcc/ada/sinput-l.adb b/gcc/ada/sinput-l.adb index aa747cef27b..a64283ec42e 100644 --- a/gcc/ada/sinput-l.adb +++ b/gcc/ada/sinput-l.adb @@ -142,6 +142,12 @@ package body Sinput.L is Source_File.Append (Source_File.Table (Xold)); Xnew := Source_File.Last; + if Debug_Flag_L then + Write_Str ("Create_Instantiation_Source: created source "); + Write_Int (Int (Xnew)); + Write_Line (""); + end if; + declare Sold : Source_File_Record renames Source_File.Table (Xold); Snew : Source_File_Record renames Source_File.Table (Xnew); @@ -149,6 +155,7 @@ package body Sinput.L is Inst_Spec : Node_Id; begin + Snew.Index := Xnew; Snew.Inlined_Body := Inlined_Body; Snew.Inherited_Pragma := Inherited_Pragma; Snew.Template := Xold; @@ -213,8 +220,8 @@ package body Sinput.L is end if; -- Now compute the new values of Source_First and Source_Last and - -- adjust the source file pointer to have the correct virtual origin - -- for the new range of values. + -- adjust the source file pointer to have the correct bounds for the + -- new range of values. -- Source_First must be greater than the last Source_Last value and -- also must be a multiple of Source_Align. @@ -229,6 +236,19 @@ package body Sinput.L is Snew.Sloc_Adjust := Sold.Sloc_Adjust - Factor.Adjust; + -- Modify the Dope of the instance Source_Text to use the + -- above-computed bounds. + + declare + Dope : constant Dope_Ptr := + new Dope_Rec'(Snew.Source_First, Snew.Source_Last); + begin + Snew.Source_Text := Sold.Source_Text; + Set_Dope (Snew.Source_Text'Address, Dope); + pragma Assert (Snew.Source_Text'First = Snew.Source_First); + pragma Assert (Snew.Source_Text'Last = Snew.Source_Last); + end; + if Debug_Flag_L then Write_Eol; Write_Str ("*** Create instantiation source for "); @@ -307,31 +327,6 @@ package body Sinput.L is Write_Location (Sloc (Inst_Node)); Write_Eol; end if; - - -- For a given character in the source, a higher subscript will be - -- used to access the instantiation, which means that the virtual - -- origin must have a corresponding lower value. We compute this new - -- origin by taking the address of the appropriate adjusted element - -- in the old array. Since this adjusted element will be at a - -- negative subscript, we must suppress checks. - - declare - pragma Suppress (All_Checks); - - pragma Warnings (Off); - -- This unchecked conversion is aliasing safe, since it is never - -- used to create improperly aliased pointer values. - - function To_Source_Buffer_Ptr is new - Unchecked_Conversion (Address, Source_Buffer_Ptr); - - pragma Warnings (On); - - begin - Snew.Source_Text := - To_Source_Buffer_Ptr - (Sold.Source_Text (-Factor.Adjust)'Address); - end; end; end Create_Instantiation_Source; @@ -405,6 +400,14 @@ package body Sinput.L is Source_File.Increment_Last; X := Source_File.Last; + if Debug_Flag_L then + Write_Str ("Sinput.L.Load_File: created source "); + Write_Int (Int (X)); + Write_Str (" for "); + Write_Str (Get_Name_String (N)); + Write_Line (""); + end if; + -- Compute starting index, respecting alignment requirement if X = Source_File.First then @@ -529,7 +532,8 @@ package body Sinput.L is Source_Text => Src, Template => No_Source_File, Unit => No_Unit, - Time_Stamp => Osint.Current_Source_File_Stamp); + Time_Stamp => Osint.Current_Source_File_Stamp, + Index => X); Alloc_Line_Tables (S, Opt.Table_Factor * Alloc.Lines_Initial); S.Lines_Table (1) := Lo; @@ -688,54 +692,28 @@ package body Sinput.L is -- Create the new source buffer declare - subtype Actual_Source_Buffer is Source_Buffer (Lo .. Hi); - -- Physical buffer allocated - - type Actual_Source_Ptr is access Actual_Source_Buffer; - -- Pointer type for the physical buffer allocated - - Actual_Ptr : constant Actual_Source_Ptr := - new Actual_Source_Buffer; - -- Actual physical buffer + Var_Ptr : constant Source_Buffer_Ptr_Var := + new Source_Buffer (Lo .. Hi); + -- Allocate source buffer, allowing extra character at + -- end for EOF. begin - Actual_Ptr (Lo .. Hi - 1) := + Var_Ptr (Lo .. Hi - 1) := Prep_Buffer (1 .. Prep_Buffer_Last); - Actual_Ptr (Hi) := EOF; - - -- Now we need to work out the proper virtual origin - -- pointer to return. This is Actual_Ptr (0)'Address, but - -- we have to be careful to suppress checks to compute - -- this address. - - declare - pragma Suppress (All_Checks); - - pragma Warnings (Off); - -- This unchecked conversion is aliasing safe, since - -- it is never used to create improperly aliased - -- pointer values. - - function To_Source_Buffer_Ptr is new - Unchecked_Conversion (Address, Source_Buffer_Ptr); - - pragma Warnings (On); - - begin - Src := To_Source_Buffer_Ptr (Actual_Ptr (0)'Address); + Var_Ptr (Hi) := EOF; + Src := Var_Ptr.all'Access; + end; - -- Record in the table the new source buffer and the - -- new value of Hi. + -- Record in the table the new source buffer and the + -- new value of Hi. - Source_File.Table (X).Source_Text := Src; - Source_File.Table (X).Source_Last := Hi; + Source_File.Table (X).Source_Text := Src; + Source_File.Table (X).Source_Last := Hi; - -- Reset Last_Line to 1, because the lines do not - -- have necessarily the same starts and lengths. + -- Reset Last_Line to 1, because the lines do not + -- have necessarily the same starts and lengths. - Source_File.Table (X).Last_Source_Line := 1; - end; - end; + Source_File.Table (X).Last_Source_Line := 1; end if; end; end if; diff --git a/gcc/ada/sinput-p.adb b/gcc/ada/sinput-p.adb index cb5650c80fc..d643d6466ec 100644 --- a/gcc/ada/sinput-p.adb +++ b/gcc/ada/sinput-p.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2017, 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- -- @@ -23,14 +23,12 @@ -- -- ------------------------------------------------------------------------------ -with Ada.Unchecked_Conversion; -with Ada.Unchecked_Deallocation; +with Unchecked_Conversion; +with Unchecked_Deallocation; with Prj.Err; with Sinput.C; -with System; - package body Sinput.P is First : Boolean := True; @@ -39,10 +37,10 @@ package body Sinput.P is -- The flag is reset to False at the first call to Load_Project_File. -- Calling Reset_First sets it back to True. - procedure Free is new Ada.Unchecked_Deallocation + procedure Free is new Unchecked_Deallocation (Lines_Table_Type, Lines_Table_Ptr); - procedure Free is new Ada.Unchecked_Deallocation + procedure Free is new Unchecked_Deallocation (Logical_Lines_Table_Type, Logical_Lines_Table_Ptr); ----------------------------- @@ -50,39 +48,18 @@ package body Sinput.P is ----------------------------- procedure Clear_Source_File_Table is - use System; - begin for X in 1 .. Source_File.Last loop declare S : Source_File_Record renames Source_File.Table (X); - Lo : constant Source_Ptr := S.Source_First; - Hi : constant Source_Ptr := S.Source_Last; - subtype Actual_Source_Buffer is Source_Buffer (Lo .. Hi); - -- Physical buffer allocated - - type Actual_Source_Ptr is access Actual_Source_Buffer; - -- This is the pointer type for the physical buffer allocated - - procedure Free is new Ada.Unchecked_Deallocation - (Actual_Source_Buffer, Actual_Source_Ptr); - - pragma Suppress (All_Checks); - - pragma Warnings (Off); - -- The following unchecked conversion is aliased safe, since it - -- is not used to create improperly aliased pointer values. - - function To_Actual_Source_Ptr is new - Ada.Unchecked_Conversion (Address, Actual_Source_Ptr); - - pragma Warnings (On); - - Actual_Ptr : Actual_Source_Ptr := - To_Actual_Source_Ptr (S.Source_Text (Lo)'Address); - begin - Free (Actual_Ptr); + if S.Instance = No_Instance_Id then + Free_Source_Buffer (S.Source_Text); + else + Free_Dope (S.Source_Text'Address); + S.Source_Text := null; + end if; + Free (S.Lines_Table); Free (S.Logical_Lines_Table); end; diff --git a/gcc/ada/sinput.adb b/gcc/ada/sinput.adb index b3cfa49369e..3cb9a0e4158 100644 --- a/gcc/ada/sinput.adb +++ b/gcc/ada/sinput.adb @@ -42,7 +42,7 @@ with Widechar; use Widechar; with GNAT.Byte_Order_Mark; use GNAT.Byte_Order_Mark; -with System; use System; +with System.Storage_Elements; with System.Memory; with System.WCh_Con; use System.WCh_Con; @@ -51,11 +51,7 @@ with Unchecked_Deallocation; package body Sinput is - use ASCII; - -- Make control characters visible - - First_Time_Around : Boolean := True; - -- This needs a comment ??? + use ASCII, System; -- Routines to support conversion between types Lines_Table_Ptr, -- Logical_Lines_Table_Ptr and System.Address. @@ -78,6 +74,24 @@ package body Sinput is pragma Warnings (On); + ----------------------------- + -- Source_File_Index_Table -- + ----------------------------- + + -- The Get_Source_File_Index function is called very frequently. Earlier + -- versions cached a single entry, but then reverted to a serial search, + -- and this proved to be a significant source of inefficiency. We then + -- switched to using a table with a start point followed by a serial + -- search. Now we make sure source buffers are on a reasonable boundary + -- (see Types.Source_Align), and we can just use a direct look up in the + -- following table. + + -- Note that this array is pretty large, but in most operating systems + -- it will not be allocated in physical memory unless it is actually used. + + Source_File_Index_Table : + array (Int range 0 .. 1 + (Int'Last / Source_Align)) of Source_File_Index; + --------------------------- -- Add_Line_Tables_Entry -- --------------------------- @@ -328,6 +342,26 @@ package body Sinput is return SIE.Inlined_Body; end Comes_From_Inlined_Body; + ------------------------ + -- Free_Source_Buffer -- + ------------------------ + + procedure Free_Source_Buffer (Src : in out Source_Buffer_Ptr) is + -- Unchecked_Deallocation doesn't work for access-to-constant; we need + -- to first Unchecked_Convert to access-to-variable. + + function To_Source_Buffer_Ptr_Var is new + Unchecked_Conversion (Source_Buffer_Ptr, Source_Buffer_Ptr_Var); + + Temp : Source_Buffer_Ptr_Var := To_Source_Buffer_Ptr_Var (Src); + + procedure Free_Ptr is new + Unchecked_Deallocation (Source_Buffer, Source_Buffer_Ptr_Var); + begin + Free_Ptr (Temp); + Src := null; + end Free_Source_Buffer; + ----------------------- -- Get_Column_Number -- ----------------------- @@ -472,8 +506,51 @@ package body Sinput is --------------------------- function Get_Source_File_Index (S : Source_Ptr) return Source_File_Index is + Result : Source_File_Index; + + procedure Assertions; + -- Assert various properties of the result + + procedure Assertions is + -- ???The old version using zero-origin array indexing without array + -- bounds checks returned 1 (i.e. system.ads) for these special + -- locations, presumably by accident. We are mimicing that here. + Special : constant Boolean := + S = No_Location or else S = Standard_Location + or else S = Standard_ASCII_Location or else S = System_Location; + pragma Assert ((S > No_Location) xor Special); + + pragma Assert (Result in Source_File.First .. Source_File.Last); + + SFR : Source_File_Record renames Source_File.Table (Result); + begin + -- SFR.Source_Text = null if and only if this is the SFR for a debug + -- output file (*.dg), and that file is under construction. + + if not Null_Source_Buffer_Ptr (SFR.Source_Text) then + pragma Assert (SFR.Source_Text'First = SFR.Source_First); + pragma Assert (SFR.Source_Text'Last = SFR.Source_Last); + null; + end if; + + if not Special then + pragma Assert (S in SFR.Source_First .. SFR.Source_Last); + null; + end if; + end Assertions; + + -- Start of processing for Get_Source_File_Index + begin - return Source_File_Index_Table (Int (S) / Source_Align); + if S > No_Location then + Result := Source_File_Index_Table (Int (S) / Source_Align); + else + Result := 1; + end if; + + pragma Debug (Assertions); + + return Result; end Get_Source_File_Index; ---------------- @@ -482,11 +559,8 @@ package body Sinput is procedure Initialize is begin - Source_gnat_adc := No_Source_File; - First_Time_Around := True; - + Source_gnat_adc := No_Source_File; Source_File.Init; - Instances.Init; Instances.Append (No_Location); pragma Assert (Instances.Last = No_Instance_Id); @@ -791,6 +865,33 @@ package body Sinput is end; end Skip_Line_Terminators; + -------------- + -- Set_Dope -- + -------------- + + procedure Set_Dope + (Src : System.Address; New_Dope : Dope_Ptr) + is + -- A fat pointer is a pair consisting of data pointer and dope pointer, + -- in that order. So we want to overwrite the second word. + Dope : Address; + pragma Import (Ada, Dope); + use System.Storage_Elements; + for Dope'Address use Src + System.Address'Size / 8; + begin + Dope := New_Dope.all'Address; + end Set_Dope; + + procedure Free_Dope (Src : System.Address) is + Dope : Dope_Ptr; + pragma Import (Ada, Dope); + use System.Storage_Elements; + for Dope'Address use Src + System.Address'Size / 8; + procedure Free is new Unchecked_Deallocation (Dope_Rec, Dope_Ptr); + begin + Free (Dope); + end Free_Dope; + ---------------- -- Sloc_Range -- ---------------- @@ -871,60 +972,29 @@ package body Sinput is begin -- First we must free any old source buffer pointers - if not First_Time_Around then - for J in Source_File.First .. Source_File.Last loop - declare - S : Source_File_Record renames Source_File.Table (J); - - type Source_Buffer_Ptr_Var is access all Big_Source_Buffer; - - procedure Free_Ptr is new Unchecked_Deallocation - (Big_Source_Buffer, Source_Buffer_Ptr_Var); - -- This works only because we're calling malloc, which keeps - -- track of the size on its own, ignoring the size of - -- Big_Source_Buffer, which is the wrong size. - - pragma Warnings (Off); - -- This unchecked conversion is aliasing safe, since it is not - -- used to create improperly aliased pointer values. - - function To_Source_Buffer_Ptr_Var is new - Unchecked_Conversion (Address, Source_Buffer_Ptr_Var); - - pragma Warnings (On); - - Tmp1 : Source_Buffer_Ptr_Var; + for J in Source_File.First .. Source_File.Last loop + declare + S : Source_File_Record renames Source_File.Table (J); + begin + if S.Instance = No_Instance_Id then + Free_Source_Buffer (S.Source_Text); - begin - if S.Instance /= No_Instance_Id then - null; + if S.Lines_Table /= null then + Memory.Free (To_Address (S.Lines_Table)); + S.Lines_Table := null; + end if; - else - -- Free the buffer, we use Free here, because we used malloc - -- or realloc directly to allocate the tables. That is - -- because we were playing the big array trick. - - -- We have to recreate a proper pointer to the actual array - -- from the zero origin pointer stored in the source table. - - Tmp1 := - To_Source_Buffer_Ptr_Var - (S.Source_Text (S.Source_First)'Address); - Free_Ptr (Tmp1); - - if S.Lines_Table /= null then - Memory.Free (To_Address (S.Lines_Table)); - S.Lines_Table := null; - end if; - - if S.Logical_Lines_Table /= null then - Memory.Free (To_Address (S.Logical_Lines_Table)); - S.Logical_Lines_Table := null; - end if; + if S.Logical_Lines_Table /= null then + Memory.Free (To_Address (S.Logical_Lines_Table)); + S.Logical_Lines_Table := null; end if; - end; - end loop; - end if; + + else + Free_Dope (S.Source_Text'Address); + S.Source_Text := null; + end if; + end; + end loop; -- Read in source file table and instance table @@ -938,56 +1008,10 @@ package body Sinput is for J in Source_File.First .. Source_File.Last loop declare S : Source_File_Record renames Source_File.Table (J); - begin - -- For the instantiation case, we do not read in any data. Instead - -- we share the data for the generic template entry. Since the - -- template always occurs first, we can safely refer to its data. - - if S.Instance /= No_Instance_Id then - declare - ST : Source_File_Record renames - Source_File.Table (S.Template); - - begin - -- The lines tables are copied from the template entry - - S.Lines_Table := - Source_File.Table (S.Template).Lines_Table; - S.Logical_Lines_Table := - Source_File.Table (S.Template).Logical_Lines_Table; - - -- In the case of the source table pointer, we share the - -- same data as the generic template, but the virtual origin - -- is adjusted. For example, if the first subscript of the - -- template is 100, and that of the instantiation is 200, - -- then the instantiation pointer is obtained by subtracting - -- 100 from the template pointer. - - declare - pragma Suppress (All_Checks); - - pragma Warnings (Off); - -- This unchecked conversion is aliasing safe since it - -- not used to create improperly aliased pointer values. - - function To_Source_Buffer_Ptr is new - Unchecked_Conversion (Address, Source_Buffer_Ptr); - - pragma Warnings (On); - - begin - S.Source_Text := - To_Source_Buffer_Ptr - (ST.Source_Text - (ST.Source_First - S.Source_First)'Address); - end; - end; - -- Normal case (non-instantiation) - else - First_Time_Around := False; + if S.Instance = No_Instance_Id then S.Lines_Table := null; S.Logical_Lines_Table := null; Alloc_Line_Tables (S, Int (S.Last_Source_Line)); @@ -1002,33 +1026,42 @@ package body Sinput is end loop; end if; - -- Allocate source buffer and read in the data and then set the - -- virtual origin to point to the logical zero'th element. This - -- address must be computed with subscript checks turned off. + -- Allocate source buffer and read in the data declare - subtype B is Text_Buffer (S.Source_First .. S.Source_Last); - type Text_Buffer_Ptr is access B; - T : Text_Buffer_Ptr; - - pragma Suppress (All_Checks); - - pragma Warnings (Off); - -- This unchecked conversion is aliasing safe, since it is - -- never used to create improperly aliased pointer values. + T : constant Source_Buffer_Ptr_Var := + new Source_Buffer (S.Source_First .. S.Source_Last); + begin + Tree_Read_Data (T (S.Source_First)'Address, + Int (S.Source_Last) - Int (S.Source_First) + 1); + S.Source_Text := T.all'Access; + end; - function To_Source_Buffer_Ptr is new - Unchecked_Conversion (Address, Source_Buffer_Ptr); + -- For the instantiation case, we do not read in any data. Instead + -- we share the data for the generic template entry. Since the + -- template always occurs first, we can safely refer to its data. - pragma Warnings (On); + else + declare + ST : Source_File_Record renames + Source_File.Table (S.Template); begin - T := new B; + -- The lines tables are copied from the template entry - Tree_Read_Data (T (S.Source_First)'Address, - Int (S.Source_Last) - Int (S.Source_First) + 1); + S.Lines_Table := ST.Lines_Table; + S.Logical_Lines_Table := ST.Logical_Lines_Table; + + -- The Source_Text of the instance is the same data as that + -- of the template, but with different bounds. - S.Source_Text := To_Source_Buffer_Ptr (T (0)'Address); + declare + Dope : constant Dope_Ptr := + new Dope_Rec'(S.Source_First, S.Source_Last); + begin + S.Source_Text := ST.Source_Text; + Set_Dope (S.Source_Text'Address, Dope); + end; end; end if; end; @@ -1058,13 +1091,9 @@ package body Sinput is -- For instantiations, there is nothing to do, since the data is -- shared with the generic template. When the tree is read, the -- pointers must be set, but no extra data needs to be written. + -- For the normal case, write out the data of the tables. - if S.Instance /= No_Instance_Id then - null; - - -- For the normal case, write out the data of the tables - - else + if S.Instance = No_Instance_Id then -- Lines table for J in 1 .. S.Last_Source_Line loop diff --git a/gcc/ada/sinput.ads b/gcc/ada/sinput.ads index fc700d1e350..7162d0fd747 100644 --- a/gcc/ada/sinput.ads +++ b/gcc/ada/sinput.ads @@ -63,6 +63,7 @@ with Alloc; with Casing; use Casing; with Namet; use Namet; +with System; with Table; with Types; use Types; @@ -219,19 +220,17 @@ package Sinput is -- pragmas are used, then the value is set to No_Line_Number. -- Source_Text : Source_Buffer_Ptr (read-only) - -- Text of source file. Note that every source file has a distinct set - -- of non-overlapping logical bounds, so it is possible to determine - -- which file is referenced from a given subscript (Source_Ptr) value. + -- Text of source file. Every source file has a distinct set of + -- nonoverlapping bounds, so it is possible to determine which + -- file is referenced from a given subscript (Source_Ptr) value. -- Source_First : Source_Ptr; (read-only) - -- Subscript of first character in Source_Text. Note that this cannot - -- be obtained as Source_Text'First, because we use virtual origin - -- addressing. + -- This is always equal to Source_Text'First, except during + -- construction of a debug output file (*.dg), when Source_Text = null, + -- and Source_First is the size so far. Likewise for Last. -- Source_Last : Source_Ptr; (read-only) - -- Subscript of last character in Source_Text. Note that this cannot - -- be obtained as Source_Text'Last, because we use virtual origin - -- addressing, so this value is always Source_Ptr'Last. + -- Same idea as Source_Last, but for Last -- Time_Stamp : Time_Stamp_Type; (read-only) -- Time stamp of the source file @@ -341,29 +340,6 @@ package Sinput is Main_Source_File : Source_File_Index := No_Source_File; -- This is set to the source file index of the main unit - ----------------------------- - -- Source_File_Index_Table -- - ----------------------------- - - -- The Get_Source_File_Index function is called very frequently. Earlier - -- versions cached a single entry, but then reverted to a serial search, - -- and this proved to be a significant source of inefficiency. We then - -- switched to using a table with a start point followed by a serial - -- search. Now we make sure source buffers are on a reasonable boundary - -- (see Types.Source_Align), and we can just use a direct look up in the - -- following table. - - -- Note that this array is pretty large, but in most operating systems - -- it will not be allocated in physical memory unless it is actually used. - - Source_File_Index_Table : - array (Int range 0 .. 1 + (Int'Last / Source_Align)) of Source_File_Index; - - procedure Set_Source_File_Index_Table (Xnew : Source_File_Index); - -- Sets entries in the Source_File_Index_Table for the newly created - -- Source_File table entry whose index is Xnew. The Source_First and - -- Source_Last fields of this entry must be set before the call. - ----------------------- -- Checksum Handling -- ----------------------- @@ -396,13 +372,13 @@ package Sinput is -- is also possible to find the location of the instantiation. -- This is achieved as follows. When an instantiation occurs, a new entry - -- is made in the source file table. This entry points to the same source - -- text, i.e. the file that contains the instantiation, but has a distinct - -- set of Source_Ptr index values. The separate range of Sloc values avoids + -- is made in the source file table. The Source_Text of the instantiation + -- points to the same Source_Buffer as the Source_Text of the template, but + -- with different bounds. The separate range of Sloc values avoids -- confusion, and means that the Sloc values can still be used to uniquely - -- identify the source file table entry. It is possible for both entries - -- to point to the same text, because of the virtual origin pointers used - -- in the source table. + -- identify the source file table entry. See Set_Dope below for the + -- low-level trickery that allows two different pointers to point at the + -- same array, but with different bounds. -- The Instantiation_Id field of this source file index entry, set -- to No_Instance_Id for normal entries, instead contains a value that @@ -858,6 +834,7 @@ private -- Max_Source_Line gives the maximum used value, this gives the -- maximum allocated value. + Index : Source_File_Index := 123456789; -- for debugging end record; -- The following representation clause ensures that the above record @@ -892,36 +869,38 @@ private Identifier_Casing at 78 range 0 .. 15; Sloc_Adjust at 80 range 0 .. 31; Lines_Table_Max at 84 range 0 .. 31; + Index at 92 range 0 .. 31; -- The following fields are pointers, so we have to specialize their -- lengths using pointer size, obtained above as Standard'Address_Size. + -- Note that Source_Text is a fat pointer, so it has size = AS*2. - Source_Text at 92 range 0 .. AS - 1; - Lines_Table at 92 range AS .. AS * 2 - 1; - Logical_Lines_Table at 92 range AS * 2 .. AS * 3 - 1; - end record; + Source_Text at 96 range 0 .. AS * 2 - 1; + Lines_Table at 96 range AS * 2 .. AS * 3 - 1; + Logical_Lines_Table at 96 range AS * 3 .. AS * 4 - 1; + end record; -- Source_File_Record - for Source_File_Record'Size use 92 * 8 + AS * 3; + for Source_File_Record'Size use 96 * 8 + AS * 4; -- This ensures that we did not leave out any fields - package Source_File is new Table.Table ( - Table_Component_Type => Source_File_Record, - Table_Index_Type => Source_File_Index, - Table_Low_Bound => 1, - Table_Initial => Alloc.Source_File_Initial, - Table_Increment => Alloc.Source_File_Increment, - Table_Name => "Source_File"); + package Source_File is new Table.Table + (Table_Component_Type => Source_File_Record, + Table_Index_Type => Source_File_Index, + Table_Low_Bound => 1, + Table_Initial => Alloc.Source_File_Initial, + Table_Increment => Alloc.Source_File_Increment, + Table_Name => "Source_File"); -- Auxiliary table containing source location of instantiations. Index 0 -- is used for code that does not come from an instance. - package Instances is new Table.Table ( - Table_Component_Type => Source_Ptr, - Table_Index_Type => Instance_Id, - Table_Low_Bound => 0, - Table_Initial => Alloc.Source_File_Initial, - Table_Increment => Alloc.Source_File_Increment, - Table_Name => "Instances"); + package Instances is new Table.Table + (Table_Component_Type => Source_Ptr, + Table_Index_Type => Instance_Id, + Table_Low_Bound => 0, + Table_Initial => Alloc.Source_File_Initial, + Table_Increment => Alloc.Source_File_Increment, + Table_Name => "Instances"); ----------------- -- Subprograms -- @@ -948,4 +927,32 @@ private -- correspond to the current value of Num_Source_Lines, releasing -- any unused storage. This is used by Sinput.L and Sinput.D. + procedure Set_Source_File_Index_Table (Xnew : Source_File_Index); + -- Sets entries in the Source_File_Index_Table for the newly created + -- Source_File table entry whose index is Xnew. The Source_First and + -- Source_Last fields of this entry must be set before the call. + -- See package body for details. + + type Dope_Rec is record + First, Last : Source_Ptr'Base; + end record; + Dope_Rec_Size : constant := 2 * Source_Ptr'Size; + for Dope_Rec'Size use Dope_Rec_Size; + for Dope_Rec'Alignment use Dope_Rec_Size / 8; + type Dope_Ptr is access all Dope_Rec; + + procedure Set_Dope + (Src : System.Address; New_Dope : Dope_Ptr); + -- Src is the address of a variable of type Source_Buffer_Ptr, which is a + -- fat pointer. This sets the dope part of the fat pointer to point to the + -- specified New_Dope. This low-level processing is used to make the + -- Source_Text of an instance point to the same text as the template, but + -- with different bounds. + + procedure Free_Dope (Src : System.Address); + -- Calls Unchecked_Deallocation on the dope part of the fat pointer Src + + procedure Free_Source_Buffer (Src : in out Source_Buffer_Ptr); + -- Deallocates the source buffer + end Sinput; diff --git a/gcc/ada/targparm.adb b/gcc/ada/targparm.adb index 0c5170a4862..7eba1365c3e 100644 --- a/gcc/ada/targparm.adb +++ b/gcc/ada/targparm.adb @@ -106,34 +106,34 @@ package body Targparm is type Buffer_Ptr is access constant Source_Buffer; Targparm_Str : constant array (Targparm_Tags) of Buffer_Ptr := - (AAM_Str'Access, - ACR_Str'Access, - ASD_Str'Access, - BDC_Str'Access, - BOC_Str'Access, - CLA_Str'Access, - CRT_Str'Access, - D32_Str'Access, - DEN_Str'Access, - EXS_Str'Access, - FEL_Str'Access, - FEX_Str'Access, - FFO_Str'Access, - MOV_Str'Access, - MRN_Str'Access, - PAS_Str'Access, - SAG_Str'Access, - SAP_Str'Access, - SCA_Str'Access, - SCC_Str'Access, - SCD_Str'Access, - SCL_Str'Access, - SCP_Str'Access, - SLS_Str'Access, - SNZ_Str'Access, - SSL_Str'Access, - UAM_Str'Access, - ZCX_Str'Access); + (AAM => AAM_Str'Access, + ACR => ACR_Str'Access, + ASD => ASD_Str'Access, + BDC => BDC_Str'Access, + BOC => BOC_Str'Access, + CLA => CLA_Str'Access, + CRT => CRT_Str'Access, + D32 => D32_Str'Access, + DEN => DEN_Str'Access, + EXS => EXS_Str'Access, + FEL => FEL_Str'Access, + FEX => FEX_Str'Access, + FFO => FFO_Str'Access, + MOV => MOV_Str'Access, + MRN => MRN_Str'Access, + PAS => PAS_Str'Access, + SAG => SAG_Str'Access, + SAP => SAP_Str'Access, + SCA => SCA_Str'Access, + SCC => SCC_Str'Access, + SCD => SCD_Str'Access, + SCL => SCL_Str'Access, + SCP => SCP_Str'Access, + SLS => SLS_Str'Access, + SNZ => SNZ_Str'Access, + SSL => SSL_Str'Access, + UAM => UAM_Str'Access, + ZCX => ZCX_Str'Access); ----------------------- -- Local Subprograms -- @@ -146,7 +146,7 @@ package body Targparm is -- Get_Target_Parameters -- --------------------------- - -- Version which reads in system.ads + -- Version that reads in system.ads procedure Get_Target_Parameters (Make_Id : Make_Id_Type := null; @@ -200,6 +200,9 @@ package body Targparm is Set_NUA : Set_NUA_Type := null; Set_NUP : Set_NUP_Type := null) is + pragma Assert (System_Text'First = Source_First); + pragma Assert (System_Text'Last = Source_Last); + P : Source_Ptr; -- Scans source buffer containing source of system.ads @@ -220,6 +223,13 @@ package body Targparm is -- with Name_Len being length, folded to lower case. On return, P points -- just past the last character (which should be a right paren). + function Looking_At (S : Source_Buffer) return Boolean; + -- True if P points to the same text as S in System_Text + + function Looking_At_Skip (S : Source_Buffer) return Boolean; + -- True if P points to the same text as S in System_Text, + -- and if True, moves P forward to skip S as a side effect. + ------------------ -- Collect_Name -- ------------------ @@ -249,15 +259,39 @@ package body Targparm is end loop; end Collect_Name; + ---------------- + -- Looking_At -- + ---------------- + + function Looking_At (S : Source_Buffer) return Boolean is + Last : constant Source_Ptr := P + S'Length - 1; + begin + return Last <= System_Text'Last + and then System_Text (P .. Last) = S; + end Looking_At; + + --------------------- + -- Looking_At_Skip -- + --------------------- + + function Looking_At_Skip (S : Source_Buffer) return Boolean is + Result : constant Boolean := Looking_At (S); + begin + if Result then + P := P + S'Length; + end if; + + return Result; + end Looking_At_Skip; + -- Start of processing for Get_Target_Parameters begin if Parameters_Obtained then return; - else - Parameters_Obtained := True; end if; + Parameters_Obtained := True; Opt.Address_Is_Private := False; -- Loop through source lines @@ -271,71 +305,59 @@ package body Targparm is -- For a special exception, see processing for pragma Pure below P := Source_First; - Line_Loop : while System_Text (P .. P + 10) /= "end System;" loop - -- Skip comments quickly + while not Looking_At ("end System;") loop + -- Skip comments - if System_Text (P) = '-' then + if Looking_At ("-") then goto Line_Loop_Continue; -- Test for type Address is private - elsif System_Text (P .. P + 26) = " type Address is private;" then + elsif Looking_At_Skip (" type Address is private;") then Opt.Address_Is_Private := True; - P := P + 26; goto Line_Loop_Continue; -- Test for pragma Profile (Ravenscar); - elsif System_Text (P .. P + 26) = - "pragma Profile (Ravenscar);" - then + elsif Looking_At_Skip ("pragma Profile (Ravenscar);") then Set_Profile_Restrictions (Ravenscar); Opt.Task_Dispatching_Policy := 'F'; Opt.Locking_Policy := 'C'; - P := P + 27; goto Line_Loop_Continue; -- Test for pragma Profile (GNAT_Extended_Ravenscar); - elsif System_Text (P .. P + 40) = - "pragma Profile (GNAT_Extended_Ravenscar);" + elsif Looking_At_Skip + ("pragma Profile (GNAT_Extended_Ravenscar);") then Set_Profile_Restrictions (GNAT_Extended_Ravenscar); Opt.Task_Dispatching_Policy := 'F'; Opt.Locking_Policy := 'C'; - P := P + 41; goto Line_Loop_Continue; -- Test for pragma Profile (GNAT_Ravenscar_EDF); - elsif System_Text (P .. P + 35) = - "pragma Profile (GNAT_Ravenscar_EDF);" - then + elsif Looking_At_Skip ("pragma Profile (GNAT_Ravenscar_EDF);") then Set_Profile_Restrictions (GNAT_Ravenscar_EDF); Opt.Task_Dispatching_Policy := 'E'; Opt.Locking_Policy := 'C'; - P := P + 36; goto Line_Loop_Continue; -- Test for pragma Profile (Restricted); - elsif System_Text (P .. P + 27) = - "pragma Profile (Restricted);" - then + elsif Looking_At_Skip ("pragma Profile (Restricted);") then Set_Profile_Restrictions (Restricted); - P := P + 28; goto Line_Loop_Continue; -- Test for pragma Restrictions - elsif System_Text (P .. P + 20) = "pragma Restrictions (" then - P := P + 21; + elsif Looking_At_Skip ("pragma Restrictions (") then PR_Start := P - 1; -- Boolean restrictions - Rloop : for K in All_Boolean_Restrictions loop + for K in All_Boolean_Restrictions loop declare Rname : constant String := Restriction_Id'Image (K); @@ -354,9 +376,8 @@ package body Targparm is end if; end; - <> - null; - end loop Rloop; + <> null; + end loop; -- Restrictions taking integer parameter @@ -423,15 +444,12 @@ package body Targparm is end if; end; - <> - null; + <> null; end loop Ploop; -- No_Dependence case - if System_Text (P .. P + 16) = "No_Dependence => " then - P := P + 17; - + if Looking_At_Skip ("No_Dependence => ") then -- Skip this processing (and simply ignore No_Dependence lines) -- if caller did not supply the three subprograms we need to -- process these lines. @@ -481,10 +499,7 @@ package body Targparm is -- No_Specification_Of_Aspect case - elsif System_Text (P .. P + 29) = "No_Specification_Of_Aspect => " - then - P := P + 30; - + elsif Looking_At_Skip ("No_Specification_Of_Aspect => ") then -- Skip this processing (and simply ignore the pragma), if -- caller did not supply the subprogram we need to process -- such lines. @@ -513,9 +528,7 @@ package body Targparm is -- No_Use_Of_Attribute case - elsif System_Text (P .. P + 22) = "No_Use_Of_Attribute => " then - P := P + 23; - + elsif Looking_At_Skip ("No_Use_Of_Attribute => ") then -- Skip this processing (and simply ignore No_Use_Of_Attribute -- lines) if caller did not supply the subprogram we need to -- process such lines. @@ -544,9 +557,7 @@ package body Targparm is -- No_Use_Of_Pragma case - elsif System_Text (P .. P + 19) = "No_Use_Of_Pragma => " then - P := P + 20; - + elsif Looking_At_Skip ("No_Use_Of_Pragma => ") then -- Skip this processing (and simply ignore No_Use_Of_Pragma -- lines) if caller did not supply the subprogram we need to -- process such lines. @@ -597,89 +608,72 @@ package body Targparm is -- Test for pragma Detect_Blocking; - elsif System_Text (P .. P + 22) = "pragma Detect_Blocking;" then - P := P + 23; + elsif Looking_At_Skip ("pragma Detect_Blocking;") then Opt.Detect_Blocking := True; goto Line_Loop_Continue; -- Discard_Names - elsif System_Text (P .. P + 20) = "pragma Discard_Names;" then - P := P + 21; + elsif Looking_At_Skip ("pragma Discard_Names;") then Opt.Global_Discard_Names := True; goto Line_Loop_Continue; -- Locking Policy - elsif System_Text (P .. P + 22) = "pragma Locking_Policy (" then - P := P + 23; + elsif Looking_At_Skip ("pragma Locking_Policy (") then Opt.Locking_Policy := System_Text (P); Opt.Locking_Policy_Sloc := System_Location; goto Line_Loop_Continue; -- Normalize_Scalars - elsif System_Text (P .. P + 24) = "pragma Normalize_Scalars;" then - P := P + 25; + elsif Looking_At_Skip ("pragma Normalize_Scalars;") then Opt.Normalize_Scalars := True; Opt.Init_Or_Norm_Scalars := True; goto Line_Loop_Continue; -- Partition_Elaboration_Policy - elsif System_Text (P .. P + 36) = - "pragma Partition_Elaboration_Policy (" - then - P := P + 37; + elsif Looking_At_Skip ("pragma Partition_Elaboration_Policy (") then Opt.Partition_Elaboration_Policy := System_Text (P); Opt.Partition_Elaboration_Policy_Sloc := System_Location; goto Line_Loop_Continue; -- Polling (On) - elsif System_Text (P .. P + 19) = "pragma Polling (On);" then - P := P + 20; + elsif Looking_At_Skip ("pragma Polling (On);") then Opt.Polling_Required := True; goto Line_Loop_Continue; -- Queuing Policy - elsif System_Text (P .. P + 22) = "pragma Queuing_Policy (" then - P := P + 23; + elsif Looking_At_Skip ("pragma Queuing_Policy (") then Opt.Queuing_Policy := System_Text (P); Opt.Queuing_Policy_Sloc := System_Location; goto Line_Loop_Continue; -- Suppress_Exception_Locations - elsif System_Text (P .. P + 35) = - "pragma Suppress_Exception_Locations;" - then - P := P + 36; + elsif Looking_At_Skip ("pragma Suppress_Exception_Locations;") then Opt.Exception_Locations_Suppressed := True; goto Line_Loop_Continue; -- Task_Dispatching Policy - elsif System_Text (P .. P + 31) = - "pragma Task_Dispatching_Policy (" - then - P := P + 32; + elsif Looking_At_Skip ("pragma Task_Dispatching_Policy (") then Opt.Task_Dispatching_Policy := System_Text (P); Opt.Task_Dispatching_Policy_Sloc := System_Location; goto Line_Loop_Continue; -- No other configuration pragmas are permitted - elsif System_Text (P .. P + 6) = "pragma " then - + elsif Looking_At ("pragma ") then -- Special exception, we allow pragma Pure (System) appearing in -- column one. This is an obsolete usage which may show up in old -- tests with an obsolete version of system.ads, so we recognize -- and ignore it to make life easier in handling such tests. - if System_Text (P .. P + 20) = "pragma Pure (System);" then - P := P + 21; + if Looking_At_Skip ("pragma Pure (System);") then goto Line_Loop_Continue; end if; @@ -699,11 +693,9 @@ package body Targparm is -- See if we have a Run_Time_Name - elsif System_Text (P .. P + 38) = - " Run_Time_Name : constant String := """ + elsif Looking_At_Skip + (" Run_Time_Name : constant String := """) then - P := P + 39; - Name_Len := 0; while System_Text (P) in 'A' .. 'Z' or else @@ -739,11 +731,9 @@ package body Targparm is -- See if we have an Executable_Extension - elsif System_Text (P .. P + 45) = - " Executable_Extension : constant String := """ + elsif Looking_At_Skip + (" Executable_Extension : constant String := """) then - P := P + 46; - Name_Len := 0; while System_Text (P) /= '"' and then System_Text (P) /= ASCII.LF @@ -769,11 +759,7 @@ package body Targparm is else Config_Param_Loop : for K in Targparm_Tags loop - if System_Text (P + 3 .. P + 2 + Targparm_Str (K)'Length) = - Targparm_Str (K).all - then - P := P + 3 + Targparm_Str (K)'Length; - + if Looking_At_Skip (" " & Targparm_Str (K).all) then if Targparm_Flags (K) then Set_Standard_Error; Write_Line @@ -851,14 +837,18 @@ package body Targparm is <> - while System_Text (P) /= CR and then System_Text (P) /= LF loop + while P < Source_Last + and then System_Text (P) /= CR + and then System_Text (P) /= LF + loop P := P + 1; - exit when P >= Source_Last; end loop; - while System_Text (P) = CR or else System_Text (P) = LF loop + while P < Source_Last + and then (System_Text (P) = CR + or else System_Text (P) = LF) + loop P := P + 1; - exit when P >= Source_Last; end loop; if P >= Source_Last then @@ -868,7 +858,7 @@ package body Targparm is Set_Standard_Output; raise Unrecoverable_Error; end if; - end loop Line_Loop; + end loop; if Fatal then raise Unrecoverable_Error; diff --git a/gcc/ada/text_io.ads b/gcc/ada/text_io.ads index 9c213e9a4fd..4c67d8dd36f 100644 --- a/gcc/ada/text_io.ads +++ b/gcc/ada/text_io.ads @@ -13,10 +13,10 @@ -- -- ------------------------------------------------------------------------------ -pragma Ada_2005; --- Explicit setting of Ada 2005 mode is required here, since we want to with a +pragma Ada_2012; +-- Explicit setting of Ada 2012 mode is required here, since we want to with a -- child unit (not possible in Ada 83 mode), and Text_IO is not considered to --- be an internal unit that is automatically compiled in Ada 2005 mode (since +-- be an internal unit that is automatically compiled in Ada 2012 mode (since -- a user is allowed to redeclare Text_IO). with Ada.Text_IO; diff --git a/gcc/ada/types.ads b/gcc/ada/types.ads index 1ae0f9b3e90..e0809f27037 100644 --- a/gcc/ada/types.ads +++ b/gcc/ada/types.ads @@ -196,23 +196,14 @@ package Types is -- which are one greater than the previous upper bound, rounded up to -- a multiple of Source_Align. - subtype Big_Source_Buffer is Text_Buffer (0 .. Text_Ptr'Last); - -- This is a virtual type used as the designated type of the access type - -- Source_Buffer_Ptr, see Osint.Read_Source_File for details. - - type Source_Buffer_Ptr is access constant Big_Source_Buffer; - -- Pointer to source buffer. We use virtual origin addressing for source - -- buffers, with thin pointers. The pointer points to a virtual instance - -- of type Big_Source_Buffer, where the actual type is in fact of type - -- Source_Buffer. The address is adjusted so that the virtual origin - -- addressing works correctly. See Osint.Read_Source_Buffer for further - -- details. Again, as for Big_String_Ptr, we should never allocate using - -- this type, but we don't give a storage size clause of zero, since we - -- may end up doing deallocations of instances allocated manually. + type Source_Buffer_Ptr_Var is access all Source_Buffer; + type Source_Buffer_Ptr is access constant Source_Buffer; + -- Pointer to source buffer. Source_Buffer_Ptr_Var is used for allocation + -- and deallocation; Source_Buffer_Ptr is used for all other uses of source + -- buffers. function Null_Source_Buffer_Ptr (X : Source_Buffer_Ptr) return Boolean; - -- True if X = null. ???This usage of "=" is wrong, because the zero-origin - -- pointer could happen to be equal to null. We need to eliminate this. + -- True if X = null function Source_Buffer_Ptr_Equal (X, Y : Source_Buffer_Ptr) return Boolean renames "="; @@ -220,10 +211,11 @@ package Types is -- Do not call this elsewhere. function "=" (X, Y : Source_Buffer_Ptr) return Boolean is abstract; - -- Make "=" abstract, to make sure no one calls it. Note that this makes - -- "/=" abstract as well. Calls to "=" on Source_Buffer_Ptr are always - -- wrong, because two different arrays allocated at two different addresses - -- can have the same virtual origin. + -- Make "=" abstract. Note that this makes "/=" abstract as well. This is a + -- vestige of the zero-origin array indexing we used to use, where "=" is + -- always wrong (including the one in Null_Source_Buffer_Ptr). We keep this + -- just because we never need to compare Source_Buffer_Ptrs other than to + -- null. subtype Source_Ptr is Text_Ptr; -- Type used to represent a source location, which is a subscript of a @@ -580,7 +572,7 @@ package Types is No_Unit : constant Unit_Number_Type := -1; -- Special value used to signal no unit - type Source_File_Index is new Int range -1 .. Int'Last; + type Source_File_Index is new Int range 0 .. Int'Last; -- Type used to index the source file table (see package Sinput) No_Source_File : constant Source_File_Index := 0; -- 2.30.2