From e917aec294d1a0e602aaf31a70df3a784f7a48b9 Mon Sep 17 00:00:00 2001 From: Robert Dewar Date: Wed, 3 Aug 2011 09:47:07 +0000 Subject: [PATCH] sem_aggr.adb, [...]: Minor reformatting 2011-08-03 Robert Dewar * sem_aggr.adb, sem_ch3.adb, lib.ads, gnatcmd.adb, prj-proc.adb, make.adb, lib-writ.adb, prj-part.adb, prj-part.ads, prj-ext.adb, fname-uf.adb, prj-ext.ads, prj.adb, prj.ads, sem_attr.adb, alfa.adb, prj-makr.adb, errout.adb, makeutl.adb, makeutl.ads, restrict.ads, sem_ch6.adb, g-pehage.adb, clean.adb, put_alfa.adb, lib-xref-alfa.adb, prj-nmsc.adb, prj-nmsc.ads, sem_ch8.adb, prj-pars.ads, exp_aggr.adb, prj-attr.ads, sem_ch13.adb, get_alfa.adb, prj-env.adb, prj-env.ads, alfa_test.adb, prj-tree.adb, prj-tree.ads, einfo.ads: Minor reformatting 2011-08-03 Robert Dewar * repinfo.adb (List_Mechanism): Add handling of Convention_Ada_Pass_By_XXX. * sem_mech.adb (Set_Mechanism): Ditto. * sem_prag.adb (Process_Convention): Add entries for Convention_Ada_Pass_By_XXX. * snames.adb-tmpl, snames.ads-tmpl: Ditto. From-SVN: r177252 --- gcc/ada/ChangeLog | 20 +++ gcc/ada/alfa.adb | 2 +- gcc/ada/alfa_test.adb | 2 + gcc/ada/clean.adb | 6 +- gcc/ada/einfo.ads | 29 ++-- gcc/ada/errout.adb | 3 +- gcc/ada/exp_aggr.adb | 2 +- gcc/ada/fname-uf.adb | 116 ++++++++------- gcc/ada/g-pehage.adb | 5 +- gcc/ada/get_alfa.adb | 28 ++-- gcc/ada/gnatcmd.adb | 2 +- gcc/ada/lib-writ.adb | 3 +- gcc/ada/lib-xref-alfa.adb | 48 +++---- gcc/ada/lib.ads | 6 +- gcc/ada/make.adb | 2 +- gcc/ada/makeutl.adb | 12 +- gcc/ada/makeutl.ads | 11 +- gcc/ada/prj-attr.ads | 17 +-- gcc/ada/prj-env.adb | 12 +- gcc/ada/prj-env.ads | 29 ++-- gcc/ada/prj-ext.adb | 5 +- gcc/ada/prj-ext.ads | 3 +- gcc/ada/prj-makr.adb | 2 +- gcc/ada/prj-nmsc.adb | 39 ++--- gcc/ada/prj-nmsc.ads | 8 +- gcc/ada/prj-pars.ads | 1 + gcc/ada/prj-part.adb | 20 +-- gcc/ada/prj-part.ads | 20 +-- gcc/ada/prj-proc.adb | 290 ++++++++++++++++++-------------------- gcc/ada/prj-tree.adb | 10 +- gcc/ada/prj-tree.ads | 9 +- gcc/ada/prj.adb | 14 +- gcc/ada/prj.ads | 15 +- gcc/ada/put_alfa.adb | 3 - gcc/ada/repinfo.adb | 45 ++++-- gcc/ada/restrict.ads | 14 +- gcc/ada/sem_aggr.adb | 32 +++-- gcc/ada/sem_attr.adb | 20 +-- gcc/ada/sem_ch13.adb | 3 +- gcc/ada/sem_ch3.adb | 2 +- gcc/ada/sem_ch6.adb | 8 +- gcc/ada/sem_ch8.adb | 8 +- gcc/ada/sem_mech.adb | 10 +- gcc/ada/sem_prag.adb | 32 +++++ gcc/ada/snames.adb-tmpl | 56 ++++---- gcc/ada/snames.ads-tmpl | 16 ++- 46 files changed, 564 insertions(+), 476 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 180fd82ec5c..5cd400aea4d 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,23 @@ +2011-08-03 Robert Dewar + + * sem_aggr.adb, sem_ch3.adb, lib.ads, gnatcmd.adb, prj-proc.adb, + make.adb, lib-writ.adb, prj-part.adb, prj-part.ads, prj-ext.adb, + fname-uf.adb, prj-ext.ads, prj.adb, prj.ads, sem_attr.adb, alfa.adb, + prj-makr.adb, errout.adb, makeutl.adb, makeutl.ads, restrict.ads, + sem_ch6.adb, g-pehage.adb, clean.adb, put_alfa.adb, lib-xref-alfa.adb, + prj-nmsc.adb, prj-nmsc.ads, sem_ch8.adb, prj-pars.ads, exp_aggr.adb, + prj-attr.ads, sem_ch13.adb, get_alfa.adb, prj-env.adb, prj-env.ads, + alfa_test.adb, prj-tree.adb, prj-tree.ads, einfo.ads: Minor reformatting + +2011-08-03 Robert Dewar + + * repinfo.adb (List_Mechanism): Add handling of + Convention_Ada_Pass_By_XXX. + * sem_mech.adb (Set_Mechanism): Ditto. + * sem_prag.adb (Process_Convention): Add entries for + Convention_Ada_Pass_By_XXX. + * snames.adb-tmpl, snames.ads-tmpl: Ditto. + 2011-08-03 Pascal Obry * makeutl.adb: Minor reformatting. diff --git a/gcc/ada/alfa.adb b/gcc/ada/alfa.adb index 42997b73461..6fd1d8f8aae 100644 --- a/gcc/ada/alfa.adb +++ b/gcc/ada/alfa.adb @@ -194,7 +194,7 @@ package body ALFA is procedure Debug_Put_ALFA is new Put_ALFA; - -- Start of processing for palfa + -- Start of processing for palfa begin Debug_Put_ALFA; diff --git a/gcc/ada/alfa_test.adb b/gcc/ada/alfa_test.adb index c190d1f1f4a..259040a4d2e 100644 --- a/gcc/ada/alfa_test.adb +++ b/gcc/ada/alfa_test.adb @@ -117,6 +117,7 @@ begin procedure Put_Char (F : File_Type; C : Character) is Item : Stream_Element_Array (1 .. 1); + begin if C /= CR and then C /= EOF then if C = LF then @@ -157,6 +158,7 @@ begin function Nextc return Character is C : Character; + begin C := Get_Char (Infile); diff --git a/gcc/ada/clean.adb b/gcc/ada/clean.adb index 49cc5cc24ba..9bbf1159051 100644 --- a/gcc/ada/clean.adb +++ b/gcc/ada/clean.adb @@ -1875,9 +1875,9 @@ package body Clean is end if; if not OK - or else not Prj.Ext.Check - (Root_Environment.External, - Ext_Asgn (Start .. Stop)) + or else not + Prj.Ext.Check (Root_Environment.External, + Ext_Asgn (Start .. Stop)) then Fail ("illegal external assignment '" diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 993094e19c7..e05834c428d 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -2940,11 +2940,11 @@ package Einfo is -- are suppressed. -- Machine_Radix_10 (Flag84) --- Present in decimal types and subtypes, set if the Machine_Radix --- is 10, as the result of the specification of a machine radix --- representation clause. Note that it is possible for this flag --- to be set without having Has_Machine_Radix_Clause True. This --- happens when a type is derived from a type with a clause present. +-- Present in decimal types and subtypes, set if the Machine_Radix is 10, +-- as the result of the specification of a machine radix representation +-- clause. Note that it is possible for this flag to be set without +-- having Has_Machine_Radix_Clause True. This happens when a type is +-- derived from a type with a clause present. -- Master_Id (Node17) -- Present in access types and subtypes. Empty unless Has_Task is @@ -2968,18 +2968,17 @@ package Einfo is -- entity but not used in this context. -- Modulus (Uint17) [base type only] --- Present in modular types. Contains the modulus. For the binary --- case, this will be a power of 2, but if Non_Binary_Modulus is --- set, then it will not be a power of 2. +-- Present in modular types. Contains the modulus. For the binary case, +-- this will be a power of 2, but if Non_Binary_Modulus is set, then it +-- will not be a power of 2. -- Must_Be_On_Byte_Boundary (Flag183) --- Present in entities for types and subtypes. Set if objects of --- the type must always be allocated on a byte boundary (more --- accurately a storage unit boundary). The front end checks that --- component clauses respect this rule, and the back end ensures --- that record packing does not violate this rule. Currently the --- flag is set only for packed arrays longer than 64 bits where --- the component size is not a power of 2. +-- Present in entities for types and subtypes. Set if objects of the type +-- must always be allocated on a byte boundary (more accurately a storage +-- unit boundary). The front end checks that component clauses respect +-- this rule, and the back end ensures that record packing does not +-- violate this rule. Currently the flag is set only for packed arrays +-- longer than 64 bits where the component size is not a power of 2. -- Must_Have_Preelab_Init (Flag208) -- Present in entities for types and subtypes. Set in the full type of a diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb index 49068ef2387..6a6142d4121 100644 --- a/gcc/ada/errout.adb +++ b/gcc/ada/errout.adb @@ -752,7 +752,8 @@ package body Errout is null; -- If the main unit has not been read yet. the warning must be on - -- a configuration file: gnat.adc or user-defined. + -- a configuration file: gnat.adc or user-defined. This means we + -- are not parsing the main unit yet, so skip following checks. elsif No (Cunit (Main_Unit)) then null; diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index b797648e7d5..27602cd64a6 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -2174,7 +2174,7 @@ package body Exp_Aggr is begin Btype := Base_Type (Typ); while Is_Derived_Type (Btype) - and then Present (Stored_Constraint (Btype)) + and then Present (Stored_Constraint (Btype)) loop Parent_Type := Etype (Btype); diff --git a/gcc/ada/fname-uf.adb b/gcc/ada/fname-uf.adb index 1e550c1d45e..e3a731fefae 100644 --- a/gcc/ada/fname-uf.adb +++ b/gcc/ada/fname-uf.adb @@ -73,8 +73,8 @@ package body Fname.UF is Key => Unit_Name_Type, Hash => SFN_Hash, Equal => "="); - -- Hash table allowing rapid access to SFN_Table, the element value - -- is an index into this table. + -- Hash table allowing rapid access to SFN_Table, the element value is an + -- index into this table. type SFN_Pattern_Entry is record Pat : String_Ptr; -- File name pattern (with asterisk in it) @@ -91,9 +91,8 @@ package body Fname.UF is Table_Initial => 10, Table_Increment => 100, Table_Name => "SFN_Patterns"); - -- Table recording all calls to Set_File_Name_Pattern. Note that the - -- first two entries are set to represent the standard GNAT rules - -- for file naming. + -- Table recording calls to Set_File_Name_Pattern. Note that the first two + -- entries are set to represent the standard GNAT rules for file naming. ----------------------- -- File_Name_Of_Body -- @@ -127,9 +126,9 @@ package body Fname.UF is (Fname : File_Name_Type) return Expected_Unit_Type is begin - -- In syntax checking only mode or in multiple unit per file mode, - -- there can be more than one unit in a file, so the file name is - -- not a useful guide to the nature of the unit. + -- In syntax checking only mode or in multiple unit per file mode, there + -- can be more than one unit in a file, so the file name is not a useful + -- guide to the nature of the unit. if Operating_Mode = Check_Syntax or else Multiple_Unit_Index /= 0 @@ -137,8 +136,8 @@ package body Fname.UF is return Unknown; end if; - -- Search the file mapping table, if we find an entry for this - -- file we know whether it is a spec or a body. + -- Search the file mapping table, if we find an entry for this file we + -- know whether it is a spec or a body. for J in SFN_Table.First .. SFN_Table.Last loop if Fname = SFN_Table.Table (J).F then @@ -150,8 +149,8 @@ package body Fname.UF is end if; end loop; - -- If no entry in file naming table, assume .ads/.adb for spec/body - -- and return unknown if we have neither of these two cases. + -- If no entry in file naming table, assume .ads/.adb for spec/body and + -- return unknown if we have neither of these two cases. Get_Name_String (Fname); @@ -179,8 +178,8 @@ package body Fname.UF is -- Set to 's' or 'b' for spec or body or to 'u' for a subunit Unit_Char_Search : Character; - -- Same as Unit_Char, except that in the case of 'u' for a subunit, - -- we set Unit_Char_Search to 'b' if we do not find a subunit match. + -- Same as Unit_Char, except that in the case of 'u' for a subunit, we + -- set Unit_Char_Search to 'b' if we do not find a subunit match. N : Int; @@ -189,8 +188,8 @@ package body Fname.UF is -- Path name and File name for mapping begin - -- Null or error name means that some previous error occurred - -- This is an unrecoverable error, so signal it. + -- Null or error name means that some previous error occurred. This is + -- an unrecoverable error, so signal it. if Uname in Error_Unit_Name_Or_No_Unit_Name then raise Unrecoverable_Error; @@ -200,8 +199,8 @@ package body Fname.UF is Fname := Mapped_File_Name (Uname); - -- If the unit name is already mapped, return the corresponding - -- file name from the map. + -- If the unit name is already mapped, return the corresponding file + -- name from the map. if Fname /= No_File then return Fname; @@ -232,9 +231,9 @@ package body Fname.UF is -- _and_.ads - -- which is bit peculiar, but we keep it that way. This means that - -- we avoid bombs due to writing a bad file name, and w get expected - -- error processing downstream, e.g. a compilation following gnatchop. + -- which is bit peculiar, but we keep it that way. This means that we + -- avoid bombs due to writing a bad file name, and w get expected error + -- processing downstream, e.g. a compilation following gnatchop. if Name_Buffer (1) = '"' then Get_Name_String (Uname); @@ -283,12 +282,12 @@ package body Fname.UF is -- Start of search through pattern table begin - -- Search pattern table to find a matching entry. In the general - -- case we do two complete searches. The first time through we - -- stop only if a matching file is found, the second time through - -- we accept the first match regardless. Note that there will - -- always be a match the second time around, because of the - -- default entries at the end of the table. + -- Search pattern table to find a matching entry. In the general case + -- we do two complete searches. The first time through we stop only + -- if a matching file is found, the second time through we accept the + -- first match regardless. Note that there will always be a match the + -- second time around, because of the default entries at the end of + -- the table. for No_File_Check in False .. True loop Unit_Char_Search := Unit_Char; @@ -345,8 +344,8 @@ package body Fname.UF is J := J + Dotl; - -- Skip past wide char sequences to avoid messing - -- with dot characters that are part of a sequence. + -- Skip past wide char sequences to avoid messing with + -- dot characters that are part of a sequence. elsif Name_Buffer (J) = ASCII.ESC or else (Upper_Half_Encoding @@ -421,8 +420,8 @@ package body Fname.UF is Name_Len := Name_Len + Ext'Length; end; - -- Case of no extension present, straight krunch on - -- the entire file name. + -- Case of no extension present, straight krunch on the + -- entire file name. else Krunch @@ -435,9 +434,9 @@ package body Fname.UF is Fnam := Name_Find; -- If we are in the second search of the table, we accept - -- the file name without checking, because we know that - -- the file does not exist, except when May_Fail is True, - -- in which case we return No_File. + -- the file name without checking, because we know that the + -- file does not exist, except when May_Fail is True, in + -- which case we return No_File. if No_File_Check then if May_Fail then @@ -451,26 +450,25 @@ package body Fname.UF is else Pname := Find_File (Fnam, Source); - -- If it does exist, we add it to the mappings and - -- return the file name. + -- If it does exist, we add it to the mappings and return + -- the file name. if Pname /= No_File then - -- Add to mapping, so that we don't do another - -- path search in Find_File for this file name - -- and, if we use a mapping file, we are ready - -- to update it at the end of this compilation - -- for the benefit of other compilation processes. + -- Add to mapping, so that we don't do another path + -- search in Find_File for this file name and, if we + -- use a mapping file, we are ready to update it at + -- the end of this compilation for the benefit of + -- other compilation processes. Add_To_File_Map (Get_File_Name.Uname, Fnam, Pname); return Fnam; - -- If there are only two entries, they are those of - -- the default GNAT naming scheme. The file does - -- not exist, but there is no point doing the - -- second search, because we will end up with the - -- same file name. Just return the file name, or No_File - -- if May_Fail is True. + -- If there are only two entries, they are those of the + -- default GNAT naming scheme. The file does not exist, + -- but there is no point doing the second search, because + -- we will end up with the same file name. Just return + -- the file name, or No_File if May_Fail is True. elsif SFN_Patterns.Last = 2 then if May_Fail then @@ -479,8 +477,8 @@ package body Fname.UF is return Fnam; end if; - -- The file does not exist, but there may be other - -- naming scheme. Keep on searching. + -- The file does not exist, but there may be other naming + -- scheme. Keep on searching. else Fnam := No_File; @@ -491,9 +489,9 @@ package body Fname.UF is Pent := Pent + 1; end loop; - -- If search failed, and was for a subunit, repeat the search - -- with Unit_Char_Search reset to 'b', since in the normal case - -- we simply treat subunits as bodies. + -- If search failed, and was for a subunit, repeat the search with + -- Unit_Char_Search reset to 'b', since in the normal case we + -- simply treat subunits as bodies. if Fnam = No_File and then Unit_Char_Search = 'u' then Unit_Char_Search := 'b'; @@ -504,8 +502,8 @@ package body Fname.UF is end loop; - -- Something is wrong if search fails completely, since the - -- default entries should catch all possibilities at this stage. + -- Something is wrong if search fails completely, since the default + -- entries should catch all possibilities at this stage. raise Program_Error; end; @@ -534,8 +532,8 @@ package body Fname.UF is SFN_Table.Init; SFN_Patterns.Init; - -- Add default entries to SFN_Patterns.Table to represent the - -- standard default GNAT rules for file name translation. + -- Add default entries to SFN_Patterns.Table to represent the standard + -- default GNAT rules for file name translation. SFN_Patterns.Append (New_Val => (Pat => new String'("*.ads"), @@ -590,9 +588,9 @@ package body Fname.UF is begin SFN_Patterns.Increment_Last; - -- Move up the last two entries (the default ones) and then - -- put the new entry into the table just before them (we - -- always have the default entries be the last ones). + -- Move up the last two entries (the default ones) and then put the new + -- entry into the table just before them (we always have the default + -- entries be the last ones). SFN_Patterns.Table (L + 1) := SFN_Patterns.Table (L); SFN_Patterns.Table (L) := SFN_Patterns.Table (L - 1); diff --git a/gcc/ada/g-pehage.adb b/gcc/ada/g-pehage.adb index b08f530b434..ce2428ddd85 100644 --- a/gcc/ada/g-pehage.adb +++ b/gcc/ada/g-pehage.adb @@ -909,10 +909,11 @@ package body GNAT.Perfect_Hash_Generators is New_Line (Output); end if; - -- Deallocate all the WT components (both initial and reduced - -- ones) to avoid memory leaks. + -- Deallocate all the WT components (both initial and reduced ones) to + -- avoid memory leaks. for W in 0 .. WT.Last loop + -- Note: WT.Table (NK) is a temporary variable, do not free it since -- this would cause a double free. diff --git a/gcc/ada/get_alfa.adb b/gcc/ada/get_alfa.adb index 95a0f94008b..e78badcd0c8 100644 --- a/gcc/ada/get_alfa.adb +++ b/gcc/ada/get_alfa.adb @@ -29,7 +29,7 @@ with Types; use Types; with Ada.IO_Exceptions; use Ada.IO_Exceptions; procedure Get_ALFA is - C : Character; + C : Character; use ASCII; -- For CR/LF @@ -56,9 +56,8 @@ procedure Get_ALFA is ----------------------- function At_EOL return Boolean; - -- Skips any spaces, then checks if we are the end of a line. If so, - -- returns True (but does not skip over the EOL sequence). If not, - -- then returns False. + -- Skips any spaces, then checks if at the end of a line. If so, returns + -- True (but does not skip the EOL sequence). If not, then returns False. procedure Check (C : Character); -- Checks that file is positioned at given character, and if so skips past @@ -72,8 +71,8 @@ procedure Get_ALFA is procedure Get_Name; -- On entry the file is positioned to a name. On return, the file is - -- positioned past the last character, and the name scanned is returned in - -- Name_Str (1 .. Name_Len). + -- positioned past the last character, and the name scanned is returned + -- in Name_Str (1 .. Name_Len). procedure Skip_EOL; -- Called with the current character about to be read being LF or CR. Skips @@ -355,10 +354,10 @@ begin XR_Entity_Line : Nat; XR_Entity_Col : Nat; - XR_File : Nat; + XR_File : Nat; -- Keeps track of the current file (changed by nn|) - XR_Scope : Nat; + XR_Scope : Nat; -- Keeps track of the current scope (changed by nn:) begin @@ -413,9 +412,10 @@ begin Rtype := Getc; Col := Get_Nat; - pragma Assert (Rtype = 'r' - or else Rtype = 'm' - or else Rtype = 's'); + pragma Assert + (Rtype = 'r' or else + Rtype = 'm' or else + Rtype = 's'); ALFA_Xref_Table.Append ( (Entity_Name => XR_Entity, @@ -438,16 +438,14 @@ begin raise Data_Error; end case; - -- For cross reference lines, the end-of-line character has been skipped - -- already. + -- For cross reference lines, the EOL character has been skipped already if C /= ' ' then Skip_EOL; end if; end loop; - -- Here with all Xrefs stored, complete last entries in File and Scope - -- tables. + -- Here with all Xrefs stored, complete last entries in File/Scope tables if ALFA_File_Table.Last /= 0 then ALFA_File_Table.Table (ALFA_File_Table.Last).To_Scope := diff --git a/gcc/ada/gnatcmd.adb b/gcc/ada/gnatcmd.adb index 2f72c8d584c..99d6953c423 100644 --- a/gcc/ada/gnatcmd.adb +++ b/gcc/ada/gnatcmd.adb @@ -1349,7 +1349,7 @@ begin Prj.Tree.Initialize (Root_Environment, Gnatmake_Flags); Prj.Env.Initialize_Default_Project_Path - (Root_Environment.Project_Path, Target_Name => ""); + (Root_Environment.Project_Path, Target_Name => ""); Project_Node_Tree := new Project_Node_Tree_Data; Prj.Tree.Initialize (Project_Node_Tree); diff --git a/gcc/ada/lib-writ.adb b/gcc/ada/lib-writ.adb index eb33a1a207f..78a55ed8a59 100644 --- a/gcc/ada/lib-writ.adb +++ b/gcc/ada/lib-writ.adb @@ -1307,8 +1307,7 @@ package body Lib.Writ is -- Output ALFA information if needed if Opt.Xref_Active and then ALFA_Mode then - Collect_ALFA (Sdep_Table => Sdep_Table, - Num_Sdep => Num_Sdep); + Collect_ALFA (Sdep_Table => Sdep_Table, Num_Sdep => Num_Sdep); Output_ALFA; end if; diff --git a/gcc/ada/lib-xref-alfa.adb b/gcc/ada/lib-xref-alfa.adb index a5dca53ab8a..94d2725b7d5 100644 --- a/gcc/ada/lib-xref-alfa.adb +++ b/gcc/ada/lib-xref-alfa.adb @@ -35,7 +35,8 @@ package body ALFA is -- Local Constants -- --------------------- - -- True for each entity kind used in ALFA + -- Table of ALFA_Entities, True for each entity kind used in ALFA + ALFA_Entities : constant array (Entity_Kind) of Boolean := (E_Void => False, E_Variable => True, @@ -171,6 +172,7 @@ package body ALFA is From : Scope_Index; S : constant Source_File_Index := Source_Index (U); + begin -- Source file could be inexistant as a result of an error, if option -- gnatQ is used. @@ -409,11 +411,11 @@ package body ALFA is T2 : constant Xref_Entry := Xrefs.Table (Rnums (Nat (Op2))); begin - -- First test: if entity is in different unit, sort by unit. Notice + -- First test: if entity is in different unit, sort by unit. Note: -- that we use Ent_Scope_File rather than Eun, as Eun may refer to - -- the file where the generic scope is defined, and it may be - -- different from the file where the enclosing scope is defined. It - -- is the latter which matters for a correct order here. + -- the file where the generic scope is defined, which may differ from + -- the file where the enclosing scope is defined. It is the latter + -- which matters for a correct order here. if T1.Ent_Scope_File /= T2.Ent_Scope_File then return Dependency_Num (T1.Ent_Scope_File) < @@ -472,12 +474,11 @@ package body ALFA is elsif T1.Loc /= T2.Loc then return T1.Loc < T2.Loc; - -- Finally, for two locations at the same address, we prefer the one - -- that does NOT have the type 'r' so that a modification or - -- extension takes preference, when there are more than one reference - -- at the same location. As a result, in the case of entities that - -- are in-out actuals, the read reference follows the modify - -- reference. + -- Finally, for two locations at the same address prefer the one that + -- does NOT have the type 'r', so that a modification or extension + -- takes preference, when there are more than one reference at the + -- same location. As a result, in the case of entities that are + -- in-out actuals, the read reference follows the modify reference. else return T2.Typ = 'r'; @@ -507,10 +508,9 @@ package body ALFA is Rnums (J) := J; end loop; - -- Eliminate entries not appropriate for ALFA. Should be prior to - -- sorting cross-references, as it discards useless references which do - -- not have a proper format for the comparison function (like no - -- location). + -- Eliminate entries not appropriate for ALFA. Done prior to sorting + -- cross-references, as it discards useless references which do not have + -- a proper format for the comparison function (like no location). Eliminate_Before_Sort : declare NR : Nat; @@ -553,7 +553,7 @@ package body ALFA is Sorting.Sort (Integer (Nrefs)); Eliminate_After_Sort : declare - NR : Nat; + NR : Nat; Crloc : Source_Ptr; -- Current reference location @@ -583,8 +583,8 @@ package body ALFA is end if; -- Eliminate the reference if it is at the same location as the - -- previous one, unless it is a read-reference that indicates that - -- the entity is an in-out actual in a call. + -- previous one, unless it is a read-reference indicating that the + -- entity is an in-out actual in a call. NR := Nrefs; Nrefs := 0; @@ -625,8 +625,8 @@ package body ALFA is ----------------------- function Cur_Scope return Node_Id; - -- Return the scope entity which corresponds to index - -- Cur_Scope_Idx in table ALFA_Scope_Table. + -- Return scope entity which corresponds to index Cur_Scope_Idx in + -- table ALFA_Scope_Table. function Is_Future_Scope_Entity (E : Entity_Id) return Boolean; -- Check whether entity E is in ALFA_Scope_Table at index @@ -688,10 +688,10 @@ package body ALFA is XE : Xref_Entry renames Xrefs.Table (Rnums (Refno)); begin - -- If this assertion fails, this means that the scope which we - -- are looking for is not in ALFA scope table, which reveals - -- either a problem in the construction of the scope table, or an - -- erroneous scope for the current cross-reference. + -- If this assertion fails, the scope which we are looking for is + -- not in ALFA scope table, which reveals either a problem in the + -- construction of the scope table, or an erroneous scope for the + -- current cross-reference. pragma Assert (Is_Future_Scope_Entity (XE.Ent_Scope)); diff --git a/gcc/ada/lib.ads b/gcc/ada/lib.ads index 845b45ab6c7..76810c22862 100644 --- a/gcc/ada/lib.ads +++ b/gcc/ada/lib.ads @@ -555,8 +555,10 @@ package Lib is -- called after Sprint has been called with -gnatD set. function Exact_Source_Name (Loc : Source_Ptr) return String; - -- Return the name of an entity at location Loc exactly as written in the - -- source. + -- Return name of entity at location Loc exactly as written in the source. + -- this includes copying the wide character encodings exactly as they were + -- used in the source, so the caller must be aware of the possibility of + -- such encodings. function Compilation_Switches_Last return Nat; -- Return the count of stored compilation switches diff --git a/gcc/ada/make.adb b/gcc/ada/make.adb index 4901928ccd6..73f022e9d5e 100644 --- a/gcc/ada/make.adb +++ b/gcc/ada/make.adb @@ -6650,7 +6650,7 @@ package body Make is Prj.Tree.Initialize (Env, Gnatmake_Flags); Prj.Env.Initialize_Default_Project_Path - (Env.Project_Path, Target_Name => ""); + (Env.Project_Path, Target_Name => ""); Project_Node_Tree := new Project_Node_Tree_Data; Prj.Tree.Initialize (Project_Node_Tree); diff --git a/gcc/ada/makeutl.adb b/gcc/ada/makeutl.adb index 743ea6d492e..a8c54e640e0 100644 --- a/gcc/ada/makeutl.adb +++ b/gcc/ada/makeutl.adb @@ -23,12 +23,6 @@ -- -- ------------------------------------------------------------------------------ -with Ada.Command_Line; use Ada.Command_Line; - -with GNAT.Case_Util; use GNAT.Case_Util; -with GNAT.Directory_Operations; use GNAT.Directory_Operations; -with GNAT.HTable; - with ALI; use ALI; with Debug; with Fname; @@ -42,6 +36,12 @@ with Snames; use Snames; with Table; with Tempdir; +with Ada.Command_Line; use Ada.Command_Line; + +with GNAT.Case_Util; use GNAT.Case_Util; +with GNAT.Directory_Operations; use GNAT.Directory_Operations; +with GNAT.HTable; + package body Makeutl is type Mark_Key is record diff --git a/gcc/ada/makeutl.ads b/gcc/ada/makeutl.ads index 8e9e151ee74..28b59c57ca4 100644 --- a/gcc/ada/makeutl.ads +++ b/gcc/ada/makeutl.ads @@ -163,12 +163,11 @@ package Makeutl is Value : out Variable_Value; Is_Default : out Boolean); -- Compute the switches (Compilation switches for instance) for the given - -- file. This checks various attributes to see whether there are file - -- specific switches, or else defaults on the switches for the - -- corresponding language. - -- Is_Default is set to False if there were file-specific switches - -- Source_File can be set to No_File to force retrieval of the default - -- switches. + -- file. This checks various attributes to see if there are file specific + -- switches, or else defaults on the switches for the corresponding + -- language. Is_Default is set to False if there were file-specific + -- switches Source_File can be set to No_File to force retrieval of + -- the default switches. function Linker_Options_Switches (Project : Project_Id; diff --git a/gcc/ada/prj-attr.ads b/gcc/ada/prj-attr.ads index b171719de69..03e63d140f9 100644 --- a/gcc/ada/prj-attr.ads +++ b/gcc/ada/prj-attr.ads @@ -154,18 +154,19 @@ package Prj.Attr is -- Attribute is Empty_Attribute. -- -- To use this function, the following code should be used: + -- -- Pkg : constant Package_Node_Id := - -- Prj.Attr.Package_Node_Id_Of (Name => ); + -- Prj.Attr.Package_Node_Id_Of (Name => ); -- Att : constant Attribute_Node_Id := - -- Prj.Attr.Attribute_Node_Id_Of - -- (Name => , - -- Starting_At => First_Attribute_Of (Pkg)); + -- Prj.Attr.Attribute_Node_Id_Of + -- (Name => , + -- Starting_At => First_Attribute_Of (Pkg)); -- Kind : constant Attribute_Kind := Attribute_Kind_Of (Att); -- - -- However, you should not use this function once you have an already - -- parsed project tree. Instead, given a Project_Node_Id corresponding to - -- the attribute declaration ("for Attr (index) use ..."), it is simpler to - -- use + -- However, do not use this function once you have an already parsed + -- project tree. Instead, given a Project_Node_Id corresponding to the + -- attribute declaration ("for Attr (index) use ..."), use for example: + -- -- if Case_Insensitive (Attr, Tree) then ... procedure Set_Attribute_Kind_Of diff --git a/gcc/ada/prj-env.adb b/gcc/ada/prj-env.adb index 52f6236e049..62852220b37 100644 --- a/gcc/ada/prj-env.adb +++ b/gcc/ada/prj-env.adb @@ -1784,7 +1784,7 @@ package body Prj.Env is begin return Self.Path /= null and then (Self.Path'Length = 0 - or else Self.Path (Self.Path'First) /= '#'); + or else Self.Path (Self.Path'First) /= '#'); end Is_Initialized; ---------------------- @@ -1802,7 +1802,8 @@ package body Prj.Env is ------------------------------------- procedure Initialize_Default_Project_Path - (Self : in out Project_Search_Path; Target_Name : String) + (Self : in out Project_Search_Path; + Target_Name : String) is Add_Default_Dir : Boolean := True; First : Positive; @@ -1984,9 +1985,7 @@ package body Prj.Env is -- Get_Path -- -------------- - procedure Get_Path - (Self : Project_Search_Path; - Path : out String_Access) is + procedure Get_Path (Self : Project_Search_Path; Path : out String_Access) is begin pragma Assert (Is_Initialized (Self)); Path := Self.Path; @@ -1996,8 +1995,7 @@ package body Prj.Env is -- Set_Path -- -------------- - procedure Set_Path - (Self : in out Project_Search_Path; Path : String) is + procedure Set_Path (Self : in out Project_Search_Path; Path : String) is begin Free (Self.Path); Self.Path := new String'(Path); diff --git a/gcc/ada/prj-env.ads b/gcc/ada/prj-env.ads index aec975d859b..61c043108b9 100644 --- a/gcc/ada/prj-env.ads +++ b/gcc/ada/prj-env.ads @@ -163,16 +163,16 @@ package Prj.Env is -- efficiency). procedure Initialize_Default_Project_Path - (Self : in out Project_Search_Path; Target_Name : String); - -- Initialize Self. - -- It will then contain the default project path on the given target - -- (including directories specified by the environment variables - -- ADA_PROJECT_PATH and GPR_PROJECT_PATH). - -- This does nothing if Self has already been initialized. + (Self : in out Project_Search_Path; + Target_Name : String); + -- Initialize Self. It will then contain the default project path on the + -- given target (including directories specified by the environment + -- variables ADA_PROJECT_PATH and GPR_PROJECT_PATH). This does nothing if + -- Self has already been initialized. procedure Initialize_Empty (Self : in out Project_Search_Path); - -- Initialize self with an empty list of directories. - -- If Self had already been set, it is reset. + -- Initialize self with an empty list of directories. If Self had already + -- been set, it is reset. function Is_Initialized (Self : Project_Search_Path) return Boolean; -- Whether Self has been initialized @@ -191,19 +191,16 @@ package Prj.Env is -- Calls to this subprogram must be performed before the first call to -- Find_Project below, or PATH will be added at the end of the search path. - procedure Get_Path - (Self : Project_Search_Path; - Path : out String_Access); + procedure Get_Path (Self : Project_Search_Path; Path : out String_Access); -- Return the current value of the project path, either the value set -- during elaboration of the package or, if procedure Set_Project_Path has -- been called, the value set by the last call to Set_Project_Path. The -- returned value must not be modified. -- Self must have been initialized first. - procedure Set_Path - (Self : in out Project_Search_Path; Path : String); + procedure Set_Path (Self : in out Project_Search_Path; Path : String); -- Override the value of the project path. This also removes the implicit - -- default search directories + -- default search directories. procedure Find_Project (Self : in out Project_Search_Path; @@ -213,9 +210,7 @@ package Prj.Env is -- Search for a project with the given name either in Directory (which -- often will be the directory contain the project we are currently parsing -- and which we found a reference to another project), or in the project - -- path Self. - -- - -- Self must have been initialized first. + -- path Self. Self must have been initialized first. -- -- Project_File_Name can optionally contain directories, and the extension -- (.gpr) for the file name is optional. diff --git a/gcc/ada/prj-ext.adb b/gcc/ada/prj-ext.adb index ee6d2c32935..b9885c310a7 100644 --- a/gcc/ada/prj-ext.adb +++ b/gcc/ada/prj-ext.adb @@ -23,9 +23,10 @@ -- -- ------------------------------------------------------------------------------ -with Ada.Unchecked_Deallocation; with Osint; use Osint; +with Ada.Unchecked_Deallocation; + package body Prj.Ext is ---------------- @@ -65,6 +66,7 @@ package body Prj.Ext is Value : String) is N : Name_To_Name_Ptr; + begin N := new Name_To_Name; @@ -179,6 +181,7 @@ package body Prj.Ext is Debug_Output ("Value_Of (" & Get_Name_String (External_Name) & ") is default", With_Default); end if; + Free (Env_Value); return With_Default; end if; diff --git a/gcc/ada/prj-ext.ads b/gcc/ada/prj-ext.ads index 26ad2199301..4ea46080814 100644 --- a/gcc/ada/prj-ext.ads +++ b/gcc/ada/prj-ext.ads @@ -79,7 +79,8 @@ package Prj.Ext is private - -- Use a Static_HTable, not a Simple_HTable. + -- Use a Static_HTable, rather than a Simple_HTable + -- The issue is that we need to be able to copy the contents of the table -- (in Initialize), but this isn't doable for Simple_HTable for which -- iterators do not return the key. diff --git a/gcc/ada/prj-makr.adb b/gcc/ada/prj-makr.adb index 439ac0598a4..678492106c1 100644 --- a/gcc/ada/prj-makr.adb +++ b/gcc/ada/prj-makr.adb @@ -802,7 +802,7 @@ package body Prj.Makr is Prj.Tree.Initialize (Root_Environment, Flags); Prj.Env.Initialize_Default_Project_Path - (Root_Environment.Project_Path, Target_Name => ""); + (Root_Environment.Project_Path, Target_Name => ""); Prj.Tree.Initialize (Tree); diff --git a/gcc/ada/prj-nmsc.adb b/gcc/ada/prj-nmsc.adb index d05af1b39f2..743a1fc79ca 100644 --- a/gcc/ada/prj-nmsc.adb +++ b/gcc/ada/prj-nmsc.adb @@ -197,8 +197,8 @@ package body Prj.Nmsc is -- Free the memory occupied by Data procedure Check - (Project : Project_Id; - Data : in out Tree_Processing_Data); + (Project : Project_Id; + Data : in out Tree_Processing_Data); -- Process the naming scheme for a single project procedure Initialize @@ -241,12 +241,15 @@ package body Prj.Nmsc is -- directories that match the globbing patterns found in Patterns (for -- instance "**/*.adb"). Typically, Patterns will be the value of the -- Source_Dirs or Excluded_Source_Dirs attributes. + -- -- Every time such a file or directory is found, the callback is called. -- Resolve_Links indicates whether we should resolve links while -- normalizing names. + -- -- In the callback, Pattern_Index is the index within Patterns where the -- expanded pattern was found (1 for the first element of Patterns and -- all its matching directories, then 2,...). + -- -- We use a generic and not an access-to-subprogram because in some cases -- this code is compiled with the restriction No_Implicit_Dynamic_Code. -- An error message is raised if a pattern does not match any file. @@ -269,15 +272,12 @@ package body Prj.Nmsc is Location : Source_Ptr := No_Location); -- Add a new source to the different lists: list of all sources in the -- project tree, list of source of a project and list of sources of a - -- language. - -- - -- If Path is specified, the file is also added to Source_Paths_HT. - -- - -- Location is used for error messages + -- language. If Path is specified, the file is also added to + -- Source_Paths_HT. Location is used for error messages function Canonical_Case_File_Name (Name : Name_Id) return File_Name_Type; -- Same as Osint.Canonical_Case_File_Name but applies to Name_Id. - -- This alters Name_Buffer + -- This alters Name_Buffer. function Suffix_Matches (Filename : String; @@ -924,16 +924,16 @@ package body Prj.Nmsc is --------------------------------- procedure Process_Aggregated_Projects - (Tree : Project_Tree_Ref; - Project : Project_Id; - Node_Tree : Prj.Tree.Project_Node_Tree_Ref; - Flags : Processing_Flags) + (Tree : Project_Tree_Ref; + Project : Project_Id; + Node_Tree : Prj.Tree.Project_Node_Tree_Ref; + Flags : Processing_Flags) is Data : Tree_Processing_Data := - (Tree => Tree, - Node_Tree => Node_Tree, - File_To_Source => Files_Htable.Nil, - Flags => Flags); + (Tree => Tree, + Node_Tree => Node_Tree, + File_To_Source => Files_Htable.Nil, + Flags => Flags); Project_Files : constant Prj.Variable_Value := Prj.Util.Value_Of @@ -949,8 +949,7 @@ package body Prj.Nmsc is procedure Expand_Project_Files is new Expand_Subdirectory_Pattern (Callback => Found_Project_File); -- Search for all project files referenced by the patterns given in - -- parameter. - -- Calls Found_Project_File for each of them + -- parameter. Calls Found_Project_File for each of them. ------------------------ -- Found_Project_File -- @@ -966,6 +965,7 @@ package body Prj.Nmsc is -- can only do this when processing the aggregate project, since the -- exact list of project files or project directories can depend on -- scenario variables. + -- -- We only load the projects explicitly here, but do not process -- them. For the processing, Prj.Proc will take care of processing -- them, within the same call to Recursive_Process (thus avoiding the @@ -1065,7 +1065,7 @@ package body Prj.Nmsc is (Project : Project_Id; Data : in out Tree_Processing_Data) is - Prj_Data : Project_Processing_Data; + Prj_Data : Project_Processing_Data; begin Debug_Increase_Indent ("Check", Project.Name); @@ -6387,6 +6387,7 @@ package body Prj.Nmsc is if Current_Verbosity = High then Debug_Indent; + if Source.Path /= No_Path_Information then Write_Line ("Setting full path for " & Get_Name_String (Source.File) diff --git a/gcc/ada/prj-nmsc.ads b/gcc/ada/prj-nmsc.ads index 47ae06b61da..fd45ba91e7f 100644 --- a/gcc/ada/prj-nmsc.ads +++ b/gcc/ada/prj-nmsc.ads @@ -43,10 +43,10 @@ private package Prj.Nmsc is -- information is only valid while the external references are preserved. procedure Process_Aggregated_Projects - (Tree : Project_Tree_Ref; - Project : Project_Id; - Node_Tree : Prj.Tree.Project_Node_Tree_Ref; - Flags : Processing_Flags); + (Tree : Project_Tree_Ref; + Project : Project_Id; + Node_Tree : Prj.Tree.Project_Node_Tree_Ref; + Flags : Processing_Flags); -- Assuming Project is an aggregate project, find out (based on the -- current external references) what are the projects it aggregates. -- This has to be done in phase 1 of the processing, so that we know the diff --git a/gcc/ada/prj-pars.ads b/gcc/ada/prj-pars.ads index fcfde916117..fb424a90033 100644 --- a/gcc/ada/prj-pars.ads +++ b/gcc/ada/prj-pars.ads @@ -42,6 +42,7 @@ package Prj.Pars is Env : in out Prj.Tree.Environment); -- Parse and process a project files and all its imported project files, in -- the project tree In_Tree. + -- -- All the project files are parsed (through Prj.Tree) to create a tree in -- memory. That tree is then processed (through Prj.Proc) to create a -- expanded representation of the tree based on the current external diff --git a/gcc/ada/prj-part.adb b/gcc/ada/prj-part.adb index b75716729b7..dbb5473727c 100644 --- a/gcc/ada/prj-part.adb +++ b/gcc/ada/prj-part.adb @@ -440,16 +440,16 @@ package body Prj.Part is ----------- procedure Parse - (In_Tree : Project_Node_Tree_Ref; - Project : out Project_Node_Id; - Project_File_Name : String; - Errout_Handling : Errout_Mode := Always_Finalize; - Packages_To_Check : String_List_Access := All_Packages; - Store_Comments : Boolean := False; - Current_Directory : String := ""; - Is_Config_File : Boolean; - Env : in out Prj.Tree.Environment; - Target_Name : String := "") + (In_Tree : Project_Node_Tree_Ref; + Project : out Project_Node_Id; + Project_File_Name : String; + Errout_Handling : Errout_Mode := Always_Finalize; + Packages_To_Check : String_List_Access := All_Packages; + Store_Comments : Boolean := False; + Current_Directory : String := ""; + Is_Config_File : Boolean; + Env : in out Prj.Tree.Environment; + Target_Name : String := "") is Dummy : Boolean; pragma Warnings (Off, Dummy); diff --git a/gcc/ada/prj-part.ads b/gcc/ada/prj-part.ads index 16b84abb502..1184c77a08d 100644 --- a/gcc/ada/prj-part.ads +++ b/gcc/ada/prj-part.ads @@ -38,16 +38,16 @@ package Prj.Part is -- either at the beginning of Parse. procedure Parse - (In_Tree : Project_Node_Tree_Ref; - Project : out Project_Node_Id; - Project_File_Name : String; - Errout_Handling : Errout_Mode := Always_Finalize; - Packages_To_Check : String_List_Access := All_Packages; - Store_Comments : Boolean := False; - Current_Directory : String := ""; - Is_Config_File : Boolean; - Env : in out Prj.Tree.Environment; - Target_Name : String := ""); + (In_Tree : Project_Node_Tree_Ref; + Project : out Project_Node_Id; + Project_File_Name : String; + Errout_Handling : Errout_Mode := Always_Finalize; + Packages_To_Check : String_List_Access := All_Packages; + Store_Comments : Boolean := False; + Current_Directory : String := ""; + Is_Config_File : Boolean; + Env : in out Prj.Tree.Environment; + Target_Name : String := ""); -- Parse project file and all its imported project files and create a tree. -- Return the node for the project (or Empty_Node if parsing failed). If -- Always_Errout_Finalize is True, Errout.Finalize is called in all cases, diff --git a/gcc/ada/prj-proc.adb b/gcc/ada/prj-proc.adb index be3a0a7f3bf..f83a05f6c97 100644 --- a/gcc/ada/prj-proc.adb +++ b/gcc/ada/prj-proc.adb @@ -125,13 +125,13 @@ package body Prj.Proc is -- Find the package of Project whose name is With_Name procedure Process_Declarative_Items - (Project : Project_Id; - In_Tree : Project_Tree_Ref; - From_Project_Node : Project_Node_Id; - Node_Tree : Project_Node_Tree_Ref; - Env : Prj.Tree.Environment; - Pkg : Package_Id; - Item : Project_Node_Id); + (Project : Project_Id; + In_Tree : Project_Tree_Ref; + From_Project_Node : Project_Node_Id; + Node_Tree : Project_Node_Tree_Ref; + Env : Prj.Tree.Environment; + Pkg : Package_Id; + Item : Project_Node_Id); -- Process declarative items starting with From_Project_Node, and put them -- in declarations Decl. This is a recursive procedure; it calls itself for -- a package declaration or a case construction. @@ -460,7 +460,8 @@ package body Prj.Proc is function Get_Attribute_Index (Tree : Project_Node_Tree_Ref; Attr : Project_Node_Id; - Index : Name_Id) return Name_Id is + Index : Name_Id) return Name_Id + is begin if Index = All_Other_Names or else not Case_Insensitive (Attr, Tree) @@ -580,7 +581,7 @@ package body Prj.Proc is if Present (String_Node) then -- If String_Node is nil, it is an empty list, there is - -- nothing to do + -- nothing to do. Value := Expression (Project => Project, @@ -623,7 +624,7 @@ package body Prj.Proc is loop -- Add the other element of the literal string list - -- one after the other + -- one after the other. String_Node := Next_Expression_In_List @@ -646,11 +647,10 @@ package body Prj.Proc is String_Element_Table.Increment_Last (In_Tree.String_Elements); - In_Tree.String_Elements.Table - (Last).Next := String_Element_Table.Last - (In_Tree.String_Elements); - Last := String_Element_Table.Last - (In_Tree.String_Elements); + In_Tree.String_Elements.Table (Last).Next := + String_Element_Table.Last (In_Tree.String_Elements); + Last := + String_Element_Table.Last (In_Tree.String_Elements); In_Tree.String_Elements.Table (Last) := (Value => Value.Value, Display_Value => No_Name, @@ -706,16 +706,14 @@ package body Prj.Proc is (The_Package).Name /= The_Name loop The_Package := - In_Tree.Packages.Table - (The_Package).Next; + In_Tree.Packages.Table (The_Package).Next; end loop; pragma Assert - (The_Package /= No_Package, - "package not found."); + (The_Package /= No_Package, "package not found."); elsif Kind_Of (The_Current_Term, From_Project_Node_Tree) = - N_Attribute_Reference + N_Attribute_Reference then The_Package := No_Package; end if; @@ -724,7 +722,7 @@ package body Prj.Proc is Name_Of (The_Current_Term, From_Project_Node_Tree); if Kind_Of (The_Current_Term, From_Project_Node_Tree) = - N_Attribute_Reference + N_Attribute_Reference then Index := Associative_Array_Index_Of @@ -742,7 +740,7 @@ package body Prj.Proc is -- First, if there is a package, look into the package if Kind_Of (The_Current_Term, From_Project_Node_Tree) = - N_Variable_Reference + N_Variable_Reference then The_Variable_Id := In_Tree.Packages.Table @@ -808,8 +806,7 @@ package body Prj.Proc is begin if The_Package /= No_Package then The_Array := - In_Tree.Packages.Table - (The_Package).Decl.Arrays; + In_Tree.Packages.Table (The_Package).Decl.Arrays; else The_Array := The_Project.Decl.Arrays; end if; @@ -818,13 +815,12 @@ package body Prj.Proc is and then In_Tree.Arrays.Table (The_Array).Name /= The_Name loop - The_Array := In_Tree.Arrays.Table - (The_Array).Next; + The_Array := In_Tree.Arrays.Table (The_Array).Next; end loop; if The_Array /= No_Array then - The_Element := In_Tree.Arrays.Table - (The_Array).Value; + The_Element := + In_Tree.Arrays.Table (The_Array).Value; Array_Index := Get_Attribute_Index (From_Project_Node_Tree, @@ -832,9 +828,8 @@ package body Prj.Proc is Index); while The_Element /= No_Array_Element - and then - In_Tree.Array_Elements.Table - (The_Element).Index /= Array_Index + and then In_Tree.Array_Elements.Table + (The_Element).Index /= Array_Index loop The_Element := In_Tree.Array_Elements.Table @@ -845,8 +840,7 @@ package body Prj.Proc is if The_Element /= No_Array_Element then The_Variable := - In_Tree.Array_Elements.Table - (The_Element).Value; + In_Tree.Array_Elements.Table (The_Element).Value; else if Expression_Kind_Of @@ -1037,8 +1031,8 @@ package body Prj.Proc is end if; Ext_List := Expression_Kind_Of - (The_Current_Term, - From_Project_Node_Tree) = List; + (The_Current_Term, + From_Project_Node_Tree) = List; if Ext_List then Value := Prj.Ext.Value_Of (Env.External, Name, No_Name); @@ -1362,7 +1356,7 @@ package body Prj.Proc is From_Project_Node : Project_Node_Id; From_Project_Node_Tree : Project_Node_Tree_Ref; Env : in out Prj.Tree.Environment; - Reset_Tree : Boolean := True) + Reset_Tree : Boolean := True) is begin Process_Project_Tree_Phase_1 @@ -1410,7 +1404,8 @@ package body Prj.Proc is procedure Process_Package_Declaration (Current_Item : Project_Node_Id); - procedure Process_Attribute_Declaration (Current : Project_Node_Id); + procedure Process_Attribute_Declaration + (Current : Project_Node_Id); procedure Process_Case_Construction (Current_Item : Project_Node_Id); procedure Process_Associative_Array @@ -1460,12 +1455,13 @@ package body Prj.Proc is -- Loop through all the valid strings for the -- string type and compare to the string value. - Current_String := First_Literal_String - (String_Type_Of (Declaration, Node_Tree), Node_Tree); + Current_String := + First_Literal_String + (String_Type_Of (Declaration, Node_Tree), Node_Tree); while Present (Current_String) and then String_Value_Of (Current_String, Node_Tree) /= - Value.Value + Value.Value loop Current_String := Next_Literal_String (Current_String, Node_Tree); @@ -1506,22 +1502,25 @@ package body Prj.Proc is --------------------------------- procedure Process_Package_Declaration - (Current_Item : Project_Node_Id) is + (Current_Item : Project_Node_Id) + is begin -- Do not process a package declaration that should be ignored if Expression_Kind_Of (Current_Item, Node_Tree) /= Ignored then + -- Create the new package Package_Table.Increment_Last (In_Tree.Packages); declare New_Pkg : constant Package_Id := - Package_Table.Last (In_Tree.Packages); + Package_Table.Last (In_Tree.Packages); The_New_Package : Package_Element; Project_Of_Renamed_Package : constant Project_Node_Id := - Project_Of_Renamed_Package_Of (Current_Item, Node_Tree); + Project_Of_Renamed_Package_Of + (Current_Item, Node_Tree); begin -- Set the name of the new package @@ -1560,10 +1559,10 @@ package body Prj.Proc is Name_Of (Current_Item, Node_Tree)); begin - -- For a renamed package, copy the declarations of - -- the renamed package, but set all the locations - -- to the location of the package name in the - -- renaming declaration. + -- For a renamed package, copy the declarations of the + -- renamed package, but set all the locations to the + -- location of the package name in the renaming + -- declaration. Copy_Package_Declarations (From => In_Tree.Packages.Table (Renamed_Package).Decl, @@ -1587,9 +1586,8 @@ package body Prj.Proc is Project_Level => False); end if; - -- Process declarative items (nothing to do when the - -- package is renaming, as the first declarative item is - -- null). + -- Process declarative items (nothing to do when the package is + -- renaming, as the first declarative item is null). Process_Declarative_Items (Project => Project, @@ -1612,11 +1610,11 @@ package body Prj.Proc is (Current_Item : Project_Node_Id) is Current_Item_Name : constant Name_Id := - Name_Of (Current_Item, Node_Tree); + Name_Of (Current_Item, Node_Tree); -- The name of the attribute Current_Location : constant Source_Ptr := - Location_Of (Current_Item, Node_Tree); + Location_Of (Current_Item, Node_Tree); New_Array : Array_Id; -- The new associative array created @@ -1633,12 +1631,12 @@ package body Prj.Proc is -- value is. Orig_Package_Name : Name_Id := No_Name; - -- The name of the package, if any, where the associative - -- array value is. + -- The name of the package, if any, where the associative array value + -- is located. Orig_Package : Package_Id := No_Package; - -- The id of the package, if any, where the associative - -- array value is. + -- The id of the package, if any, where the associative array value + -- is located. New_Element : Array_Element_Id := No_Array_Element; -- Id of a new array element created @@ -1650,16 +1648,16 @@ package body Prj.Proc is -- Current array element in original associative array Next_Element : Array_Element_Id := No_Array_Element; - -- Id of the array element that follows the new element. - -- This is not always nil, because values for the - -- associative array attribute may already have been - -- declared, and the array elements declared are reused. + -- Id of the array element that follows the new element. This is not + -- always nil, because values for the associative array attribute may + -- already have been declared, and the array elements declared are + -- reused. Prj : Project_List; begin - -- First find if the associative array attribute already - -- has elements declared. + -- First find if the associative array attribute already has elements + -- declared. if Pkg /= No_Package then New_Array := In_Tree.Packages.Table (Pkg).Decl.Arrays; @@ -1673,8 +1671,8 @@ package body Prj.Proc is New_Array := In_Tree.Arrays.Table (New_Array).Next; end loop; - -- If the attribute has never been declared add new entry - -- in the arrays of the project/package and link it. + -- If the attribute has never been declared add new entry in the + -- arrays of the project/package and link it. if New_Array = No_Array then Array_Table.Increment_Last (In_Tree.Arrays); @@ -1722,8 +1720,7 @@ package body Prj.Proc is Orig_Array := Orig_Project.Decl.Arrays; else - -- If in a package, find the package where the value - -- is declared. + -- If in a package, find the package where the value is declared Orig_Package_Name := Name_Of @@ -1734,7 +1731,7 @@ package body Prj.Proc is "original package not found"); while In_Tree.Packages.Table - (Orig_Package).Name /= Orig_Package_Name + (Orig_Package).Name /= Orig_Package_Name loop Orig_Package := In_Tree.Packages.Table (Orig_Package).Next; pragma Assert (Orig_Package /= No_Package, @@ -1770,8 +1767,8 @@ package body Prj.Proc is if Prev_Element = No_Array_Element then - -- And there is no array element declared yet, - -- create a new first array element. + -- And there is no array element declared yet, create a new + -- first array element. if In_Tree.Arrays.Table (New_Array).Value = No_Array_Element @@ -1834,8 +1831,8 @@ package body Prj.Proc is In_Tree.Array_Elements.Table (Orig_Element).Next; end loop; - -- Make sure that the array ends here, in case there - -- previously a greater number of elements. + -- Make sure that the array ends here, in case there previously a + -- greater number of elements. In_Tree.Array_Elements.Table (New_Element).Next := No_Array_Element; @@ -1850,15 +1847,15 @@ package body Prj.Proc is (Current : Project_Node_Id; New_Value : Variable_Value) is - Name : constant Name_Id := Name_Of (Current, Node_Tree); + Name : constant Name_Id := Name_Of (Current, Node_Tree); Current_Location : constant Source_Ptr := - Location_Of (Current, Node_Tree); + Location_Of (Current, Node_Tree); Index_Name : Name_Id := - Associative_Array_Index_Of (Current, Node_Tree); + Associative_Array_Index_Of (Current, Node_Tree); Source_Index : constant Int := - Source_Index_Of (Current, Node_Tree); + Source_Index_Of (Current, Node_Tree); The_Array : Array_Id; Elem : Array_Element_Id := No_Array_Element; @@ -1882,10 +1879,9 @@ package body Prj.Proc is The_Array := In_Tree.Arrays.Table (The_Array).Next; end loop; - -- If the array cannot be found, create a new entry - -- in the list. As The_Array_Element is initialized - -- to No_Array_Element, a new element will be - -- created automatically later + -- If the array cannot be found, create a new entry in the list. + -- As The_Array_Element is initialized to No_Array_Element, a new + -- element will be created automatically later if The_Array = No_Array then Array_Table.Increment_Last (In_Tree.Arrays); @@ -1914,14 +1910,14 @@ package body Prj.Proc is Elem := In_Tree.Arrays.Table (The_Array).Value; end if; - -- Look in the list, if any, to find an element - -- with the same index and same source index. + -- Look in the list, if any, to find an element with the same index + -- and same source index. while Elem /= No_Array_Element and then (In_Tree.Array_Elements.Table (Elem).Index /= Index_Name - or else - In_Tree.Array_Elements.Table (Elem).Src_Index /= Source_Index) + or else + In_Tree.Array_Elements.Table (Elem).Src_Index /= Source_Index) loop Elem := In_Tree.Array_Elements.Table (Elem).Next; end loop; @@ -1946,8 +1942,8 @@ package body Prj.Proc is In_Tree.Arrays.Table (The_Array).Value := Elem; else - -- An element with the same index already exists, - -- just replace its value with the new one. + -- An element with the same index already exists, just replace its + -- value with the new one. In_Tree.Array_Elements.Table (Elem).Value := New_Value; end if; @@ -1968,9 +1964,11 @@ package body Prj.Proc is New_Value : Variable_Value) is Name : constant Name_Id := Name_Of (Current_Item, Node_Tree); - Var : Variable_Id := No_Variable; + Var : Variable_Id := No_Variable; + Is_Attribute : constant Boolean := - Kind_Of (Current_Item, Node_Tree) = N_Attribute_Declaration; + Kind_Of (Current_Item, Node_Tree) = + N_Attribute_Declaration; begin -- First, find the list where to find the variable or attribute. @@ -1998,13 +1996,12 @@ package body Prj.Proc is Var := In_Tree.Variable_Elements.Table (Var).Next; end loop; - -- If it has not been declared, create a new entry - -- in the list. + -- If it has not been declared, create a new entry in the list if Var = No_Variable then - -- All single string attribute should already have - -- been declared with a default empty string value. + -- All single string attribute should already have been declared + -- with a default empty string value. pragma Assert (not Is_Attribute, @@ -2030,8 +2027,8 @@ package body Prj.Proc is Project.Decl.Variables := Var; end if; - -- If the variable/attribute has already been - -- declared, just change the value. + -- If the variable/attribute has already been declared, just + -- change the value. else In_Tree.Variable_Elements.Table (Var).Value := New_Value; @@ -2042,28 +2039,25 @@ package body Prj.Proc is -- Process_Expression -- ------------------------ - procedure Process_Expression - (Current : Project_Node_Id) - is + procedure Process_Expression (Current : Project_Node_Id) is New_Value : Variable_Value := - Expression - (Project => Project, - In_Tree => In_Tree, - From_Project_Node => From_Project_Node, - From_Project_Node_Tree => Node_Tree, - Env => Env, - Pkg => Pkg, - First_Term => - Tree.First_Term - (Expression_Of (Current, Node_Tree), Node_Tree), - Kind => Expression_Kind_Of (Current, Node_Tree)); + Expression + (Project => Project, + In_Tree => In_Tree, + From_Project_Node => From_Project_Node, + From_Project_Node_Tree => Node_Tree, + Env => Env, + Pkg => Pkg, + First_Term => + Tree.First_Term + (Expression_Of (Current, Node_Tree), Node_Tree), + Kind => + Expression_Kind_Of (Current, Node_Tree)); begin -- Process a typed variable declaration - if Kind_Of (Current, Node_Tree) = - N_Typed_Variable_Declaration - then + if Kind_Of (Current, Node_Tree) = N_Typed_Variable_Declaration then Check_Or_Set_Typed_Variable (New_Value, Current); end if; @@ -2094,7 +2088,7 @@ package body Prj.Proc is ------------------------------- procedure Process_Case_Construction - (Current_Item : Project_Node_Id) + (Current_Item : Project_Node_Id) is The_Project : Project_Id := Project; -- The id of the project of the case variable @@ -2123,8 +2117,7 @@ package body Prj.Proc is Name : Name_Id := No_Name; begin - -- If a project was specified for the case variable, - -- get its id. + -- If a project was specified for the case variable, get its id if Present (Project_Node_Of (Variable_Node, Node_Tree)) then Name := @@ -2134,8 +2127,7 @@ package body Prj.Proc is Imported_Or_Extended_Project_From (Project, Name); end if; - -- If a package were specified for the case variable, - -- get its id. + -- If a package was specified for the case variable, get its id if Present (Package_Node_Of (Variable_Node, Node_Tree)) then Name := @@ -2146,12 +2138,12 @@ package body Prj.Proc is Name := Name_Of (Variable_Node, Node_Tree); - -- First, look for the case variable into the package, - -- if any. + -- First, look for the case variable into the package, if any if The_Package /= No_Package then - Var_Id := In_Tree.Packages.Table (The_Package).Decl.Variables; Name := Name_Of (Variable_Node, Node_Tree); + + Var_Id := In_Tree.Packages.Table (The_Package).Decl.Variables; while Var_Id /= No_Variable and then In_Tree.Variable_Elements.Table (Var_Id).Name /= Name loop @@ -2159,8 +2151,8 @@ package body Prj.Proc is end loop; end if; - -- If not found in the package, or if there is no - -- package, look at the project level. + -- If not found in the package, or if there is no package, look at + -- the project level. if Var_Id = No_Variable and then No (Package_Node_Of (Variable_Node, Node_Tree)) @@ -2175,8 +2167,8 @@ package body Prj.Proc is if Var_Id = No_Variable then - -- Should never happen, because this has already been - -- checked during parsing. + -- Should never happen, because this has already been checked + -- during parsing. Write_Line ("variable """ & Get_Name_String (Name) & """ not found"); @@ -2189,8 +2181,8 @@ package body Prj.Proc is if The_Variable.Kind /= Single then - -- Should never happen, because this has already been - -- checked during parsing. + -- Should never happen, because this has already been checked + -- during parsing. Write_Line ("variable""" & Get_Name_String (Name) & """ is not a single string variable"); @@ -2198,6 +2190,7 @@ package body Prj.Proc is end if; -- Get the case variable value + Case_Value := The_Variable.Value; end; @@ -2209,8 +2202,8 @@ package body Prj.Proc is while Present (Case_Item) loop Choice_String := First_Choice_Of (Case_Item, Node_Tree); - -- When Choice_String is nil, it means that it is - -- the "when others =>" alternative. + -- When Choice_String is nil, it means that it is the + -- "when others =>" alternative. if No (Choice_String) then Decl_Item := First_Declarative_Item_Of (Case_Item, Node_Tree); @@ -2265,8 +2258,9 @@ package body Prj.Proc is when N_Package_Declaration => Process_Package_Declaration (Current); + -- Nothing to process for string type declaration + when N_String_Type_Declaration => - -- There is nothing to process null; when N_Attribute_Declaration | @@ -2369,12 +2363,14 @@ package body Prj.Proc is declare Object_Dir : constant Path_Information := Project.Object_Directory; + begin Prj := In_Tree.Projects; while Prj /= null loop if Prj.Project.Virtual then Prj.Project.Object_Directory := Object_Dir; end if; + Prj := Prj.Next; end loop; end; @@ -2463,14 +2459,13 @@ package body Prj.Proc is -- Imported is the id of the last imported project. procedure Process_Aggregated_Projects; - -- Process all the projects aggregated in List. - -- This does nothing if the project is not an aggregate project. + -- Process all the projects aggregated in List. This does nothing if the + -- project is not an aggregate project. procedure Process_Extended_Project; - -- Process the extended project: - -- inherit all packages from the extended project that are not - -- explicitly defined or renamed. Also inherit the languages, if - -- attribute Languages is not explicitly defined. + -- Process the extended project: inherit all packages from the extended + -- project that are not explicitly defined or renamed. Also inherit the + -- languages, if attribute Languages is not explicitly defined. ------------------------------- -- Process_Imported_Projects -- @@ -2611,8 +2606,7 @@ package body Prj.Proc is end loop; if Current_Pkg = No_Package then - Package_Table.Increment_Last - (In_Tree.Packages); + Package_Table.Increment_Last (In_Tree.Packages); Current_Pkg := Package_Table.Last (In_Tree.Packages); In_Tree.Packages.Table (Current_Pkg) := (Name => Element.Name, @@ -2622,8 +2616,7 @@ package body Prj.Proc is Project.Decl.Packages := Current_Pkg; Copy_Package_Declarations (From => Element.Decl, - To => - In_Tree.Packages.Table (Current_Pkg).Decl, + To => In_Tree.Packages.Table (Current_Pkg).Decl, New_Loc => No_Location, Restricted => True, In_Tree => In_Tree); @@ -2632,28 +2625,24 @@ package body Prj.Proc is Extended_Pkg := Element.Next; end loop; - -- Check if attribute Languages is declared in the - -- extending project. + -- Check if attribute Languages is declared in the extending project Attribute1 := Project.Decl.Attributes; while Attribute1 /= No_Variable loop - Attr_Value1 := In_Tree.Variable_Elements. - Table (Attribute1); + Attr_Value1 := In_Tree.Variable_Elements. Table (Attribute1); exit when Attr_Value1.Name = Snames.Name_Languages; Attribute1 := Attr_Value1.Next; end loop; - if Attribute1 = No_Variable or else - Attr_Value1.Value.Default + if Attribute1 = No_Variable + or else Attr_Value1.Value.Default then - -- Attribute Languages is not declared in the extending - -- project. Check if it is declared in the project being - -- extended. + -- Attribute Languages is not declared in the extending project. + -- Check if it is declared in the project being extended. Attribute2 := Project.Extends.Decl.Attributes; while Attribute2 /= No_Variable loop - Attr_Value2 := In_Tree.Variable_Elements. - Table (Attribute2); + Attr_Value2 := In_Tree.Variable_Elements.Table (Attribute2); exit when Attr_Value2.Name = Snames.Name_Languages; Attribute2 := Attr_Value2.Next; end loop; @@ -2661,9 +2650,8 @@ package body Prj.Proc is if Attribute2 /= No_Variable and then not Attr_Value2.Value.Default then - -- As attribute Languages is declared in the project - -- being extended, copy its value for the extending - -- project. + -- As attribute Languages is declared in the project being + -- extended, copy its value for the extending project. if Attribute1 = No_Variable then Variable_Element_Table.Increment_Last diff --git a/gcc/ada/prj-tree.adb b/gcc/ada/prj-tree.adb index 2d1b55633b3..3dda4714dd8 100644 --- a/gcc/ada/prj-tree.adb +++ b/gcc/ada/prj-tree.adb @@ -993,7 +993,9 @@ package body Prj.Tree is -------------------- procedure Override_Flags - (Self : in out Environment; Flags : Prj.Processing_Flags) is + (Self : in out Environment; + Flags : Prj.Processing_Flags) + is begin Self.Flags := Flags; end Override_Flags; @@ -1006,11 +1008,13 @@ package body Prj.Tree is (Self : in out Environment; Flags : Processing_Flags) is begin -- Do not reset the external references, in case we are reloading a - -- project, since we want to preserve the current environment. - -- But we still need to ensure that the external references are properly + -- project, since we want to preserve the current environment. But we + -- still need to ensure that the external references are properly -- initialized. Prj.Ext.Initialize (Self.External); + + -- Why is this line commented out ??? -- Prj.Ext.Reset (Tree.External); Self.Flags := Flags; diff --git a/gcc/ada/prj-tree.ads b/gcc/ada/prj-tree.ads index f391e9d64fe..69372ae5d6b 100644 --- a/gcc/ada/prj-tree.ads +++ b/gcc/ada/prj-tree.ads @@ -40,8 +40,11 @@ package Prj.Tree is -- Environment -- ----------------- + -- The following record contains the context in which projects are parsed + -- and processed (finding importing project, resolving external values,..). + type Environment is record - External : Prj.Ext.External_References; + External : Prj.Ext.External_References; -- External references are stored in this hash table (and manipulated -- through subprograms in prj-ext.ads). External references are -- project-tree specific so that one can load the same tree twice but @@ -53,11 +56,9 @@ package Prj.Tree is -- particular when using different compilers with different default -- search directories. - Flags : Prj.Processing_Flags; + Flags : Prj.Processing_Flags; -- Configure errors and warnings end record; - -- This record contains the context in which projects are parsed and - -- processed (finding importing project, resolving external values,...) procedure Initialize (Self : in out Environment; Flags : Processing_Flags); -- Initialize a new environment diff --git a/gcc/ada/prj.adb b/gcc/ada/prj.adb index cbc2c9657ec..cc5733555a6 100644 --- a/gcc/ada/prj.adb +++ b/gcc/ada/prj.adb @@ -49,7 +49,7 @@ package body Prj is The_Empty_String : Name_Id := No_Name; Debug_Level : Integer := 0; - -- Current indentation level for debug traces. + -- Current indentation level for debug traces type Cst_String_Access is access constant String; @@ -222,12 +222,14 @@ package body Prj is ------------------- function Empty_Project - (Qualifier : Project_Qualifier) return Project_Data is + (Qualifier : Project_Qualifier) return Project_Data + is begin Prj.Initialize (Tree => No_Project_Tree); declare Data : Project_Data (Qualifier => Qualifier); + begin -- Only the fields for which no default value could be provided in -- prj.ads are initialized below @@ -253,7 +255,9 @@ package body Prj is procedure Expect (The_Token : Token_Type; Token_Image : String) is begin if Token /= The_Token then + -- ??? Should pass user flags here instead + Error_Msg (Gnatmake_Flags, Token_Image & " expected", Token_Ptr); end if; end Expect; @@ -399,10 +403,10 @@ package body Prj is -------------------------------- procedure For_Every_Project_Imported - (By : Project_Id; - With_State : in out State; + (By : Project_Id; + With_State : in out State; Include_Aggregated : Boolean := True; - Imported_First : Boolean := False) + Imported_First : Boolean := False) is use Project_Boolean_Htable; Seen : Project_Boolean_Htable.Instance := Project_Boolean_Htable.Nil; diff --git a/gcc/ada/prj.ads b/gcc/ada/prj.ads index ebcc815c76e..1e60bdc6f8b 100644 --- a/gcc/ada/prj.ads +++ b/gcc/ada/prj.ads @@ -1102,7 +1102,8 @@ package Prj is -- Free the memory used for List procedure Add_Aggregated_Project - (Project : Project_Id; Path : Path_Name_Type); + (Project : Project_Id; + Path : Path_Name_Type); -- Add a new aggregated project in Project. -- The aggregated project has not been processed yet. This procedure should -- the called while processing the aggregate project, and as a result @@ -1111,6 +1112,7 @@ package Prj is ------------------ -- Project_Data -- ------------------ + -- The following record describes a project file representation type Project_Data (Qualifier : Project_Qualifier := Unspecified) is record @@ -1314,9 +1316,10 @@ package Prj is -- in the project tree. ----------------------------- - -- qualifier-specific data -- + -- Qualifier-Specific data -- ----------------------------- - -- The following fields are only valid for specific types of projects. + + -- The following fields are only valid for specific types of projects case Qualifier is when Aggregate => @@ -1462,10 +1465,10 @@ package Prj is (Project : Project_Id; With_State : in out State); procedure For_Every_Project_Imported - (By : Project_Id; - With_State : in out State; + (By : Project_Id; + With_State : in out State; Include_Aggregated : Boolean := True; - Imported_First : Boolean := False); + Imported_First : Boolean := False); -- Call Action for each project imported directly or indirectly by project -- By, as well as extended projects. -- diff --git a/gcc/ada/put_alfa.adb b/gcc/ada/put_alfa.adb index 1e1a661ac97..58021145d1b 100644 --- a/gcc/ada/put_alfa.adb +++ b/gcc/ada/put_alfa.adb @@ -32,7 +32,6 @@ begin for J in 1 .. ALFA_File_Table.Last loop declare F : ALFA_File_Record renames ALFA_File_Table.Table (J); - Start : Scope_Index; Stop : Scope_Index; @@ -92,10 +91,8 @@ begin for J in 1 .. ALFA_File_Table.Last loop declare F : ALFA_File_Record renames ALFA_File_Table.Table (J); - Start : Scope_Index; Stop : Scope_Index; - File : Nat; Scope : Nat; Entity_Line : Nat; diff --git a/gcc/ada/repinfo.adb b/gcc/ada/repinfo.adb index 3f3f488e1c7..c3e6772ed50 100644 --- a/gcc/ada/repinfo.adb +++ b/gcc/ada/repinfo.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1999-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1999-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- -- @@ -665,19 +665,36 @@ package body Repinfo is Write_Str (" convention : "); case Convention (Ent) is - when Convention_Ada => Write_Line ("Ada"); - when Convention_Intrinsic => Write_Line ("InLineinsic"); - when Convention_Entry => Write_Line ("Entry"); - when Convention_Protected => Write_Line ("Protected"); - when Convention_Assembler => Write_Line ("Assembler"); - when Convention_C => Write_Line ("C"); - when Convention_CIL => Write_Line ("CIL"); - when Convention_COBOL => Write_Line ("COBOL"); - when Convention_CPP => Write_Line ("C++"); - when Convention_Fortran => Write_Line ("Fortran"); - when Convention_Java => Write_Line ("Java"); - when Convention_Stdcall => Write_Line ("Stdcall"); - when Convention_Stubbed => Write_Line ("Stubbed"); + when Convention_Ada => + Write_Line ("Ada"); + when Convention_Ada_Pass_By_Copy => + Write_Line ("Ada_Pass_By_Copy"); + when Convention_Ada_Pass_By_Reference => + Write_Line ("Ada_Pass_By_Reference"); + when Convention_Intrinsic => + Write_Line ("Intrinsic"); + when Convention_Entry => + Write_Line ("Entry"); + when Convention_Protected => + Write_Line ("Protected"); + when Convention_Assembler => + Write_Line ("Assembler"); + when Convention_C => + Write_Line ("C"); + when Convention_CIL => + Write_Line ("CIL"); + when Convention_COBOL => + Write_Line ("COBOL"); + when Convention_CPP => + Write_Line ("C++"); + when Convention_Fortran => + Write_Line ("Fortran"); + when Convention_Java => + Write_Line ("Java"); + when Convention_Stdcall => + Write_Line ("Stdcall"); + when Convention_Stubbed => + Write_Line ("Stubbed"); end case; -- Find max length of formal name diff --git a/gcc/ada/restrict.ads b/gcc/ada/restrict.ads index 31cecd7305d..0c1c5b6cbfa 100644 --- a/gcc/ada/restrict.ads +++ b/gcc/ada/restrict.ads @@ -239,21 +239,21 @@ package Restrict is -- known, V is left at its default of -1 which indicates an unknown count. procedure Check_Restriction - (R : Restriction_Id; - N : Node_Id; - V : Uint := Uint_Minus_1); + (R : Restriction_Id; + N : Node_Id; + V : Uint := Uint_Minus_1); -- Wrapper on Check_Restriction with Msg_Issued, with the out-parameter -- being ignored here. procedure Check_Restriction_No_Dependence (U : Node_Id; Err : Node_Id); -- Called when a dependence on a unit is created (either implicitly, or by - -- an explicit WITH clause). U is a node for the unit involved, and Err - -- is the node to which an error will be attached if necessary. + -- an explicit WITH clause). U is a node for the unit involved, and Err is + -- the node to which an error will be attached if necessary. procedure Check_Elaboration_Code_Allowed (N : Node_Id); -- Tests to see if elaboration code is allowed by the current restrictions - -- settings. This function is called by Gigi when it needs to define - -- an elaboration routine. If elaboration code is not allowed, an error + -- settings. This function is called by Gigi when it needs to define an + -- elaboration routine. If elaboration code is not allowed, an error -- message is posted on the node given as argument. procedure Check_SPARK_Restriction diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index e433376db9e..71fe0fbbbb3 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -1127,21 +1127,22 @@ package body Sem_Aggr is Set_Etype (N, Aggr_Typ); -- May be overridden later on - if Pkind = N_Assignment_Statement or else - (Is_Constrained (Typ) and then - (Pkind = N_Parameter_Association or else - Pkind = N_Function_Call or else - Pkind = N_Procedure_Call_Statement or else - Pkind = N_Generic_Association or else - Pkind = N_Formal_Object_Declaration or else - Pkind = N_Simple_Return_Statement or else - Pkind = N_Object_Declaration or else - Pkind = N_Component_Declaration or else - Pkind = N_Parameter_Specification or else - Pkind = N_Qualified_Expression or else - Pkind = N_Aggregate or else - Pkind = N_Extension_Aggregate or else - Pkind = N_Component_Association)) + if Pkind = N_Assignment_Statement + or else (Is_Constrained (Typ) + and then + (Pkind = N_Parameter_Association or else + Pkind = N_Function_Call or else + Pkind = N_Procedure_Call_Statement or else + Pkind = N_Generic_Association or else + Pkind = N_Formal_Object_Declaration or else + Pkind = N_Simple_Return_Statement or else + Pkind = N_Object_Declaration or else + Pkind = N_Component_Declaration or else + Pkind = N_Parameter_Specification or else + Pkind = N_Qualified_Expression or else + Pkind = N_Aggregate or else + Pkind = N_Extension_Aggregate or else + Pkind = N_Component_Association)) then Aggr_Resolved := Resolve_Array_Aggregate @@ -1185,6 +1186,7 @@ package body Sem_Aggr is end if; Aggr_Subtyp := Any_Composite; + else Aggr_Subtyp := Array_Aggr_Subtype (N, Typ); end if; diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 849ec86c824..7ece5832a7c 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -1289,16 +1289,6 @@ package body Sem_Attr is Check_E2; end Check_Floating_Point_Type_2; - ------------------------------------------ - -- Check_SPARK_Restriction_On_Attribute -- - ------------------------------------------ - - procedure Check_SPARK_Restriction_On_Attribute is - begin - Error_Msg_Name_1 := Aname; - Check_SPARK_Restriction ("attribute % is not allowed", P); - end Check_SPARK_Restriction_On_Attribute; - ------------------------ -- Check_Integer_Type -- ------------------------ @@ -1540,6 +1530,16 @@ package body Sem_Attr is end if; end Check_Scalar_Type; + ------------------------------------------ + -- Check_SPARK_Restriction_On_Attribute -- + ------------------------------------------ + + procedure Check_SPARK_Restriction_On_Attribute is + begin + Error_Msg_Name_1 := Aname; + Check_SPARK_Restriction ("attribute % is not allowed", P); + end Check_SPARK_Restriction_On_Attribute; + --------------------------- -- Check_Standard_Prefix -- --------------------------- diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 8e240de9c55..ac065414375 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -7300,7 +7300,8 @@ package body Sem_Ch13 is else return Has_Aliased_Components (Base_Type (T1)) - = Has_Aliased_Components (Base_Type (T2)); + = + Has_Aliased_Components (Base_Type (T2)); end if; end if; end if; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 297f51e0606..c37a086b517 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -8636,7 +8636,7 @@ package body Sem_Ch3 is IR : constant Node_Id := Make_Itype_Reference (Sloc (Nod)); begin - -- Itype references are only created for use by the back-end. + -- Itype references are only created for use by the back-end if Inside_A_Generic then return; diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 11c807b5c3b..ca7831e7ef6 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -629,8 +629,8 @@ package body Sem_Ch6 is if Nkind (N) = N_Simple_Return_Statement then Expr := Expression (N); - -- Guard against a malformed expression. The parser may have - -- tried to recover but the node is not analyzable. + -- Guard against a malformed expression. The parser may have tried to + -- recover but the node is not analyzable. if Nkind (Expr) = N_Error then Set_Etype (Expr, Any_Type); @@ -8614,8 +8614,8 @@ package body Sem_Ch6 is -- If S is a derived operation for an untagged type then by -- definition it's not a dispatching operation (even if the parent - -- operation was dispatching), so we don't call - -- Check_Dispatching_Operation in that case. + -- operation was dispatching), so Check_Dispatching_Operation is not + -- called in that case. if No (Derived_Type) or else Is_Tagged_Type (Derived_Type) diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index fddb704c96f..e0e1e06ef1c 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -708,17 +708,15 @@ package body Sem_Ch8 is Subt : Entity_Id; begin - if (Nkind (Nam) = N_Function_Call - or else Nkind (Nam) = N_Explicit_Dereference) + if Nkind_In (Nam, N_Function_Call, N_Explicit_Dereference) and then Is_Composite_Type (Etype (Nam)) and then not Is_Constrained (Etype (Nam)) and then not Has_Unknown_Discriminants (Etype (Nam)) and then Expander_Active then - -- If Actual_Sbutype is already set, nothing to do. + -- If Actual_Subtype is already set, nothing to do - if (Ekind (Id) = E_Variable - or else Ekind (Id) = E_Constant) + if Ekind_In (Id, E_Variable, E_Constant) and then Present (Actual_Subtype (Id)) then null; diff --git a/gcc/ada/sem_mech.adb b/gcc/ada/sem_mech.adb index 1954b3deb74..d21e6ae6fa5 100644 --- a/gcc/ada/sem_mech.adb +++ b/gcc/ada/sem_mech.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1996-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1996-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- -- @@ -324,6 +324,14 @@ package body Sem_Mech is null; end if; + -- Special Ada conventions specifying passing mechanism + + when Convention_Ada_Pass_By_Copy => + Set_Mechanism (Formal, By_Copy); + + when Convention_Ada_Pass_By_Reference => + Set_Mechanism (Formal, By_Reference); + ------- -- C -- ------- diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index ebc51619772..840592f289b 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -3014,6 +3014,38 @@ package body Sem_Prag is Ent := E; + -- Ada_Pass_By_Copy special checking + + if C = Convention_Ada_Pass_By_Copy then + if not Is_First_Subtype (E) then + Error_Pragma_Arg + ("convention `Ada_Pass_By_Copy` only " + & "allowed for types", Arg2); + end if; + + if Is_By_Reference_Type (E) then + Error_Pragma_Arg + ("convention `Ada_Pass_By_Copy` not allowed for " + & "by-reference type", Arg1); + end if; + end if; + + -- Ada_Pass_By_Reference special checking + + if C = Convention_Ada_Pass_By_Reference then + if not Is_First_Subtype (E) then + Error_Pragma_Arg + ("convention `Ada_Pass_By_Reference` only " + & "allowed for types", Arg2); + end if; + + if Is_By_Copy_Type (E) then + Error_Pragma_Arg + ("convention `Ada_Pass_By_Reference` not allowed for " + & "by-copy type", Arg1); + end if; + end if; + -- Go to renamed subprogram if present, since convention applies to -- the actual renamed entity, not to the renaming entity. If the -- subprogram is inherited, go to parent subprogram. diff --git a/gcc/ada/snames.adb-tmpl b/gcc/ada/snames.adb-tmpl index 164b11d3548..defe9495ee9 100644 --- a/gcc/ada/snames.adb-tmpl +++ b/gcc/ada/snames.adb-tmpl @@ -137,22 +137,25 @@ package body Snames is function Get_Convention_Id (N : Name_Id) return Convention_Id is begin case N is - when Name_Ada => return Convention_Ada; - when Name_Assembler => return Convention_Assembler; - when Name_C => return Convention_C; - when Name_CIL => return Convention_CIL; - when Name_COBOL => return Convention_COBOL; - when Name_CPP => return Convention_CPP; - when Name_Fortran => return Convention_Fortran; - when Name_Intrinsic => return Convention_Intrinsic; - when Name_Java => return Convention_Java; - when Name_Stdcall => return Convention_Stdcall; - when Name_Stubbed => return Convention_Stubbed; + when Name_Ada => return Convention_Ada; + when Name_Ada_Pass_By_Copy => return Convention_Ada_Pass_By_Copy; + when Name_Ada_Pass_By_Reference => + return Convention_Ada_Pass_By_Reference; + when Name_Assembler => return Convention_Assembler; + when Name_C => return Convention_C; + when Name_CIL => return Convention_CIL; + when Name_COBOL => return Convention_COBOL; + when Name_CPP => return Convention_CPP; + when Name_Fortran => return Convention_Fortran; + when Name_Intrinsic => return Convention_Intrinsic; + when Name_Java => return Convention_Java; + when Name_Stdcall => return Convention_Stdcall; + when Name_Stubbed => return Convention_Stubbed; -- If no direct match, then we must have a convention -- identifier pragma that has specified this name. - when others => + when others => for J in 1 .. Convention_Identifiers.Last loop if N = Convention_Identifiers.Table (J).Name then return Convention_Identifiers.Table (J).Convention; @@ -170,19 +173,22 @@ package body Snames is function Get_Convention_Name (C : Convention_Id) return Name_Id is begin case C is - when Convention_Ada => return Name_Ada; - when Convention_Assembler => return Name_Assembler; - when Convention_C => return Name_C; - when Convention_CIL => return Name_CIL; - when Convention_COBOL => return Name_COBOL; - when Convention_CPP => return Name_CPP; - when Convention_Entry => return Name_Entry; - when Convention_Fortran => return Name_Fortran; - when Convention_Intrinsic => return Name_Intrinsic; - when Convention_Java => return Name_Java; - when Convention_Protected => return Name_Protected; - when Convention_Stdcall => return Name_Stdcall; - when Convention_Stubbed => return Name_Stubbed; + when Convention_Ada => return Name_Ada; + when Convention_Ada_Pass_By_Copy => return Name_Ada_Pass_By_Copy; + when Convention_Ada_Pass_By_Reference => + return Name_Ada_Pass_By_Reference; + when Convention_Assembler => return Name_Assembler; + when Convention_C => return Name_C; + when Convention_CIL => return Name_CIL; + when Convention_COBOL => return Name_COBOL; + when Convention_CPP => return Name_CPP; + when Convention_Entry => return Name_Entry; + when Convention_Fortran => return Name_Fortran; + when Convention_Intrinsic => return Name_Intrinsic; + when Convention_Java => return Name_Java; + when Convention_Protected => return Name_Protected; + when Convention_Stdcall => return Name_Stdcall; + when Convention_Stubbed => return Name_Stubbed; end case; end Get_Convention_Name; diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index 5360f4eaa1f..981784bb37f 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -579,6 +579,8 @@ package Snames is First_Convention_Name : constant Name_Id := N + $; Name_Ada : constant Name_Id := N + $; + Name_Ada_Pass_By_Copy : constant Name_Id := N + $; + Name_Ada_Pass_By_Reference : constant Name_Id := N + $; Name_Assembler : constant Name_Id := N + $; Name_CIL : constant Name_Id := N + $; Name_COBOL : constant Name_Id := N + $; @@ -1424,6 +1426,12 @@ package Snames is Convention_Protected, Convention_Stubbed, + -- The following conventions are equivalent to Ada for all purposes + -- except controlling the way parameters are passed. + + Convention_Ada_Pass_By_Copy, + Convention_Ada_Pass_By_Reference, + -- The remaining conventions are foreign language conventions Convention_Assembler, -- also Asm, Assembly @@ -1435,10 +1443,10 @@ package Snames is Convention_Java, Convention_Stdcall); -- also DLL, Win32 - -- Note: Convention C_Pass_By_Copy is allowed only for record - -- types (where it is treated like C except that the appropriate - -- flag is set in the record type). Recognizing this convention - -- is specially handled in Sem_Prag. + -- Note: Convention C_Pass_By_Copy is allowed only for record types + -- (where it is treated like C except that the appropriate flag is set + -- in the record type). Recognizing this convention is specially handled + -- in Sem_Prag. for Convention_Id'Size use 8; -- Plenty of space for expansion -- 2.30.2