diff options
Diffstat (limited to 'gcc/ada')
51 files changed, 1783 insertions, 399 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 1229cfa..26c8ef5 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,137 @@ +2004-03-29 Javier Miranda <miranda@gnat.com> + + * checks.adb (Null_Exclusion_Static_Checks): New subprogram + (Install_Null_Excluding_Check): Local subprogram that determines whether + an access node requires a runtime access check and if so inserts the + appropriate run-time check. + (Apply_Access_Check): Call Install_Null_Excluding check if required + (Apply_Constraint_Check): Call Install_Null_Excluding check if required + + * checks.ads: (Null_Exclusion_Static_Checks): New subprogram + + * einfo.ads: Fix typo in comment + + * exp_ch3.adb (Build_Assignment): Generate conversion to the + null-excluding type to force the corresponding run-time check. + (Expand_N_Object_Declaration): Generate conversion to the null-excluding + type to force the corresponding run-time check. + + * exp_ch5.adb (Expand_N_Assignment_Statement): Generate conversion to + the null-excluding type to force the corresponding run-time check. + + * exp_ch6.adb (Expand_Call): Do not generate the run-time check in + case of access types unless they have the null-excluding attribute. + + * sprint.adb (Sprint_Node_Actual): Give support to the null-exclusing + part. + + * exp_util.ads: Fix typo in comment + + * par.adb (P_Null_Exclusion): New subprogram + (P_Subtype_Indication): New formal that indicates if the null-excluding + part has been scanned-out and it was present + + * par-ch3.adb, par-ch4.adb, par-ch6.adb: Give support to AI-231 + + * sem_aggr.adb: (Check_Can_Never_Be_Null): New subprogram + (Aggregate_Constraint_Checks): Generate conversion to the null-excluding + type to force the corresponding run-time check + (Resolve_Aggregate): Propagate the null-excluding attribute to the array + components + (Resolve_Array_Aggregate): Carry out some static checks + (Resolve_Record_Aggregate.Get_Value): Carry out some static check + + * sem_ch3.adb (Access_Definition): In Ada 0Y the Can_Never_Be_Null + attribute must be set only if specified by means of the null-excluding + part. In addition, we must also propagate the access-constant attribute + if present. + (Access_Subprogram_Declaration, Access_Type_Declaration, + Analyze_Component_Declaration, Analyze_Object_Declaration, + Array_Type_Declaration, Process_Discriminants, + Analyze_Subtype_Declaration): Propagate the null-excluding attribute + and carry out some static checks. + (Build_Derived_Access_Type): Set the null-excluding attribute + (Derived_Type_Declaration, Process_Subtype): Carry out some static + checks. + + * sem_ch4.adb (Analyze_Allocator): Carry out some static checks + + * sem_ch5.adb (Analyze_Assignment): Carry out some static checks + + * sem_ch6.adb (Process_Formals): Carry out some static checks. + (Set_Actual_Subtypes): Generate null-excluding subtype if the + null-excluding part was present; it is not required to be done here in + case of anonymous access types. + (Set_Formal_Mode): Ada 0Y allows anonymous access to have the null + value. + + * sem_res.adb (Resolve_Actuals): Carry out some static check + (Resolve_Null): Allow null in anonymous access + + * sinfo.adb: New subprogram Null_Exclusion_Present + All_Present and Constant_Present available on access_definition nodes + + * sinfo.ads: New flag Null_Exclusion_Present on subtype_declaration, + object_declaration, derived_type_definition, component_definition, + discriminant_specification, access_to_object_definition, + access_function_definition, allocator, access_procedure_definition, + access_definition, parameter_specification, All_Present and + Constant_Present flags available on access_definition nodes. + +2004-03-29 Robert Dewar <dewar@gnat.com> + + * fname.adb, fname.ads, fname-sf.adb, fname-uf.adb, fname-uf.ads, + gnat1drv.adb, lib.adb, lib.ads, lib-load.adb, lib-writ.adb, + opt.ads, osint.adb, osint.ads, osint-c.adb, par.adb, + par-ch10.adb, par-load.adb, par-prag.adb, sfn_scan.adb, + sfn_scan.ads, sinput-l.adb, sinput-l.ads, switch-c.adb, + sem_prag.adb: Updates to handle multiple units/file + + * par.adb: Change test for s-rpc to s-rp for detecting rpc and children + + * par.adb, memtrack.adb, prj-makr.adb, prj-part.adb, + sem_util.adb: Minor reformatting + + * sem_ch12.adb: Add comment for previous change + +2004-03-29 Laurent Pautet <pautet@act-europe.fr> + + * osint.adb (Executable_Prefix): Set Exec_Name to the current + executable name when not initialized. Otherwise, use its current value. + + * osint.ads (Exec_Name): Move Exec_Name from body to spec in order to + initialize it to another executable name than the current one. This + allows to configure paths for an executable name (gnatmake) different + from the current one (gnatdist). + +2004-03-29 Ed Schonberg <schonberg@gnat.com> + + * exp_ch6.adb (Expand_Call): A call to a function declared in the + current unit cannot be inlined if it appears in the body of a withed + unit, to avoid order of elaboration problems in gigi. + + * exp_ch9.adb (Build_Protected_Sub_Specification): Generate debugging + information for protected (wrapper) operation as well, to simplify gdb + use. + + * sem_ch6.adb (Analyze_Subprogram_Body): For a private operation in a + protected body, indicate that the entity for the generated spec comes + from source, to ensure that references are properly generated for it. + (Build_Body_To_Inline): Do not inline a function that returns a + controlled type. + + * sem_prag.adb (Process_Convention): If subprogram is overloaded, only + apply convention to homonyms that are declared explicitly. + + * sem_res.adb (Make_Call_Into_Operator): If the operation is a function + that renames an equality operator and the operands are overloaded, + resolve them with the declared formal types, before rewriting as an + operator. + +2004-03-29 GNAT Script <nobody@gnat.com> + + * Make-lang.in: Makefile automatically updated + 2004-03-25 Vasiliy Fofanov <fofanov@act-europe.fr> * memtrack.adb: Log realloc calls, which are treated as free followed diff --git a/gcc/ada/Make-lang.in b/gcc/ada/Make-lang.in index 886cf79..419fd0b 100644 --- a/gcc/ada/Make-lang.in +++ b/gcc/ada/Make-lang.in @@ -2211,8 +2211,8 @@ ada/fname-uf.o : ada/ada.ads ada/a-except.ads ada/a-uncdea.ads \ ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-htable.adb \ ada/s-memory.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/tree_io.ads ada/types.ads ada/unchconv.ads \ - ada/unchdeal.ads ada/widechar.ads + ada/table.adb ada/tree_io.ads ada/types.ads ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/widechar.ads ada/fname.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/debug.ads \ ada/fname.ads ada/fname.adb ada/gnat.ads ada/g-os_lib.ads \ @@ -2590,25 +2590,25 @@ ada/osint-b.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/debug.ads \ ada/osint-c.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/debug.ads \ ada/gnat.ads ada/g-os_lib.ads ada/g-string.ads ada/gnatvsn.ads \ - ada/hostparm.ads ada/namet.ads ada/opt.ads ada/osint.ads \ + ada/hostparm.ads ada/namet.ads ada/namet.adb ada/opt.ads ada/osint.ads \ ada/osint-c.ads ada/osint-c.adb ada/output.ads ada/system.ads \ ada/s-exctab.ads ada/s-memory.ads ada/s-secsta.ads ada/s-soflin.ads \ ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ ada/table.adb ada/tree_io.ads ada/types.ads ada/unchconv.ads \ - ada/unchdeal.ads + ada/unchdeal.ads ada/widechar.ads ada/osint.o : ada/ada.ads ada/a-except.ads ada/a-uncdea.ads ada/alloc.ads \ ada/debug.ads ada/fmap.ads ada/gnat.ads ada/g-htable.ads \ ada/g-os_lib.ads ada/g-string.ads ada/gnatvsn.ads ada/hostparm.ads \ - ada/namet.ads ada/opt.ads ada/osint.ads ada/osint.adb ada/output.ads \ - ada/sdefault.ads ada/system.ads ada/s-casuti.ads ada/s-exctab.ads \ - ada/s-htable.ads ada/s-htable.adb ada/s-memory.ads ada/s-secsta.ads \ - ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads \ - ada/s-sopco5.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads \ - ada/unchconv.ads ada/unchdeal.ads + ada/namet.ads ada/namet.adb ada/opt.ads ada/osint.ads ada/osint.adb \ + ada/output.ads ada/sdefault.ads ada/system.ads ada/s-casuti.ads \ + ada/s-exctab.ads ada/s-htable.ads ada/s-htable.adb ada/s-memory.ads \ + ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads \ + ada/s-sopco4.ads ada/s-sopco5.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \ + ada/types.ads ada/unchconv.ads ada/unchdeal.ads ada/widechar.ads ada/output.o : ada/gnat.ads ada/g-os_lib.ads ada/g-string.ads \ ada/output.ads ada/output.adb ada/system.ads ada/s-exctab.ads \ diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 327ddb6..b16fcc1 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -244,6 +244,10 @@ package body Checks is -- that the access value is non-null, since the checks do not -- not apply to null access values. + procedure Install_Null_Excluding_Check (N : Node_Id); + -- Determines whether an access node requires a runtime access check and + -- if so inserts the appropriate run-time check + procedure Install_Static_Check (R_Cno : Node_Id; Loc : Source_Ptr); -- Called by Apply_{Length,Range}_Checks to rewrite the tree with the -- Constraint_Error node. @@ -392,19 +396,7 @@ package body Checks is -- Access check is required - declare - Loc : constant Source_Ptr := Sloc (N); - - begin - Insert_Action (N, - Make_Raise_Constraint_Error (Sloc (N), - Condition => - Make_Op_Eq (Loc, - Left_Opnd => Duplicate_Subexpr_Move_Checks (P), - Right_Opnd => - Make_Null (Loc)), - Reason => CE_Access_Check_Failed)); - end; + Install_Null_Excluding_Check (P); end Apply_Access_Check; ------------------------------- @@ -506,7 +498,7 @@ package body Checks is Reason => PE_Misaligned_Address_Value)); Error_Msg_NE ("?specified address for& not " & - "consistent with alignment", Expr, E); + "consistent with alignment ('R'M 13.3(27))", Expr, E); end if; -- Here we do not know if the value is acceptable, generate @@ -997,6 +989,12 @@ package body Checks is then Apply_Discriminant_Check (N, Typ); end if; + + if Can_Never_Be_Null (Typ) + and then not Can_Never_Be_Null (Etype (N)) + then + Install_Null_Excluding_Check (N); + end if; end if; end Apply_Constraint_Check; @@ -2194,6 +2192,170 @@ package body Checks is end Check_Valid_Lvalue_Subscripts; ---------------------------------- + -- Null_Exclusion_Static_Checks -- + ---------------------------------- + + procedure Null_Exclusion_Static_Checks (N : Node_Id) is + K : constant Node_Kind := Nkind (N); + Expr : Node_Id; + Typ : Entity_Id; + Related_Nod : Node_Id; + Has_Null_Exclusion : Boolean := False; + + -- Following declarations and subprograms are just used to qualify the + -- error messages + + type Msg_Kind is (Components, Formals, Objects); + Msg_K : Msg_Kind := Objects; + + procedure Must_Be_Initialized; + procedure Null_Not_Allowed; + + ------------------------- + -- Must_Be_Initialized -- + ------------------------- + + procedure Must_Be_Initialized is + begin + case Msg_K is + when Components => + Error_Msg_N + ("(Ada 0Y) null-excluding components must be initialized", + Related_Nod); + + when Formals => + Error_Msg_N + ("(Ada 0Y) null-excluding formals must be initialized", + Related_Nod); + + when Objects => + Error_Msg_N + ("(Ada 0Y) null-excluding objects must be initialized", + Related_Nod); + end case; + end Must_Be_Initialized; + + ---------------------- + -- Null_Not_Allowed -- + ---------------------- + + procedure Null_Not_Allowed is + begin + case Msg_K is + when Components => + Error_Msg_N + ("(Ada 0Y) NULL not allowed in null-excluding components", + Expr); + + when Formals => + Error_Msg_N + ("(Ada 0Y) NULL not allowed in null-excluding formals", + Expr); + + when Objects => + Error_Msg_N + ("(Ada 0Y) NULL not allowed in null-excluding objects", + Expr); + end case; + end Null_Not_Allowed; + + -- Start of processing for Null_Exclusion_Static_Checks + + begin + pragma Assert (K = N_Component_Declaration + or else K = N_Parameter_Specification + or else K = N_Object_Declaration + or else K = N_Discriminant_Specification + or else K = N_Allocator); + + Expr := Expression (N); + + case K is + when N_Component_Declaration => + Msg_K := Components; + Has_Null_Exclusion := Null_Exclusion_Present + (Component_Definition (N)); + Typ := Etype (Subtype_Indication + (Component_Definition (N))); + Related_Nod := Subtype_Indication + (Component_Definition (N)); + + when N_Parameter_Specification => + Msg_K := Formals; + Has_Null_Exclusion := Null_Exclusion_Present (N); + Typ := Entity (Parameter_Type (N)); + Related_Nod := Parameter_Type (N); + + when N_Object_Declaration => + Msg_K := Objects; + Has_Null_Exclusion := Null_Exclusion_Present (N); + Typ := Entity (Object_Definition (N)); + Related_Nod := Object_Definition (N); + + when N_Discriminant_Specification => + Msg_K := Components; + + if Nkind (Discriminant_Type (N)) = N_Access_Definition then + + -- This case is special. We do not want to carry out some of + -- the null-excluding checks. Reason: the analysis of the + -- access_definition propagates the null-excluding attribute + -- to the can_never_be_null entity attribute (and thus it is + -- wrong to check it now) + + Has_Null_Exclusion := False; + else + Has_Null_Exclusion := Null_Exclusion_Present (N); + end if; + + Typ := Etype (Defining_Identifier (N)); + Related_Nod := Discriminant_Type (N); + + when N_Allocator => + Msg_K := Objects; + Has_Null_Exclusion := Null_Exclusion_Present (N); + Typ := Etype (Expr); + + if Nkind (Expr) = N_Qualified_Expression then + Related_Nod := Subtype_Mark (Expr); + else + Related_Nod := Expr; + end if; + + when others => + pragma Assert (False); + null; + end case; + + -- Check that the entity was already decorated + + pragma Assert (Typ /= Empty); + + if Has_Null_Exclusion + and then not Is_Access_Type (Typ) + then + Error_Msg_N ("(Ada 0Y) must be an access type", Related_Nod); + + elsif Has_Null_Exclusion + and then Can_Never_Be_Null (Typ) + then + Error_Msg_N + ("(Ada 0Y) already a null-excluding type", Related_Nod); + + elsif (Nkind (N) = N_Component_Declaration + or else Nkind (N) = N_Object_Declaration) + and not Present (Expr) + then + Must_Be_Initialized; + + elsif Present (Expr) + and then Nkind (Expr) = N_Null + then + Null_Not_Allowed; + end if; + end Null_Exclusion_Static_Checks; + + ---------------------------------- -- Conditional_Statements_Begin -- ---------------------------------- @@ -4192,6 +4354,38 @@ package body Checks is Validity_Checks_On := True; end Insert_Valid_Check; + ---------------------------------- + -- Install_Null_Excluding_Check -- + ---------------------------------- + + procedure Install_Null_Excluding_Check (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Etyp : constant Entity_Id := Etype (N); + + begin + pragma Assert (Is_Access_Type (Etyp)); + + -- Don't need access check if: 1) we are analyzing a generic, 2) it is + -- known to be non-null, or 3) the check was suppressed on the type + + if Inside_A_Generic + or else Access_Checks_Suppressed (Etyp) + then + return; + + -- Otherwise install access check + + else + Insert_Action (N, + Make_Raise_Constraint_Error (Loc, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => Duplicate_Subexpr_Move_Checks (N), + Right_Opnd => Make_Null (Loc)), + Reason => CE_Access_Check_Failed)); + end if; + end Install_Null_Excluding_Check; + -------------------------- -- Install_Static_Check -- -------------------------- diff --git a/gcc/ada/checks.ads b/gcc/ada/checks.ads index d6ad2bd..dcb4606 100644 --- a/gcc/ada/checks.ads +++ b/gcc/ada/checks.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2002 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2004 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- -- @@ -616,6 +616,9 @@ package Checks is -- the sense of the 'Valid attribute returning True. Constraint_Error -- will be raised if the value is not valid. + procedure Null_Exclusion_Static_Checks (N : Node_Id); + -- Ada 0Y (AI-231): Check bad usages of the null-exclusion issue + procedure Remove_Checks (Expr : Node_Id); -- Remove all checks from Expr except those that are only executed -- conditionally (on the right side of And Then/Or Else. This call diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 795d69e..a8180e4 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -1970,7 +1970,7 @@ package Einfo is -- Present in all entities. Relevant (and can be set True) only for -- objects of an access type. It is set if the object is currently -- known to have a non-null value (meaning that no access checks --- are needed). The indication can for eample3 come from assignment +-- are needed). The indication can for example3 come from assignment -- of an access parameter or an allocator. -- -- Note: this flag is set according to the sequential flow of the diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index e6e4231..c8a28aa 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -1052,7 +1052,7 @@ package body Exp_Ch3 is Controller_Typ : Entity_Id; begin - -- Nothing to do if the Init_Proc is null, unless Initialize_Sclalars + -- Nothing to do if the Init_Proc is null, unless Initialize_Scalars -- is active (in which case we make the call anyway, since in the -- actual compiled client it may be non null). @@ -1491,6 +1491,19 @@ package body Exp_Ch3 is Exp := New_Copy_Tree (Original_Node (Exp)); end if; + -- Ada 0Y (AI-231): Generate conversion to the null-excluding + -- type to force the corresponding run-time check + + if Extensions_Allowed + and then Can_Never_Be_Null (Etype (Id)) -- Lhs + and then (Present (Etype (Exp)) + and then not Can_Never_Be_Null (Etype (Exp))) + then + Rewrite (Exp, Convert_To (Etype (Id), + Relocate_Node (Exp))); + Analyze_And_Resolve (Exp, Etype (Id)); + end if; + Res := New_List ( Make_Assignment_Statement (Loc, Name => Lhs, @@ -3421,17 +3434,30 @@ package body Exp_Ch3 is then Set_Is_Known_Valid (Def_Id); - -- For access types set the Is_Known_Non_Null flag if the - -- initializing value is known to be non-null. We can also - -- set Can_Never_Be_Null if this is a constant. + elsif Is_Access_Type (Typ) then - elsif Is_Access_Type (Typ) - and then Known_Non_Null (Expr) - then - Set_Is_Known_Non_Null (Def_Id); + -- Ada 0Y (AI-231): Generate conversion to the null-excluding + -- type to force the corresponding run-time check - if Constant_Present (N) then - Set_Can_Never_Be_Null (Def_Id); + if Extensions_Allowed + and then (Can_Never_Be_Null (Def_Id) + or else Can_Never_Be_Null (Typ)) + then + Rewrite (Expr_Q, Convert_To (Etype (Def_Id), + Relocate_Node (Expr_Q))); + Analyze_And_Resolve (Expr_Q, Etype (Def_Id)); + end if; + + -- For access types set the Is_Known_Non_Null flag if the + -- initializing value is known to be non-null. We can also + -- set Can_Never_Be_Null if this is a constant. + + if Known_Non_Null (Expr) then + Set_Is_Known_Non_Null (Def_Id); + + if Constant_Present (N) then + Set_Can_Never_Be_Null (Def_Id); + end if; end if; end if; diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index a08cd1f..08ec7d5 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -1541,6 +1541,19 @@ package body Exp_Ch5 is (Expression (Rhs), Designated_Type (Etype (Lhs))); end if; + -- Ada 0Y (AI-231): Generate conversion to the null-excluding + -- type to force the corresponding run-time check + + if Is_Access_Type (Typ) + and then ((Is_Entity_Name (Lhs) + and then Can_Never_Be_Null (Entity (Lhs))) + or else Can_Never_Be_Null (Etype (Lhs))) + then + Rewrite (Rhs, Convert_To (Etype (Lhs), + Relocate_Node (Rhs))); + Analyze_And_Resolve (Rhs, Etype (Lhs)); + end if; + -- If we are assigning an access type and the left side is an -- entity, then make sure that Is_Known_Non_Null properly -- reflects the state of the entity after the assignment diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index b8d8ed2..469bae6 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -1382,7 +1382,7 @@ package body Exp_Ch6 is -- When passing an access parameter as the actual to another -- access parameter we need to pass along the actual's own - -- associated access level parameter. This is done is we are + -- associated access level parameter. This is done if we are -- in the scope of the formal access parameter (if this is an -- inlined body the extra formal is irrelevant). @@ -1516,7 +1516,12 @@ package body Exp_Ch6 is elsif Convention (Subp) = Convention_Java then null; - else + -- Ada 0Y (AI-231): do not force the check in case of Ada 0Y unless + -- it is a null-excluding type + + elsif not Extensions_Allowed + or else Can_Never_Be_Null (Etype (Prev)) + then Cond := Make_Op_Eq (Loc, Left_Opnd => Duplicate_Subexpr_No_Checks (Prev), @@ -1999,10 +2004,16 @@ package body Exp_Ch6 is -- temporaries are generated when compiling the body by -- itself. Otherwise link errors can occur. + -- If the function being called is itself in the main unit, + -- we cannot inline, because there is a risk of double + -- elaboration and/or circularity: the inlining can make + -- visible a private entity in the body of the main unit, + -- that gigi will see before its sees its proper definition. + elsif not (In_Extended_Main_Code_Unit (N)) and then In_Package_Body then - Must_Inline := True; + Must_Inline := not In_Extended_Main_Source_Unit (Subp); end if; end if; diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index 0864da7..f60980a 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -1488,6 +1488,7 @@ package body Exp_Ch9 is Protnm : constant Name_Id := Chars (Prottyp); Ident : Entity_Id; Nam : Name_Id; + New_Id : Entity_Id; New_Plist : List_Id; Append_Char : Character; New_Spec : Node_Id; @@ -1514,20 +1515,28 @@ package body Exp_Ch9 is Append_Char := 'P'; end if; + New_Id := + Make_Defining_Identifier (Loc, + Chars => Build_Selected_Name (Protnm, Nam, Append_Char)); + + -- The unprotected operation carries the user code, and debugging + -- information must be generated for it, even though this spec does + -- not come from source. It is also convenient to allow gdb to step + -- into the protected operation, even though it only contains lock/ + -- unlock calls. + + Set_Needs_Debug_Info (New_Id); + if Nkind (Specification (Decl)) = N_Procedure_Specification then return Make_Procedure_Specification (Loc, - Defining_Unit_Name => - Make_Defining_Identifier (Loc, - Chars => Build_Selected_Name (Protnm, Nam, Append_Char)), + Defining_Unit_Name => New_Id, Parameter_Specifications => New_Plist); else New_Spec := Make_Function_Specification (Loc, - Defining_Unit_Name => - Make_Defining_Identifier (Loc, - Chars => Build_Selected_Name (Protnm, Nam, Append_Char)), + Defining_Unit_Name => New_Id, Parameter_Specifications => New_Plist, Subtype_Mark => New_Copy (Subtype_Mark (Specification (Decl)))); Set_Return_Present (Defining_Unit_Name (New_Spec)); diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index 8dc14b7..62568f5 100644 --- a/gcc/ada/exp_util.ads +++ b/gcc/ada/exp_util.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2003 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2004 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- -- @@ -127,7 +127,7 @@ package Exp_Util is -- -- Implementation limitation: Assoc_Node must be a statement. We can -- generalize to expressions if there is a need but this is tricky to - -- implement because of short-ciruits (among other things).??? + -- implement because of short-circuits (among other things).??? procedure Insert_Library_Level_Action (N : Node_Id); -- This procedure inserts and analyzes the node N as an action at the diff --git a/gcc/ada/fname-sf.adb b/gcc/ada/fname-sf.adb index 962b335..28977e7 100644 --- a/gcc/ada/fname-sf.adb +++ b/gcc/ada/fname-sf.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2000 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2004 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- -- @@ -46,7 +46,11 @@ package body Fname.SF is -- Local Procedures -- ---------------------- - procedure Set_File_Name (Typ : Character; U : String; F : String); + procedure Set_File_Name + (Typ : Character; + U : String; + F : String; + Index : Natural); -- This is a transfer function that is called from Scan_SFN_Pragmas, -- and reformats its parameters appropriately for the version of -- Set_File_Name found in Fname.SF. @@ -89,10 +93,14 @@ package body Fname.SF is -- Set_File_Name -- ------------------- - procedure Set_File_Name (Typ : Character; U : String; F : String) is + procedure Set_File_Name + (Typ : Character; + U : String; + F : String; + Index : Natural) + is Unm : Unit_Name_Type; Fnm : File_Name_Type; - begin Name_Buffer (1 .. U'Length) := U; Name_Len := U'Length; @@ -104,7 +112,7 @@ package body Fname.SF is Name_Buffer (1 .. F'Length) := F; Name_Len := F'Length; Fnm := Name_Find; - Fname.UF.Set_File_Name (Unm, Fnm); + Fname.UF.Set_File_Name (Unm, Fnm, Nat (Index)); end Set_File_Name; --------------------------- diff --git a/gcc/ada/fname-uf.adb b/gcc/ada/fname-uf.adb index 9852688..00af708 100644 --- a/gcc/ada/fname-uf.adb +++ b/gcc/ada/fname-uf.adb @@ -32,6 +32,7 @@ with Namet; use Namet; with Opt; use Opt; with Osint; use Osint; with Table; +with Uname; use Uname; with Widechar; use Widechar; with GNAT.HTable; @@ -43,8 +44,9 @@ package body Fname.UF is -------------------------------------------------------- type SFN_Entry is record - U : Unit_Name_Type; -- Unit name - F : File_Name_Type; -- Spec/Body file name + U : Unit_Name_Type; -- Unit name + F : File_Name_Type; -- Spec/Body file name + Index : Nat; -- Index from SFN pragma (0 if none) end record; -- Record single Unit_Name type call to Set_File_Name @@ -118,6 +120,53 @@ package body Fname.UF is return Get_File_Name (Name_Enter, Subunit => False); end File_Name_Of_Spec; + ---------------------------- + -- Get_Expected_Unit_Type -- + ---------------------------- + + function Get_Expected_Unit_Type + (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. + + if Operating_Mode = Check_Syntax + or else Multiple_Unit_Index /= 0 + then + 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. + + for J in SFN_Table.First .. SFN_Table.Last loop + if Fname = SFN_Table.Table (J).F then + if Is_Body_Name (SFN_Table.Table (J).U) then + return Expect_Body; + else + return Expect_Spec; + end if; + 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. + + Get_Name_String (Fname); + + if Name_Len > 4 then + if Name_Buffer (Name_Len - 3 .. Name_Len) = ".ads" then + return Expect_Spec; + elsif Name_Buffer (Name_Len - 3 .. Name_Len) = ".adb" then + return Expect_Body; + end if; + end if; + + return Unknown; + end Get_Expected_Unit_Type; + ------------------- -- Get_File_Name -- ------------------- @@ -457,6 +506,20 @@ package body Fname.UF is end; end Get_File_Name; + -------------------- + -- Get_Unit_Index -- + -------------------- + + function Get_Unit_Index (Uname : Unit_Name_Type) return Nat is + N : constant Int := SFN_HTable.Get (Uname); + begin + if N /= No_Entry then + return SFN_Table.Table (N).Index; + else + return 0; + end if; + end Get_Unit_Index; + ---------------- -- Initialize -- ---------------- @@ -496,10 +559,14 @@ package body Fname.UF is -- Set_File_Name -- ------------------- - procedure Set_File_Name (U : Unit_Name_Type; F : File_Name_Type) is + procedure Set_File_Name + (U : Unit_Name_Type; + F : File_Name_Type; + Index : Nat) + is begin SFN_Table.Increment_Last; - SFN_Table.Table (SFN_Table.Last) := (U, F); + SFN_Table.Table (SFN_Table.Last) := (U, F, Index); SFN_HTable.Set (U, SFN_Table.Last); end Set_File_Name; @@ -514,6 +581,7 @@ package body Fname.UF is Cas : Casing_Type) is L : constant Nat := SFN_Patterns.Last; + begin SFN_Patterns.Increment_Last; diff --git a/gcc/ada/fname-uf.ads b/gcc/ada/fname-uf.ads index aad0e25..d829a20 100644 --- a/gcc/ada/fname-uf.ads +++ b/gcc/ada/fname-uf.ads @@ -43,6 +43,16 @@ package Fname.UF is -- Subprograms -- ----------------- + type Expected_Unit_Type is (Expect_Body, Expect_Spec, Unknown); + -- Return value from Get_Expected_Unit_Type + + function Get_Expected_Unit_Type + (Fname : File_Name_Type) return Expected_Unit_Type; + -- If possible, determine whether the given file name corresponds to a unit + -- that is a spec or body (e.g. by examining the extension). If this cannot + -- be determined with the file naming conventions in use, then the returned + -- value is set to Unknown. + function Get_File_Name (Uname : Unit_Name_Type; Subunit : Boolean; @@ -52,11 +62,16 @@ package Fname.UF is -- false for all other kinds of units. The caller is responsible for -- ensuring that the unit name meets the requirements given in package -- Uname and described above. + -- -- When May_Fail is True, if the file cannot be found, this function -- returns No_File. When it is False, if the file cannot be found, -- a file name compatible with one pattern Source_File_Name pragma is -- returned. + function Get_Unit_Index (Uname : Unit_Name_Type) return Nat; + -- If there is a specific Source_File_Name pragma for this unit, then + -- return the corresponding unit index value. Return 0 if no index given. + procedure Initialize; -- Initialize internal tables. This is called automatically when the -- package body is elaborated, so an explicit call to Initialize is @@ -76,9 +91,14 @@ package Fname.UF is -- name. The unit name here is not encoded as a Unit_Name_Type, but is -- rather just a normal form name in lower case, e.g. "xyz.def". - procedure Set_File_Name (U : Unit_Name_Type; F : File_Name_Type); + procedure Set_File_Name + (U : Unit_Name_Type; + F : File_Name_Type; + Index : Nat); -- Make association between given unit name, U, and the given file name, -- F. This is the routine called to process a Source_File_Name pragma. + -- Index is the value from the index parameter of the pragma if present + -- and zero if no index parameter is present. procedure Set_File_Name_Pattern (Pat : String_Ptr; diff --git a/gcc/ada/fname.adb b/gcc/ada/fname.adb index b771772..fd3e92e 100644 --- a/gcc/ada/fname.adb +++ b/gcc/ada/fname.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2003, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2004, 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- -- @@ -59,31 +59,6 @@ package body Fname is Table_Initial => Alloc.SFN_Table_Initial, Table_Increment => Alloc.SFN_Table_Increment, Table_Name => "Fname_Dummy_Table"); - ---------------------------- - -- Get_Expected_Unit_Type -- - ---------------------------- - - -- We assume that a file name whose last character is a lower case b is - -- a body and a file name whose last character is a lower case s is a - -- spec. If any other character is found (e.g. when we are in syntax - -- checking only mode, where the file name conventions are not set), - -- then we return Unknown. - - function Get_Expected_Unit_Type - (Fname : File_Name_Type) - return Expected_Unit_Type - is - begin - Get_Name_String (Fname); - - if Name_Buffer (Name_Len) = 'b' then - return Expect_Body; - elsif Name_Buffer (Name_Len) = 's' then - return Expect_Spec; - else - return Unknown; - end if; - end Get_Expected_Unit_Type; --------------------------- -- Is_Internal_File_Name -- @@ -91,8 +66,7 @@ package body Fname is function Is_Internal_File_Name (Fname : File_Name_Type; - Renamings_Included : Boolean := True) - return Boolean + Renamings_Included : Boolean := True) return Boolean is begin if Is_Predefined_File_Name (Fname, Renamings_Included) then @@ -132,8 +106,7 @@ package body Fname is function Is_Predefined_File_Name (Fname : File_Name_Type; - Renamings_Included : Boolean := True) - return Boolean + Renamings_Included : Boolean := True) return Boolean is begin Get_Name_String (Fname); @@ -141,8 +114,7 @@ package body Fname is end Is_Predefined_File_Name; function Is_Predefined_File_Name - (Renamings_Included : Boolean := True) - return Boolean + (Renamings_Included : Boolean := True) return Boolean is subtype Str8 is String (1 .. 8); diff --git a/gcc/ada/fname.ads b/gcc/ada/fname.ads index 380b617..151971c 100644 --- a/gcc/ada/fname.ads +++ b/gcc/ada/fname.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2003 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2004 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- -- @@ -64,17 +64,6 @@ package Fname is -- Subprograms -- ----------------- - type Expected_Unit_Type is (Expect_Body, Expect_Spec, Unknown); - -- Return value from Get_Expected_Unit_Type - - function Get_Expected_Unit_Type - (Fname : File_Name_Type) - return Expected_Unit_Type; - -- If possible, determine whether the given file name corresponds to a unit - -- that is a spec or body (e.g. by examining the extension). If this cannot - -- be determined with the file naming conventions in use, then the returned - -- value is set to Unknown. - function Is_Predefined_File_Name (Fname : File_Name_Type; Renamings_Included : Boolean := True) return Boolean; @@ -92,8 +81,7 @@ package Fname is function Is_Internal_File_Name (Fname : File_Name_Type; - Renamings_Included : Boolean := True) - return Boolean; + Renamings_Included : Boolean := True) return Boolean; -- Similar to Is_Predefined_File_Name. The internal file set is a -- superset of the predefined file set including children of GNAT, -- and also children of DEC for the VMS case. diff --git a/gcc/ada/gnat1drv.adb b/gcc/ada/gnat1drv.adb index 45a2c5a..a544e55 100644 --- a/gcc/ada/gnat1drv.adb +++ b/gcc/ada/gnat1drv.adb @@ -310,7 +310,13 @@ begin -- include both in a partition, this is diagnosed at bind time. -- In Ada 83 mode this is not a warning case. + -- Note: if weird file names are being used, we can have a + -- situation where the file name that supposedly contains a + -- body, in fact contains a spec, or we can't tell what it + -- contains. Skip the error message in these cases. + if Src_Ind /= No_Source_File + and then Get_Expected_Unit_Type (Fname) = Expect_Body and then not Source_File_Is_Subunit (Src_Ind) then Error_Msg_Name_1 := Sname; diff --git a/gcc/ada/lib-load.adb b/gcc/ada/lib-load.adb index 212c465..b294a84 100644 --- a/gcc/ada/lib-load.adb +++ b/gcc/ada/lib-load.adb @@ -153,6 +153,7 @@ package body Lib.Load is Ident_String => Empty, Loading => False, Main_Priority => Default_Main_Priority, + Munit_Index => 0, Serial_Number => 0, Source_Index => No_Source_File, Unit_File_Name => Get_File_Name (Spec_Name, Subunit => False), @@ -221,9 +222,10 @@ package body Lib.Load is Fatal_Error => False, Generate_Code => False, Has_RACW => False, - Loading => True, Ident_String => Empty, + Loading => True, Main_Priority => Default_Main_Priority, + Munit_Index => 0, Serial_Number => 0, Source_Index => Main_Source_File, Unit_File_Name => Fname, @@ -462,7 +464,10 @@ package body Lib.Load is -- then we have the problem that the file does not contain the unit that -- is needed. We simply treat this as a file not found condition. - if Unum > Units.Last then + -- We skip this test in multiple unit per file mode since in this + -- case we can have multiple units from the same source file. + + if Unum > Units.Last and then Multiple_Unit_Index = 0 then for J in Units.First .. Units.Last loop if Fname = Units.Table (J).Unit_File_Name then if Debug_Flag_L then @@ -473,7 +478,6 @@ package body Lib.Load is end if; if Present (Error_Node) then - if Is_Predefined_File_Name (Fname) then Error_Msg_Name_1 := Uname_Actual; Error_Msg @@ -546,7 +550,7 @@ package body Lib.Load is Set_Load_Unit_Dependency (Unum); return Unum; - -- File is not already in table, so try to open it + -- Unit is not already in table, so try to open the file else if Debug_Flag_L then @@ -580,6 +584,7 @@ package body Lib.Load is Ident_String => Empty, Loading => True, Main_Priority => Default_Main_Priority, + Munit_Index => 0, Serial_Number => 0, Source_Index => Src_Ind, Unit_File_Name => Fname, @@ -588,9 +593,16 @@ package body Lib.Load is -- Parse the new unit - Initialize_Scanner (Unum, Source_Index (Unum)); - Discard_List (Par (Configuration_Pragmas => False)); - Set_Loading (Unum, False); + declare + Save_Index : constant Nat := Multiple_Unit_Index; + begin + Multiple_Unit_Index := Get_Unit_Index (Uname_Actual); + Units.Table (Unum).Munit_Index := Multiple_Unit_Index; + Initialize_Scanner (Unum, Source_Index (Unum)); + Discard_List (Par (Configuration_Pragmas => False)); + Multiple_Unit_Index := Save_Index; + Set_Loading (Unum, False); + end; -- If spec is irrelevant, then post errors and quit diff --git a/gcc/ada/lib-writ.adb b/gcc/ada/lib-writ.adb index 1cafffe..bc6bfe5 100644 --- a/gcc/ada/lib-writ.adb +++ b/gcc/ada/lib-writ.adb @@ -76,6 +76,7 @@ package body Lib.Writ is Ident_String => Empty, Loading => False, Main_Priority => -1, + Munit_Index => 0, Serial_Number => 0, Version => 0, Error_Location => No_Location); @@ -92,8 +93,6 @@ package body Lib.Writ is System_Fname : File_Name_Type; -- File name for system spec if needed for dummy entry - Save_Style : constant Boolean := Style_Check; - begin -- Nothing to do if we already compiled System @@ -131,6 +130,7 @@ package body Lib.Writ is Ident_String => Empty, Loading => False, Main_Priority => -1, + Munit_Index => 0, Serial_Number => 0, Version => 0, Error_Location => No_Location); @@ -138,10 +138,17 @@ package body Lib.Writ is -- Parse system.ads so that the checksum is set right -- Style checks are not applied. - Style_Check := False; - Initialize_Scanner (Units.Last, System_Source_File_Index); - Discard_List (Par (Configuration_Pragmas => False)); - Style_Check := Save_Style; + declare + Save_Mindex : constant Nat := Multiple_Unit_Index; + Save_Style : constant Boolean := Style_Check; + begin + Multiple_Unit_Index := 0; + Style_Check := False; + Initialize_Scanner (Units.Last, System_Source_File_Index); + Discard_List (Par (Configuration_Pragmas => False)); + Style_Check := Save_Style; + Multiple_Unit_Index := Save_Mindex; + end; end Ensure_System_Dependency; --------------- @@ -667,11 +674,13 @@ package body Lib.Writ is then Write_Info_Name (Body_Fname); Write_Info_Tab (49); - Write_Info_Name (Lib_File_Name (Body_Fname)); + Write_Info_Name + (Lib_File_Name (Body_Fname, Munit_Index (Unum))); else Write_Info_Name (Fname); Write_Info_Tab (49); - Write_Info_Name (Lib_File_Name (Fname)); + Write_Info_Name + (Lib_File_Name (Fname, Munit_Index (Unum))); end if; if Elab_Flags (Unum) then diff --git a/gcc/ada/lib.adb b/gcc/ada/lib.adb index 5e90930..124ca39 100644 --- a/gcc/ada/lib.adb +++ b/gcc/ada/lib.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2003 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2004 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- -- @@ -133,6 +133,11 @@ package body Lib is return Units.Table (U).Main_Priority; end Main_Priority; + function Munit_Index (U : Unit_Number_Type) return Nat is + begin + return Units.Table (U).Munit_Index; + end Munit_Index; + function Source_Index (U : Unit_Number_Type) return Source_File_Index is begin return Units.Table (U).Source_Index; @@ -596,7 +601,7 @@ package body Lib is end if; -- If S was No_Location, or was not in the table, we must be in the - -- main source unit (and the value is not got put into the table yet) + -- main source unit (and the value has not got put into the table yet) return Main_Unit; end Get_Source_Unit; @@ -798,7 +803,6 @@ package body Lib is function Increment_Serial_Number return Nat is TSN : Int renames Units.Table (Current_Sem_Unit).Serial_Number; - begin TSN := TSN + 1; return TSN; diff --git a/gcc/ada/lib.ads b/gcc/ada/lib.ads index 5dae581..2a94f86 100644 --- a/gcc/ada/lib.ads +++ b/gcc/ada/lib.ads @@ -262,6 +262,10 @@ package Lib is -- Set when the entry is created by a call to Lib.Load and then cannot -- be changed. + -- Munit_Index + -- The index of the unit within the file for multiple unit per file + -- mode. Set to zero in normal single unit per file mode. + -- Error_Location -- This is copied from the Sloc field of the Enode argument passed -- to Load_Unit. It refers to the enclosing construct which caused @@ -388,6 +392,7 @@ package Lib is function Has_RACW (U : Unit_Number_Type) return Boolean; function Loading (U : Unit_Number_Type) return Boolean; function Main_Priority (U : Unit_Number_Type) return Int; + function Munit_Index (U : Unit_Number_Type) return Nat; function Source_Index (U : Unit_Number_Type) return Source_File_Index; function Unit_File_Name (U : Unit_Number_Type) return File_Name_Type; function Unit_Name (U : Unit_Number_Type) return Unit_Name_Type; @@ -614,6 +619,7 @@ private pragma Inline (Increment_Serial_Number); pragma Inline (Loading); pragma Inline (Main_Priority); + pragma Inline (Munit_Index); pragma Inline (Set_Cunit); pragma Inline (Set_Cunit_Entity); pragma Inline (Set_Fatal_Error); @@ -629,6 +635,7 @@ private type Unit_Record is record Unit_File_Name : File_Name_Type; Unit_Name : Unit_Name_Type; + Munit_Index : Nat; Expected_Unit : Unit_Name_Type; Source_Index : Source_File_Index; Cunit : Node_Id; diff --git a/gcc/ada/memtrack.adb b/gcc/ada/memtrack.adb index 39ffb82..a36e52b 100644 --- a/gcc/ada/memtrack.adb +++ b/gcc/ada/memtrack.adb @@ -31,7 +31,7 @@ -- -- ------------------------------------------------------------------------------ --- This version contains allocation tracking capability. +-- This version contains allocation tracking capability -- The object file corresponding to this instrumented version is to be found -- in libgmem. @@ -313,7 +313,6 @@ package body System.Memory is Lock_Task.all; if First_Call then - First_Call := False; -- We first log deallocation call diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads index 2c78b75..77468fa 100644 --- a/gcc/ada/opt.ads +++ b/gcc/ada/opt.ads @@ -659,6 +659,14 @@ package Opt is -- GNATMAKE -- Set to True if minimal recompilation mode requested. + Multiple_Unit_Index : Int; + -- GNAT + -- This is set non-zero if the current unit is being compiled in multiple + -- unit per file mode, meaning that the current unit is selected from the + -- sequence of units in the current source file, using the value stored + -- in this variable (e.g. 2 = select second unit in file). A value of + -- zero indicates that we are in normal (one unit per file) mode. + No_Main_Subprogram : Boolean := False; -- GNATMAKE, GNATBIND -- Set to True if compilation/binding of a program without main diff --git a/gcc/ada/osint-c.adb b/gcc/ada/osint-c.adb index d925abf..7914b1b 100644 --- a/gcc/ada/osint-c.adb +++ b/gcc/ada/osint-c.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2003 Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2004 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- -- @@ -43,8 +43,7 @@ package body Osint.C is function Create_Auxiliary_File (Src : File_Name_Type; - Suffix : String) - return File_Name_Type; + Suffix : String) return File_Name_Type; -- Common processing for Creat_Repinfo_File and Create_Debug_File. -- Src is the file name used to create the required output file and -- Suffix is the desired suffic (dg/rep for debug/repinfo file). @@ -52,7 +51,8 @@ package body Osint.C is procedure Set_Library_Info_Name; -- Sets a default ali file name from the main compiler source name. -- This is used by Create_Output_Library_Info, and by the version of - -- Read_Library_Info that takes a default file name. + -- Read_Library_Info that takes a default file name. The name is in + -- Name_Buffer (with length in Name_Len) on return from the call ---------------------- -- Close_Debug_File -- @@ -60,6 +60,7 @@ package body Osint.C is procedure Close_Debug_File is Status : Boolean; + begin Close (Output_FD, Status); @@ -76,6 +77,7 @@ package body Osint.C is procedure Close_Output_Library_Info is Status : Boolean; + begin Close (Output_FD, Status); @@ -92,6 +94,7 @@ package body Osint.C is procedure Close_Repinfo_File is Status : Boolean; + begin Close (Output_FD, Status); @@ -108,8 +111,7 @@ package body Osint.C is function Create_Auxiliary_File (Src : File_Name_Type; - Suffix : String) - return File_Name_Type + Suffix : String) return File_Name_Type is Result : File_Name_Type; @@ -256,18 +258,36 @@ package body Osint.C is -- To compare them, remove file name directories and extensions. if Output_Object_File_Name /= null then + -- Make sure there is a dot at Dot_Index. This may not be the case -- if the source file name has no extension. Name_Buffer (Dot_Index) := '.'; + -- If we are in multiple unit per file mode, then add ~nnn + -- extension to the name before doing the comparison. + + if Multiple_Unit_Index /= 0 then + declare + Exten : constant String := Name_Buffer (Dot_Index .. Name_Len); + begin + Name_Len := Dot_Index - 1; + Add_Char_To_Name_Buffer ('~'); + Add_Nat_To_Name_Buffer (Multiple_Unit_Index); + Dot_Index := Name_Len + 1; + Add_Str_To_Name_Buffer (Exten); + end; + end if; + + -- Remove extension preparing to replace it + declare Name : constant String := Name_Buffer (1 .. Dot_Index); Len : constant Natural := Dot_Index; begin - Name_Buffer (1 .. Output_Object_File_Name'Length) - := Output_Object_File_Name.all; + Name_Buffer (1 .. Output_Object_File_Name'Length) := + Output_Object_File_Name.all; Dot_Index := 0; for J in reverse Output_Object_File_Name'Range loop @@ -277,8 +297,11 @@ package body Osint.C is end if; end loop; + -- Dot_Index should be zero now (we check for extension elsewhere) + pragma Assert (Dot_Index /= 0); - -- We check for the extension elsewhere + + -- Check name of object file is what we expect if Name /= Name_Buffer (Dot_Index - Len + 1 .. Dot_Index) then Fail ("incorrect object file name"); diff --git a/gcc/ada/osint.adb b/gcc/ada/osint.adb index 93cdb12..fcf4e13 100644 --- a/gcc/ada/osint.adb +++ b/gcc/ada/osint.adb @@ -750,13 +750,11 @@ package body Osint is return Name_Enter; end Executable_Name; - ------------------------- + ----------------------- -- Executable_Prefix -- - ------------------------- + ----------------------- function Executable_Prefix return String_Ptr is - Exec_Name : String (1 .. Len_Arg (0)); - function Get_Install_Dir (Exec : String) return String_Ptr; -- S is the executable name preceeded by the absolute or relative -- path, e.g. "c:\usr\bin\gcc.exe" or "..\bin\gcc". @@ -790,21 +788,25 @@ package body Osint is -- Start of processing for Executable_Prefix begin - Osint.Fill_Arg (Exec_Name'Address, 0); + if Exec_Name = null then + Exec_Name := new String (1 .. Len_Arg (0)); + Osint.Fill_Arg (Exec_Name (1)'Address, 0); + end if; -- First determine if a path prefix was placed in front of the -- executable name. for J in reverse Exec_Name'Range loop if Is_Directory_Separator (Exec_Name (J)) then - return Get_Install_Dir (Exec_Name); + return Get_Install_Dir (Exec_Name.all); end if; end loop; -- If we come here, the user has typed the executable name with no -- directory prefix. - return Get_Install_Dir (GNAT.OS_Lib.Locate_Exec_On_Path (Exec_Name).all); + return Get_Install_Dir + (GNAT.OS_Lib.Locate_Exec_On_Path (Exec_Name.all).all); end Executable_Prefix; ------------------ @@ -1390,27 +1392,26 @@ package body Osint is ------------------- function Lib_File_Name - (Source_File : File_Name_Type) - return File_Name_Type + (Source_File : File_Name_Type; + Munit_Index : Nat := 0) return File_Name_Type is - Fptr : Natural; - -- Pointer to location to set extension in place - begin Get_Name_String (Source_File); - Fptr := Name_Len + 1; for J in reverse 2 .. Name_Len loop if Name_Buffer (J) = '.' then - Fptr := J; + Name_Len := J - 1; exit; end if; end loop; - Name_Buffer (Fptr) := '.'; - Name_Buffer (Fptr + 1 .. Fptr + ALI_Suffix'Length) := ALI_Suffix.all; - Name_Buffer (Fptr + ALI_Suffix'Length + 1) := ASCII.NUL; - Name_Len := Fptr + ALI_Suffix'Length; + if Munit_Index /= 0 then + Add_Char_To_Name_Buffer ('~'); + Add_Nat_To_Name_Buffer (Munit_Index); + end if; + + Add_Char_To_Name_Buffer ('.'); + Add_Str_To_Name_Buffer (ALI_Suffix.all); return Name_Find; end Lib_File_Name; diff --git a/gcc/ada/osint.ads b/gcc/ada/osint.ads index ec86234..0e87e9a 100644 --- a/gcc/ada/osint.ads +++ b/gcc/ada/osint.ads @@ -235,7 +235,7 @@ package Osint is procedure Get_Next_Dir_In_Path_Init (Search_Path : String_Access); - function Get_Next_Dir_In_Path + function Get_Next_Dir_In_Path (Search_Path : String_Access) return String_Access; -- These subprograms are used to parse out the directory names in a -- search path specified by a Search_Path argument. The procedure @@ -271,11 +271,14 @@ package Osint is -- directories. These files, located in Sdefault.Search_Dir_Prefix, do -- not necessarily exist. + Exec_Name : String_Ptr; + -- Executable name as typed by the user (used to compute the + -- executable prefix). + function Read_Default_Search_Dirs (Search_Dir_Prefix : String_Access; Search_File : String_Access; - Search_Dir_Default_Name : String_Access) - return String_Access; + Search_Dir_Default_Name : String_Access) return String_Access; -- Read and return the default search directories from the file located -- in Search_Dir_Prefix (as modified by update_path) and named Search_File. -- If no such file exists or an error occurs then instead return the @@ -480,11 +483,15 @@ package Osint is -- file directory lookup penalty is incurred every single time this -- routine is called. - function Lib_File_Name (Source_File : File_Name_Type) return File_Name_Type; + function Lib_File_Name + (Source_File : File_Name_Type; + Munit_Index : Nat := 0) return File_Name_Type; -- Given the name of a source file, returns the name of the corresponding -- library information file. This may be the name of the object file, or -- of a separate file used to store the library information. In either case -- the returned result is suitable for use in a call to Read_Library_Info. + -- The Munit_Index is the unit index in multiple unit per file mode, or + -- zero in normal single unit per file mode (used to add ~nnn suffix). -- Note: this subprogram is in this section because it is used by the -- compiler to determine the proper library information names to be placed -- in the generated library information file. diff --git a/gcc/ada/par-ch10.adb b/gcc/ada/par-ch10.adb index 475f0c3..985d9e3 100644 --- a/gcc/ada/par-ch10.adb +++ b/gcc/ada/par-ch10.adb @@ -301,7 +301,6 @@ package body Ch10 is else if Operating_Mode = Check_Syntax and then Token = Tok_EOF then Error_Msg_SC ("?file contains no compilation units"); - else Error_Msg_SC ("compilation unit expected"); Cunit_Error_Flag := True; @@ -333,15 +332,10 @@ package body Ch10 is -- contained subprogram bodies), by knowing that that the file we -- are compiling has a name that requires a body to be found. - -- However, we do not do this check if we are operating in syntax - -- checking only mode, because in that case there may be multiple - -- units in the same file, and the file name is not a reliable guide. - Save_Scan_State (Scan_State); Scan; -- past Package keyword if Token /= Tok_Body - and then Operating_Mode /= Check_Syntax and then Get_Expected_Unit_Type (File_Name (Current_Source_File)) = Expect_Body @@ -665,13 +659,26 @@ package body Ch10 is elsif Operating_Mode = Check_Syntax then return Comp_Unit_Node; + -- We also allow multiple units if we are in multiple unit mode + + elsif Multiple_Unit_Index /= 0 then + + -- Skip tokens to end of file, so that the -gnatl listing + -- will be complete in this situation, but no need to parse + -- the remaining units. + + while Token /= Tok_EOF loop + Scan; + end loop; + + return Comp_Unit_Node; + -- Otherwise we have an error. We suppress the error message -- if we already had a fatal error, since this stops junk -- cascaded messages in some situations. else if not Fatal_Error (Current_Source_Unit) then - if Token in Token_Class_Cunit then Error_Msg_SC ("end of file expected, " & @@ -706,7 +713,6 @@ package body Ch10 is when Error_Resync => Set_Fatal_Error (Current_Source_Unit); return Error; - end P_Compilation_Unit; -------------------------- diff --git a/gcc/ada/par-ch3.adb b/gcc/ada/par-ch3.adb index c5f2464..7940fe4 100644 --- a/gcc/ada/par-ch3.adb +++ b/gcc/ada/par-ch3.adb @@ -387,7 +387,8 @@ package body Ch3 is loop case Token is - when Tok_Access => + when Tok_Access | + Tok_Not => -- Ada 0Y (AI-231) Typedef_Node := P_Access_Type_Definition; TF_Semicolon; exit; @@ -727,8 +728,8 @@ package body Ch3 is -- Error recovery: can raise Error_Resync function P_Subtype_Declaration return Node_Id is - Decl_Node : Node_Id; - + Decl_Node : Node_Id; + Not_Null_Present : Boolean := False; begin Decl_Node := New_Node (N_Subtype_Declaration, Token_Ptr); Scan; -- past SUBTYPE @@ -740,7 +741,13 @@ package body Ch3 is Scan; -- past NEW end if; - Set_Subtype_Indication (Decl_Node, P_Subtype_Indication); + if Extensions_Allowed then -- Ada 0Y (AI-231) + Not_Null_Present := P_Null_Exclusion; + Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present); + end if; + + Set_Subtype_Indication + (Decl_Node, P_Subtype_Indication (Not_Null_Present)); TF_Semicolon; return Decl_Node; end P_Subtype_Declaration; @@ -749,17 +756,43 @@ package body Ch3 is -- 3.2.2 Subtype Indication -- ------------------------------- - -- SUBTYPE_INDICATION ::= SUBTYPE_MARK [CONSTRAINT] + -- SUBTYPE_INDICATION ::= + -- [NOT NULL] SUBTYPE_MARK [CONSTRAINT] -- Error recovery: can raise Error_Resync - function P_Subtype_Indication return Node_Id is - Type_Node : Node_Id; + function P_Null_Exclusion return Boolean is + begin + if Token /= Tok_Not then + return False; + + else + if not Extensions_Allowed then + Error_Msg_SP + ("null-excluding access is an Ada 0Y extension"); + Error_Msg_SP ("\unit must be compiled with -gnatX switch"); + end if; + + Scan; -- past NOT + + if Token = Tok_Null then + Scan; -- past NULL + else + Error_Msg_SP ("(Ada 0Y) missing NULL"); + end if; + + return True; + end if; + end P_Null_Exclusion; + + function P_Subtype_Indication + (Not_Null_Present : Boolean := False) return Node_Id is + Type_Node : Node_Id; begin if Token = Tok_Identifier or else Token = Tok_Operator_Symbol then Type_Node := P_Subtype_Mark; - return P_Subtype_Indication (Type_Node); + return P_Subtype_Indication (Type_Node, Not_Null_Present); else -- Check for error of using record definition and treat it nicely, @@ -782,9 +815,11 @@ package body Ch3 is -- Error recovery: can raise Error_Resync - function P_Subtype_Indication (Subtype_Mark : Node_Id) return Node_Id is - Indic_Node : Node_Id; - Constr_Node : Node_Id; + function P_Subtype_Indication + (Subtype_Mark : Node_Id; + Not_Null_Present : Boolean := False) return Node_Id is + Indic_Node : Node_Id; + Constr_Node : Node_Id; begin Constr_Node := P_Constraint_Opt; @@ -792,6 +827,10 @@ package body Ch3 is if No (Constr_Node) then return Subtype_Mark; else + if Not_Null_Present then + Error_Msg_SP ("(Ada 0Y) constrained null-exclusion not allowed"); + end if; + Indic_Node := New_Node (N_Subtype_Indication, Sloc (Subtype_Mark)); Set_Subtype_Mark (Indic_Node, Check_Subtype_Mark (Subtype_Mark)); Set_Constraint (Indic_Node, Constr_Node); @@ -1017,16 +1056,17 @@ package body Ch3 is Done : out Boolean; In_Spec : Boolean) is - Acc_Node : Node_Id; - Decl_Node : Node_Id; - Type_Node : Node_Id; - Ident_Sloc : Source_Ptr; - Scan_State : Saved_Scan_State; - List_OK : Boolean := True; - Ident : Nat; - Init_Expr : Node_Id; - Init_Loc : Source_Ptr; - Con_Loc : Source_Ptr; + Acc_Node : Node_Id; + Decl_Node : Node_Id; + Type_Node : Node_Id; + Ident_Sloc : Source_Ptr; + Scan_State : Saved_Scan_State; + List_OK : Boolean := True; + Ident : Nat; + Init_Expr : Node_Id; + Init_Loc : Source_Ptr; + Con_Loc : Source_Ptr; + Not_Null_Present : Boolean := False; Idents : array (Int range 1 .. 4096) of Entity_Id; -- Used to save identifiers in the identifier list. The upper bound @@ -1241,6 +1281,11 @@ package body Ch3 is Init_Expr := Init_Expr_Opt; if Present (Init_Expr) then + if Not_Null_Present then + Error_Msg_SP ("(Ada 0Y) null-exclusion not allowed in " + & "numeric expression"); + end if; + Decl_Node := New_Node (N_Number_Declaration, Ident_Sloc); Set_Expression (Decl_Node, Init_Expr); @@ -1248,6 +1293,7 @@ package body Ch3 is else Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc); + Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present); Set_Constant_Present (Decl_Node, True); if Token_Name = Name_Aliased then @@ -1264,8 +1310,15 @@ package body Ch3 is if Token = Tok_Array then Set_Object_Definition (Decl_Node, P_Array_Type_Definition); + else - Set_Object_Definition (Decl_Node, P_Subtype_Indication); + if Extensions_Allowed then -- Ada 0Y (AI-231) + Not_Null_Present := P_Null_Exclusion; + Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present); + end if; + + Set_Object_Definition (Decl_Node, + P_Subtype_Indication (Not_Null_Present)); end if; if Token = Tok_Renames then @@ -1298,6 +1351,7 @@ package body Ch3 is Scan; -- past ALIASED Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc); Set_Aliased_Present (Decl_Node, True); + Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present); if Token = Tok_Constant then Scan; -- past CONSTANT @@ -1307,8 +1361,15 @@ package body Ch3 is if Token = Tok_Array then Set_Object_Definition (Decl_Node, P_Array_Type_Definition); + else - Set_Object_Definition (Decl_Node, P_Subtype_Indication); + if Extensions_Allowed then -- Ada 0Y (AI-231) + Not_Null_Present := P_Null_Exclusion; + Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present); + end if; + + Set_Object_Definition (Decl_Node, + P_Subtype_Indication (Not_Null_Present)); end if; -- Array case @@ -1344,11 +1405,20 @@ package body Ch3 is -- Subtype indication case else + if Extensions_Allowed then -- Ada 0Y (AI-231) + Not_Null_Present := P_Null_Exclusion; + end if; + Type_Node := P_Subtype_Mark; -- Object renaming declaration if Token_Is_Renames then + if Not_Null_Present then + Error_Msg_SP + ("(Ada 0Y) null-exclusion not allowed in renamings"); + end if; + No_List; Decl_Node := New_Node (N_Object_Renaming_Declaration, Ident_Sloc); @@ -1359,8 +1429,10 @@ package body Ch3 is else Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc); + Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present); Set_Object_Definition - (Decl_Node, P_Subtype_Indication (Type_Node)); + (Decl_Node, + P_Subtype_Indication (Type_Node, Not_Null_Present)); -- RENAMES at this point means that we had the combination of -- a constraint on the Type_Node and renames, which is illegal @@ -1466,9 +1538,9 @@ package body Ch3 is -- Error recovery: can raise Error_Resync; function P_Derived_Type_Def_Or_Private_Ext_Decl return Node_Id is - Typedef_Node : Node_Id; - Typedecl_Node : Node_Id; - + Typedef_Node : Node_Id; + Typedecl_Node : Node_Id; + Not_Null_Present : Boolean := False; begin Typedef_Node := New_Node (N_Derived_Type_Definition, Token_Ptr); T_New; @@ -1478,7 +1550,13 @@ package body Ch3 is Scan; end if; - Set_Subtype_Indication (Typedef_Node, P_Subtype_Indication); + if Extensions_Allowed then -- Ada 0Y (AI-231) + Not_Null_Present := P_Null_Exclusion; + Set_Null_Exclusion_Present (Typedef_Node, Not_Null_Present); + end if; + + Set_Subtype_Indication (Typedef_Node, + P_Subtype_Indication (Not_Null_Present)); -- Deal with record extension, note that we assume that a WITH is -- missing in the case of "type X is new Y record ..." or in the @@ -2045,11 +2123,12 @@ package body Ch3 is -- Error recovery: can raise Error_Resync function P_Array_Type_Definition return Node_Id is - Array_Loc : Source_Ptr; - CompDef_Node : Node_Id; - Def_Node : Node_Id; - Subs_List : List_Id; - Scan_State : Saved_Scan_State; + Array_Loc : Source_Ptr; + CompDef_Node : Node_Id; + Def_Node : Node_Id; + Not_Null_Present : Boolean := False; + Subs_List : List_Id; + Scan_State : Saved_Scan_State; begin Array_Loc := Token_Ptr; @@ -2134,7 +2213,13 @@ package body Ch3 is Scan; -- past ALIASED end if; - Set_Subtype_Indication (CompDef_Node, P_Subtype_Indication); + if Extensions_Allowed then -- Ada 0Y (AI-231) + Not_Null_Present := P_Null_Exclusion; + Set_Null_Exclusion_Present (CompDef_Node, Not_Null_Present); + end if; + + Set_Subtype_Indication (CompDef_Node, + P_Subtype_Indication (Not_Null_Present)); end if; Set_Component_Definition (Def_Node, CompDef_Node); @@ -2315,6 +2400,7 @@ package body Ch3 is Ident_Sloc : Source_Ptr; Scan_State : Saved_Scan_State; Num_Idents : Nat; + Not_Null_Present : Boolean; Ident : Nat; Idents : array (Int range 1 .. 4096) of Entity_Id; @@ -2358,6 +2444,8 @@ package body Ch3 is New_Node (N_Discriminant_Specification, Ident_Sloc); Set_Defining_Identifier (Specification_Node, Idents (Ident)); + Not_Null_Present := P_Null_Exclusion; -- Ada 0Y (AI-231) + if Token = Tok_Access then if Ada_83 then Error_Msg_SC @@ -2366,10 +2454,15 @@ package body Ch3 is Set_Discriminant_Type (Specification_Node, P_Access_Definition); + Set_Null_Exclusion_Present -- Ada 0Y (AI-231) + (Discriminant_Type (Specification_Node), + Not_Null_Present); else Set_Discriminant_Type (Specification_Node, P_Subtype_Mark); No_Constraint; + Set_Null_Exclusion_Present -- Ada 0Y (AI-231) + (Specification_Node, Not_Null_Present); end if; Set_Expression @@ -2782,12 +2875,13 @@ package body Ch3 is -- items, do we need to add this capability sometime in the future ??? procedure P_Component_Items (Decls : List_Id) is - CompDef_Node : Node_Id; - Decl_Node : Node_Id; - Scan_State : Saved_Scan_State; - Num_Idents : Nat; - Ident : Nat; - Ident_Sloc : Source_Ptr; + CompDef_Node : Node_Id; + Decl_Node : Node_Id; + Scan_State : Saved_Scan_State; + Not_Null_Present : Boolean := False; + Num_Idents : Nat; + Ident : Nat; + Ident_Sloc : Source_Ptr; Idents : array (Int range 1 .. 4096) of Entity_Id; -- This array holds the list of defining identifiers. The upper bound @@ -2844,7 +2938,7 @@ package body Ch3 is if not Extensions_Allowed then Error_Msg_SP ("Generalized use of anonymous access types " & - "is an Ada0X extension"); + "is an Ada 0Y extension"); Error_Msg_SP ("\unit must be compiled with -gnatX switch"); end if; @@ -2870,7 +2964,13 @@ package body Ch3 is raise Error_Resync; end if; - Set_Subtype_Indication (CompDef_Node, P_Subtype_Indication); + if Extensions_Allowed then -- Ada 0Y (AI-231) + Not_Null_Present := P_Null_Exclusion; + Set_Null_Exclusion_Present (CompDef_Node, Not_Null_Present); + end if; + + Set_Subtype_Indication (CompDef_Node, + P_Subtype_Indication (Not_Null_Present)); end if; Set_Component_Definition (Decl_Node, CompDef_Node); @@ -3134,9 +3234,10 @@ package body Ch3 is -- Error recovery: can raise Error_Resync function P_Access_Type_Definition return Node_Id is - Prot_Flag : Boolean; - Access_Loc : Source_Ptr; - Type_Def_Node : Node_Id; + Prot_Flag : Boolean; + Access_Loc : Source_Ptr; + Not_Null_Present : Boolean := False; + Type_Def_Node : Node_Id; procedure Check_Junk_Subprogram_Name; -- Used in access to subprogram definition cases to check for an @@ -3163,6 +3264,10 @@ package body Ch3 is -- Start of processing for P_Access_Type_Definition begin + if Extensions_Allowed then -- Ada 0Y (AI-231) + Not_Null_Present := P_Null_Exclusion; + end if; + Access_Loc := Token_Ptr; Scan; -- past ACCESS @@ -3187,6 +3292,7 @@ package body Ch3 is end if; Type_Def_Node := New_Node (N_Access_Procedure_Definition, Access_Loc); + Set_Null_Exclusion_Present (Type_Def_Node, Not_Null_Present); Scan; -- past PROCEDURE Check_Junk_Subprogram_Name; Set_Parameter_Specifications (Type_Def_Node, P_Parameter_Profile); @@ -3198,6 +3304,7 @@ package body Ch3 is end if; Type_Def_Node := New_Node (N_Access_Function_Definition, Access_Loc); + Set_Null_Exclusion_Present (Type_Def_Node, Not_Null_Present); Scan; -- past FUNCTION Check_Junk_Subprogram_Name; Set_Parameter_Specifications (Type_Def_Node, P_Parameter_Profile); @@ -3209,6 +3316,7 @@ package body Ch3 is else Type_Def_Node := New_Node (N_Access_To_Object_Definition, Access_Loc); + Set_Null_Exclusion_Present (Type_Def_Node, Not_Null_Present); if Token = Tok_All or else Token = Tok_Constant then if Ada_83 then @@ -3225,7 +3333,8 @@ package body Ch3 is Scan; -- past ALL or CONSTANT end if; - Set_Subtype_Indication (Type_Def_Node, P_Subtype_Indication); + Set_Subtype_Indication (Type_Def_Node, + P_Subtype_Indication (Not_Null_Present)); end if; return Type_Def_Node; @@ -3265,6 +3374,20 @@ package body Ch3 is begin Def_Node := New_Node (N_Access_Definition, Token_Ptr); Scan; -- past ACCESS + + -- Ada 0Y (AI-231): ACCESS [general_access_modifier] subtype_mark + + if Extensions_Allowed then + if Token = Tok_All then + Scan; -- past ALL + Set_All_Present (Def_Node); + + elsif Token = Tok_Constant then + Scan; -- past CONSTANT + Set_Constant_Present (Def_Node); + end if; + end if; + Set_Subtype_Mark (Def_Node, P_Subtype_Mark); No_Constraint; return Def_Node; diff --git a/gcc/ada/par-ch4.adb b/gcc/ada/par-ch4.adb index 0334034..b56c8b0 100644 --- a/gcc/ada/par-ch4.adb +++ b/gcc/ada/par-ch4.adb @@ -2328,19 +2328,35 @@ package body Ch4 is -- Error recovery: can raise Error_Resync function P_Allocator return Node_Id is - Alloc_Node : Node_Id; - Type_Node : Node_Id; + Alloc_Node : Node_Id; + Type_Node : Node_Id; + Null_Exclusion_Present : Boolean; begin Alloc_Node := New_Node (N_Allocator, Token_Ptr); T_New; + + -- Scan Null_Exclusion if present (Ada 0Y (AI-231)) + + if Extensions_Allowed then + Null_Exclusion_Present := P_Null_Exclusion; + Set_Null_Exclusion_Present (Alloc_Node, Null_Exclusion_Present); + + -- If Ada 95, null exclusion never present + + else + Null_Exclusion_Present := False; + end if; + Type_Node := P_Subtype_Mark_Resync; if Token = Tok_Apostrophe then Scan; -- past apostrophe Set_Expression (Alloc_Node, P_Qualified_Expression (Type_Node)); else - Set_Expression (Alloc_Node, P_Subtype_Indication (Type_Node)); + Set_Expression + (Alloc_Node, + P_Subtype_Indication (Type_Node, Null_Exclusion_Present)); end if; return Alloc_Node; diff --git a/gcc/ada/par-ch6.adb b/gcc/ada/par-ch6.adb index cc0e898..964a9a6 100644 --- a/gcc/ada/par-ch6.adb +++ b/gcc/ada/par-ch6.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2003 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2004 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- -- @@ -857,6 +857,7 @@ package body Ch6 is Num_Idents : Nat; Ident : Nat; Ident_Sloc : Source_Ptr; + Not_Null_Present : Boolean := False; Idents : array (Int range 1 .. 4096) of Entity_Id; -- This array holds the list of defining identifiers. The upper bound @@ -865,7 +866,6 @@ package body Ch6 is begin Specification_List := New_List; - Specification_Loop : loop begin if Token = Tok_Pragma then @@ -953,8 +953,12 @@ package body Ch6 is Specification_Node := New_Node (N_Parameter_Specification, Ident_Sloc); Set_Defining_Identifier (Specification_Node, Idents (Ident)); + Not_Null_Present := P_Null_Exclusion; -- Ada 0Y (AI-231) if Token = Tok_Access then + Set_Null_Exclusion_Present + (Specification_Node, Not_Null_Present); + if Ada_83 then Error_Msg_SC ("(Ada 83) access parameters not allowed"); end if; @@ -963,7 +967,18 @@ package body Ch6 is (Specification_Node, P_Access_Definition); else - P_Mode (Specification_Node); + if Token = Tok_In or else Token = Tok_Out then + if Not_Null_Present then + Error_Msg_SC + ("ACCESS must be placed after the parameter mode"); + end if; + + P_Mode (Specification_Node); + Not_Null_Present := P_Null_Exclusion; -- Ada 0Y (AI-231) + end if; + + Set_Null_Exclusion_Present + (Specification_Node, Not_Null_Present); if Token = Tok_Procedure or else diff --git a/gcc/ada/par-load.adb b/gcc/ada/par-load.adb index 3910a10..30dd830 100644 --- a/gcc/ada/par-load.adb +++ b/gcc/ada/par-load.adb @@ -150,7 +150,9 @@ begin -- Next step, make sure that the unit name matches the file name -- and issue a warning message if not. We only output this for the -- main unit, since for other units it is more serious and is - -- caught in a separate test below. + -- caught in a separate test below. We also inhibit the message in + -- multiple unit per file mode, because in this case the relation + -- between file name and unit name is broken. File_Name := Get_File_Name @@ -158,6 +160,7 @@ begin Subunit => Nkind (Unit (Cunit (Cur_Unum))) = N_Subunit); if Cur_Unum = Main_Unit + and then Multiple_Unit_Index = 0 and then File_Name /= Unit_File_Name (Cur_Unum) and then (File_Names_Case_Sensitive or not Same_File_Name_Except_For_Case @@ -338,7 +341,6 @@ begin if Unum /= No_Unit then Set_Library_Unit (Curunit, Cunit (Unum)); end if; - end if; -- Now we load with'ed units, with style/validity checks turned off @@ -352,7 +354,6 @@ begin Context_Node := First (Context_Items (Curunit)); while Present (Context_Node) loop - if Nkind (Context_Node) = N_With_Clause then With_Node := Context_Node; Spec_Name := Get_Unit_Name (With_Node); diff --git a/gcc/ada/par-prag.adb b/gcc/ada/par-prag.adb index fef50e0..23f280c 100644 --- a/gcc/ada/par-prag.adb +++ b/gcc/ada/par-prag.adb @@ -360,25 +360,27 @@ begin -- These two pragmas have the same syntax and semantics. -- There are five forms of these pragmas: - -- pragma Source_File_Name ( + -- pragma Source_File_Name[_Project] ( -- [UNIT_NAME =>] unit_NAME, - -- BODY_FILE_NAME => STRING_LITERAL); + -- BODY_FILE_NAME => STRING_LITERAL + -- [, [INDEX =>] INTEGER_LITERAL]); - -- pragma Source_File_Name ( + -- pragma Source_File_Name[_Project] ( -- [UNIT_NAME =>] unit_NAME, - -- SPEC_FILE_NAME => STRING_LITERAL); + -- SPEC_FILE_NAME => STRING_LITERAL + -- [, [INDEX =>] INTEGER_LITERAL]); - -- pragma Source_File_Name ( + -- pragma Source_File_Name[_Project] ( -- BODY_FILE_NAME => STRING_LITERAL -- [, DOT_REPLACEMENT => STRING_LITERAL] -- [, CASING => CASING_SPEC]); - -- pragma Source_File_Name ( + -- pragma Source_File_Name[_Project] ( -- SPEC_FILE_NAME => STRING_LITERAL -- [, DOT_REPLACEMENT => STRING_LITERAL] -- [, CASING => CASING_SPEC]); - -- pragma Source_File_Name ( + -- pragma Source_File_Name[_Project] ( -- SUBUNIT_FILE_NAME => STRING_LITERAL -- [, DOT_REPLACEMENT => STRING_LITERAL] -- [, CASING => CASING_SPEC]); @@ -410,6 +412,8 @@ begin Dot : String_Ptr; Cas : Casing_Type; Nast : Nat; + Expr : Node_Id; + Index : Nat; function Get_Fname (Arg : Node_Id) return Name_Id; -- Process file name from unit name form of pragma @@ -520,7 +524,6 @@ begin -- Source_File_Name_Project pragmas. begin - if Get_Pragma_Id (Pragma_Name) = Pragma_Source_File_Name then if Project_File_In_Use = In_Use then Error_Msg @@ -536,7 +539,6 @@ begin Error_Msg ("pragma Source_File_Name_Project should only be used " & "with a project file", Pragma_Sloc); - else Project_File_In_Use := In_Use; end if; @@ -569,7 +571,30 @@ begin return Error; end if; - Check_Arg_Count (2); + -- Process index argument if present + + if Arg_Count = 3 then + Expr := Expression (Arg3); + + if Nkind (Expr) /= N_Integer_Literal + or else not UI_Is_In_Int_Range (Intval (Expr)) + or else Intval (Expr) > 999 + or else Intval (Expr) <= 0 + then + Error_Msg + ("pragma% index must be integer literal" & + " in range 1 .. 999", Sloc (Expr)); + raise Error_Resync; + else + Index := UI_To_Int (Intval (Expr)); + end if; + + -- No index argument present + + else + Check_Arg_Count (2); + Index := 0; + end if; Check_Optional_Identifier (Arg1, Name_Unit_Name); Unam := Get_Unit_Name (Expr1); @@ -577,10 +602,12 @@ begin Check_Arg_Is_String_Literal (Arg2); if Chars (Arg2) = Name_Spec_File_Name then - Set_File_Name (Get_Spec_Name (Unam), Get_Fname (Arg2)); + Set_File_Name + (Get_Spec_Name (Unam), Get_Fname (Arg2), Index); elsif Chars (Arg2) = Name_Body_File_Name then - Set_File_Name (Unam, Get_Fname (Arg2)); + Set_File_Name + (Unam, Get_Fname (Arg2), Index); else Error_Msg_N @@ -635,7 +662,6 @@ begin -- Set defaults for Casing and Dot_Separator parameters Cas := All_Lower_Case; - Dot := new String'("."); -- Process second and third arguments if present @@ -703,7 +729,6 @@ begin ("file name required for first % pragma in file", Pragma_Sloc); raise Error_Resync; - else Fname := No_Name; end if; diff --git a/gcc/ada/par.adb b/gcc/ada/par.adb index 56629ef..1a1d975 100644 --- a/gcc/ada/par.adb +++ b/gcc/ada/par.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2003 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2004 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- -- @@ -46,6 +46,10 @@ with Style; with Table; with Tbuild; use Tbuild; +--------- +-- Par -- +--------- + function Par (Configuration_Pragmas : Boolean) return List_Id is Num_Library_Units : Natural := 0; @@ -515,6 +519,10 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is -- corresponding to their name, and return an ID value for the Node or -- List that is created. + ------------- + -- Par.Ch2 -- + ------------- + package Ch2 is function P_Pragma return Node_Id; @@ -535,6 +543,10 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is -- Parses optional pragmas and appends them to the List end Ch2; + ------------- + -- Par.Ch3 -- + ------------- + package Ch3 is Missing_Begin_Msg : Error_Msg_Id; -- This variable is set by a call to P_Declarative_Part. Normally it @@ -560,7 +572,6 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is function P_Range_Or_Subtype_Mark return Node_Id; function P_Range_Constraint return Node_Id; function P_Record_Definition return Node_Id; - function P_Subtype_Indication return Node_Id; function P_Subtype_Mark return Node_Id; function P_Subtype_Mark_Resync return Node_Id; function P_Unknown_Discriminant_Part_Opt return Boolean; @@ -576,6 +587,15 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is -- treatment of errors in case a reserved word is scanned. See the -- declaration of this type for details. + function P_Null_Exclusion return Boolean; + -- Ada 0Y (AI-231): Parse the null-excluding part. True indicates + -- that the null-excluding part was present. + + function P_Subtype_Indication + (Not_Null_Present : Boolean := False) return Node_Id; + -- Ada 0Y (AI-231): The flag Not_Null_Present indicates that the + -- null-excluding part has been scanned out and it was present. + function Init_Expr_Opt (P : Boolean := False) return Node_Id; -- If an initialization expression is present (:= expression), then -- it is scanned out and returned, otherwise Empty is returned if no @@ -590,17 +610,24 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is -- Token is known to be a declaration token (in Token_Class_Declk) -- on entry, so there definition is a declaration to be scanned. - function P_Subtype_Indication (Subtype_Mark : Node_Id) return Node_Id; + function P_Subtype_Indication + (Subtype_Mark : Node_Id; + Not_Null_Present : Boolean := False) return Node_Id; -- This version of P_Subtype_Indication is called when the caller has -- already scanned out the subtype mark which is passed as a parameter. + -- Ada 0Y (AI-231): The flag Not_Null_Present indicates that the + -- null-excluding part has been scanned out and it was present. function P_Subtype_Mark_Attribute (Type_Node : Node_Id) return Node_Id; -- Parse a subtype mark attribute. The caller has already parsed the -- subtype mark, which is passed in as the argument, and has checked -- that the current token is apostrophe. - end Ch3; + ------------- + -- Par.Ch4 -- + ------------- + package Ch4 is function P_Aggregate return Node_Id; function P_Expression return Node_Id; @@ -618,11 +645,13 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is return Node_Id; -- This routine scans out a qualified expression when the caller has -- already scanned out the name and apostrophe of the construct. - end Ch4; - package Ch5 is + ------------- + -- Par.Ch5 -- + ------------- + package Ch5 is function P_Statement_Name (Name_Node : Node_Id) return Node_Id; -- Given a node representing a name (which is a call), converts it -- to the syntactically corresponding procedure call statement. @@ -634,9 +663,12 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is procedure Parse_Decls_Begin_End (Parent : Node_Id); -- Parses declarations and handled statement sequence, setting -- fields of Parent node appropriately. - end Ch5; + ------------- + -- Par.Ch6 -- + ------------- + package Ch6 is function P_Designator return Node_Id; function P_Defining_Program_Unit_Name return Node_Id; @@ -654,9 +686,12 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is -- PROCEDURE or FUNCTION. The parameter indicates which possible -- possible kinds of construct (body, spec, instantiation etc.) -- are permissible in the current context. - end Ch6; + ------------- + -- Par.Ch7 -- + ------------- + package Ch7 is function P_Package (Pf_Flags : Pf_Rec) return Node_Id; -- Scans out any construct starting with the keyword PACKAGE. The @@ -664,10 +699,18 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is -- instantiation etc.) are permissible in the current context. end Ch7; + ------------- + -- Par.Ch8 -- + ------------- + package Ch8 is function P_Use_Clause return Node_Id; end Ch8; + ------------- + -- Par.Ch9 -- + ------------- + package Ch9 is function P_Abort_Statement return Node_Id; function P_Abortable_Part return Node_Id; @@ -681,6 +724,10 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is function P_Terminate_Alternative return Node_Id; end Ch9; + -------------- + -- Par.Ch10 -- + -------------- + package Ch10 is function P_Compilation_Unit return Node_Id; -- Note: this function scans a single compilation unit, and @@ -692,8 +739,16 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is -- for end of file and there may be more compilation units to -- scan. The caller can uniquely detect this situation by the -- fact that Token is not set to Tok_EOF on return. + -- + -- The Ignore parameter is normally set False. It is set True + -- in multiple unit per file mode if we are skipping past a unit + -- that we are not interested in. end Ch10; + -------------- + -- Par.Ch11 -- + -------------- + package Ch11 is function P_Handled_Sequence_Of_Statements return Node_Id; function P_Raise_Statement return Node_Id; @@ -702,14 +757,21 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is -- Parses the partial construct EXCEPTION followed by a list of -- exception handlers which appears in a number of productions, -- and returns the list of exception handlers. - end Ch11; + -------------- + -- Par.Ch12 -- + -------------- + package Ch12 is function P_Generic return Node_Id; function P_Generic_Actual_Part_Opt return List_Id; end Ch12; + -------------- + -- Par.Ch13 -- + -------------- + package Ch13 is function P_Representation_Clause return Node_Id; @@ -730,14 +792,13 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is -- At clause is parsed by P_At_Clause (13.1) -- Mod clause is parsed by P_Mod_Clause (13.5.1) - ------------------ - -- End Handling -- - ------------------ + -------------- + -- Par.Endh -- + -------------- -- Routines for handling end lines, including scope recovery package Endh is - function Check_End return Boolean; -- Called when an end sequence is required. In the absence of an error -- situation, Token contains Tok_End on entry, but in a missing end @@ -765,12 +826,11 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is -- only be used in cases where the only appropriate terminator is end. -- If Parent is non-empty, then if a correct END line is encountered, -- the End_Label field of Parent is set appropriately. - end Endh; - ------------------------------------ - -- Resynchronization After Errors -- - ------------------------------------ + -------------- + -- Par.Sync -- + -------------- -- These procedures are used to resynchronize after errors. Following an -- error which is not immediately locally recoverable, the exception @@ -783,7 +843,6 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is -- Multiple_Errors_Per_Line is set in Options. package Sync is - procedure Resync_Choice; -- Used if an error occurs scanning a choice. The scan pointer is -- advanced to the next vertical bar, arrow, or semicolon, whichever @@ -828,12 +887,11 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is procedure Resync_Cunit; -- Synchronize to next token which could be the start of a compilation -- unit, or to the end of file token. - end Sync; - ------------------------- - -- Token Scan Routines -- - ------------------------- + -------------- + -- Par.Tchk -- + -------------- -- Routines to check for expected tokens @@ -900,15 +958,13 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is procedure TF_Semicolon; procedure TF_Then; procedure TF_Use; - end Tchk; - ---------------------- - -- Utility Routines -- - ---------------------- + -------------- + -- Par.Util -- + -------------- package Util is - function Bad_Spelling_Of (T : Token_Type) return Boolean; -- This function is called in an error situation. It checks if the -- current token is an identifier whose name is a plausible bad @@ -1035,12 +1091,13 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is function Token_Is_At_End_Of_Line return Boolean; -- Determines if the current token is the last token on the line - end Util; - --------------------------------------- - -- Specialized Syntax Check Routines -- - --------------------------------------- + -------------- + -- Par.Prag -- + -------------- + + -- The processing for pragmas is split off from chapter 2 function Prag (Pragma_Node : Node_Id; Semi : Source_Ptr) return Node_Id; -- This function is passed a tree for a pragma that has been scanned out. @@ -1059,9 +1116,9 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is -- the scanning of the semicolon so that it will be scanned using the -- settings from the Style_Checks pragma preceding it. - ------------------------- - -- Subsidiary Routines -- - ------------------------- + -------------- + -- Par.Labl -- + -------------- procedure Labl; -- This procedure creates implicit label declarations for all label that @@ -1071,6 +1128,10 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is -- label is declared (e.g. a sequence of statements is not yet attached -- to its containing scope at the point a label in the sequence is found) + -------------- + -- Par.Load -- + -------------- + procedure Load; -- This procedure loads all subsidiary units that are required by this -- unit, including with'ed units, specs for bodies, and parents for child @@ -1125,14 +1186,10 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is procedure Labl is separate; procedure Load is separate; - --------- - -- Par -- - --------- - --- This function is the parse routine called at the outer level. It parses --- the current compilation unit and adds implicit label declarations. +-- Start of processing for Par begin + -- Deal with configuration pragmas case first if Configuration_Pragmas then @@ -1194,13 +1251,12 @@ begin -- that language defined units cannot be recompiled). -- However, an exception is s-rpc, and its children. We test this - -- by looking at the character after the minus, the rule is that - -- System.RPC and its children are the only children in System - -- whose second level name can start with the letter r. + -- by looking at the characters after the minus. The rule is that + -- only s-rpc and its children have names starting s-rp. Get_Name_String (File_Name (Current_Source_File)); - if (Name_Len < 3 or else Name_Buffer (1 .. 3) /= "s-r") + if (Name_Len < 5 or else Name_Buffer (1 .. 4) /= "s-rp") and then Current_Source_Unit = Main_Unit and then not GNAT_Mode and then Operating_Mode = Generate_Code @@ -1209,10 +1265,12 @@ begin end if; end if; - -- The following loop runs more than once only in syntax check mode - -- where we allow multiple compilation units in the same file. + -- The following loop runs more than once in syntax check mode + -- where we allow multiple compilation units in the same file + -- and in Multiple_Unit_Per_file mode where we skip units till + -- we get to the unit we want. - loop + for Ucount in Pos loop Set_Opt_Config_Switches (Is_Internal_File_Name (File_Name (Current_Source_File))); @@ -1226,13 +1284,51 @@ begin Last_Resync_Point := No_Location; Label_List := New_Elmt_List; - Discard_Node (P_Compilation_Unit); - -- If we are not at an end of file, then this means that we are - -- in syntax scan mode, and we can have another compilation unit, - -- otherwise we will exit from the loop. + -- If in multiple unit per file mode, skip past ignored unit + + if Ucount < Multiple_Unit_Index then + + -- We skip in syntax check only mode, since we don't want + -- to do anything more than skip past the unit and ignore it. + -- This causes processing like setting up a unit table entry + -- to be skipped. + + declare + Save_Operating_Mode : constant Operating_Mode_Type := + Operating_Mode; + + begin + Operating_Mode := Check_Syntax; + Discard_Node (P_Compilation_Unit); + Operating_Mode := Save_Operating_Mode; + + -- If we are at an end of file, and not yet at the right + -- unit, then we have a fatal error. The unit is missing. + + if Token = Tok_EOF then + Error_Msg_SC ("file has too few compilation units"); + raise Unrecoverable_Error; + end if; + end; + + -- Here if we are not skipping a file in multiple unit per file + -- mode. Parse the unit that we are interested in. Note that in + -- check syntax mode we are interested in all units in the file. + + else + Discard_Node (P_Compilation_Unit); + + -- All done if at end of file + + exit when Token = Tok_EOF; + + -- If we are not at an end of file, it means we are in syntax + -- check only mode, and we keep the loop going to parse all + -- remaining units in the file. + + end if; - exit when Token = Tok_EOF; Restore_Opt_Config_Switches (Save_Config_Switches); end loop; @@ -1260,5 +1356,4 @@ begin Set_Comes_From_Source_Default (False); return Empty_List; end if; - end Par; diff --git a/gcc/ada/prj-makr.adb b/gcc/ada/prj-makr.adb index bed3415..6fdb3bb 100644 --- a/gcc/ada/prj-makr.adb +++ b/gcc/ada/prj-makr.adb @@ -365,6 +365,7 @@ package body Prj.Makr is Output.Write_Str ("(process died) "); end if; end if; + else Line_Loop : while not End_Of_File (File) loop Get_Line (File, Text_Line, Text_Last); @@ -376,8 +377,7 @@ package body Prj.Makr is if J >= 13 and then Text_Line (1 .. 4) = "Unit" then - -- Add an entry in the SFN_Pragmas - -- table. + -- Add entry to SFN_Pragmas table Name_Len := J - 12; Name_Buffer (1 .. Name_Len) := @@ -431,25 +431,24 @@ package body Prj.Makr is if Project_File then - -- Add the corresponding attribute in - -- the Naming package of the naming - -- project. + -- Add the corresponding attribute in the + -- Naming package of the naming project. declare - Decl_Item : constant Project_Node_Id - := Default_Project_Node - (Of_Kind => - N_Declarative_Item); + Decl_Item : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => + N_Declarative_Item); - Attribute : constant Project_Node_Id - := Default_Project_Node - (Of_Kind => - N_Attribute_Declaration); + Attribute : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => + N_Attribute_Declaration); - Expression : constant Project_Node_Id - := Default_Project_Node - (Of_Kind => N_Expression, - And_Expr_Kind => Single); + Expression : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => N_Expression, + And_Expr_Kind => Single); Term : constant Project_Node_Id := Default_Project_Node @@ -458,10 +457,8 @@ package body Prj.Makr is Value : constant Project_Node_Id := Default_Project_Node - (Of_Kind => - N_Literal_String, - And_Expr_Kind => - Single); + (Of_Kind => N_Literal_String, + And_Expr_Kind => Single); begin Set_Next_Declarative_Item @@ -503,8 +500,7 @@ package body Prj.Makr is (Value, To => File_Name_Id); end; - -- Add source file name to source list - -- file. + -- Add source file name to source list file Last := Last + 1; Str (Last) := ASCII.LF; @@ -527,8 +523,7 @@ package body Prj.Makr is -- File name matches none of the regular expressions else - -- If the file is not excluded, look if this is a foreign - -- source. + -- If file is not excluded, see if this is foreign source if Matched /= Excluded then for Index in Foreign_Expressions'Range loop diff --git a/gcc/ada/prj-part.adb b/gcc/ada/prj-part.adb index b381bac..c03e191 100644 --- a/gcc/ada/prj-part.adb +++ b/gcc/ada/prj-part.adb @@ -180,8 +180,7 @@ package body Prj.Part is function Project_Path_Name_Of (Project_File_Name : String; - Directory : String) - return String; + Directory : String) return String; -- Returns the path name of a project file. Returns an empty string -- if project file cannot be found. @@ -863,10 +862,12 @@ package body Prj.Part is Extends_All := False; declare - Normed_Path : constant String := Normalize_Pathname - (Path_Name, Resolve_Links => False, Case_Sensitive => True); + Normed_Path : constant String := Normalize_Pathname + (Path_Name, Resolve_Links => False, + Case_Sensitive => True); Canonical_Path : constant String := Normalize_Pathname - (Normed_Path, Resolve_Links => True, Case_Sensitive => False); + (Normed_Path, Resolve_Links => True, + Case_Sensitive => False); begin Name_Len := Normed_Path'Length; @@ -1585,8 +1586,7 @@ package body Prj.Part is function Project_Path_Name_Of (Project_File_Name : String; - Directory : String) - return String + Directory : String) return String is Result : String_Access; diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index 897e9b5..4d8a67d 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2003 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2004 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,6 +78,9 @@ package body Sem_Aggr is -- statement of variant part will usually be small and probably in near -- sorted order. + procedure Check_Can_Never_Be_Null (N : Node_Id; Expr : Node_Id); + -- Ada 0Y (AI-231): Check bad usage of the null-exclusion issue + ------------------------------------------------------ -- Subprograms used for RECORD AGGREGATE Processing -- ------------------------------------------------------ @@ -465,6 +468,17 @@ package body Sem_Aggr is Analyze_And_Resolve (Exp, Check_Typ); Check_Unset_Reference (Exp); end if; + + -- Ada 0Y (AI-231): Generate conversion to the null-excluding + -- type to force the corresponding run-time check + + elsif Is_Access_Type (Check_Typ) + and then Can_Never_Be_Null (Check_Typ) + and then not Can_Never_Be_Null (Exp_Typ) + then + Rewrite (Exp, Convert_To (Check_Typ, Relocate_Node (Exp))); + Analyze_And_Resolve (Exp, Check_Typ); + Check_Unset_Reference (Exp); end if; end Aggregate_Constraint_Checks; @@ -867,7 +881,7 @@ package body Sem_Aggr is Error_Msg_N ("aggregate type cannot have limited component", N); Explain_Limited_Type (Typ, N); - -- Ada0Y (AI-287): Limited aggregates allowed + -- Ada 0Y (AI-287): Limited aggregates allowed elsif Is_Limited_Type (Typ) and not Extensions_Allowed @@ -965,6 +979,13 @@ package body Sem_Aggr is Set_Etype (N, Aggr_Typ); -- may be overridden later on. + -- Ada 0Y (AI-231): Propagate the null_exclusion attribute to the + -- components of the array aggregate + + if Extensions_Allowed then + Set_Can_Never_Be_Null (Aggr_Typ, Can_Never_Be_Null (Typ)); + end if; + if Is_Constrained (Typ) and then (Pkind = N_Assignment_Statement or else Pkind = N_Parameter_Association or else @@ -1644,12 +1665,16 @@ package body Sem_Aggr is end if; end loop; - -- Ada0Y (AI-287): In case of default initialized component + -- Ada 0Y (AI-231) + + Check_Can_Never_Be_Null (N, Expression (Assoc)); + + -- Ada 0Y (AI-287): In case of default initialized component -- we delay the resolution to the expansion phase if Box_Present (Assoc) then - -- Ada0Y (AI-287): In case of default initialization of a + -- Ada 0Y (AI-287): In case of default initialization of a -- component the expander will generate calls to the -- corresponding initialization subprogram. @@ -1776,6 +1801,8 @@ package body Sem_Aggr is while Present (Expr) loop Nb_Elements := Nb_Elements + 1; + Check_Can_Never_Be_Null (N, Expr); -- Ada 0Y (AI-231) + if not Resolve_Aggr_Expr (Expr, Single_Elmt => True) then return Failure; end if; @@ -1786,12 +1813,14 @@ package body Sem_Aggr is if Others_Present then Assoc := Last (Component_Associations (N)); - -- Ada0Y (AI-287): In case of default initialized component + Check_Can_Never_Be_Null (N, Expression (Assoc)); -- Ada 0Y (AI-231) + + -- Ada 0Y (AI-287): In case of default initialized component -- we delay the resolution to the expansion phase. if Box_Present (Assoc) then - -- Ada0Y (AI-287): In case of default initialization of a + -- Ada 0Y (AI-287): In case of default initialization of a -- component the expander will generate calls to the -- corresponding initialization subprogram. @@ -1958,7 +1987,7 @@ package body Sem_Aggr is elsif Is_Limited_Type (Typ) then - -- Ada0Y (AI-287): Limited aggregates are allowed + -- Ada 0Y (AI-287): Limited aggregates are allowed if Extensions_Allowed then null; @@ -2069,7 +2098,7 @@ package body Sem_Aggr is Mbox_Present : Boolean := False; Others_Mbox : Boolean := False; - -- Ada0Y (AI-287): Variables used in case of default initialization to + -- Ada 0Y (AI-287): Variables used in case of default initialization to -- provide a functionality similar to Others_Etype. Mbox_Present -- indicates that the component takes its default initialization; -- Others_Mbox indicates that at least one component takes its default @@ -2258,7 +2287,7 @@ package body Sem_Aggr is and then Comes_From_Source (Compon) and then not In_Instance_Body then - -- Ada0Y (AI-287): Limited aggregates are allowed + -- Ada 0Y (AI-287): Limited aggregates are allowed if Extensions_Allowed and then Present (Expression (Assoc)) @@ -2298,7 +2327,7 @@ package body Sem_Aggr is -- indispensable otherwise, because each one must be -- expanded individually to preserve side-effects. - -- Ada0Y (AI-287): In case of default initialization of + -- Ada 0Y (AI-287): In case of default initialization of -- components, we duplicate the corresponding default -- expression (from the record type declaration). @@ -2336,10 +2365,24 @@ package body Sem_Aggr is elsif Chars (Compon) = Chars (Selector_Name) then if No (Expr) then + -- Ada 0Y (AI-231) + + if Extensions_Allowed + and then Present (Expression (Assoc)) + and then Nkind (Expression (Assoc)) = N_Null + and then Can_Never_Be_Null (Compon) + then + Error_Msg_N + ("(Ada 0Y) NULL not allowed in null-excluding " & + "components", Expression (Assoc)); + end if; + -- We need to duplicate the expression when several -- components are grouped together with a "|" choice. -- For instance "filed1 | filed2 => Expr" + -- Ada 0Y (AI-287) + if Box_Present (Assoc) then Mbox_Present := True; @@ -2643,6 +2686,18 @@ package body Sem_Aggr is while Present (Discrim) and then Present (Positional_Expr) loop if Discr_Present (Discrim) then Resolve_Aggr_Expr (Positional_Expr, Discrim); + + -- Ada 0Y (AI-231) + + if Extensions_Allowed + and then Nkind (Positional_Expr) = N_Null + and then Can_Never_Be_Null (Discrim) + then + Error_Msg_N + ("(Ada 0Y) NULL not allowed in null-excluding components", + Positional_Expr); + end if; + Next (Positional_Expr); end if; @@ -2874,6 +2929,16 @@ package body Sem_Aggr is Component := Node (Component_Elmt); Resolve_Aggr_Expr (Positional_Expr, Component); + -- Ada 0Y (AI-231) + if Extensions_Allowed + and then Nkind (Positional_Expr) = N_Null + and then Can_Never_Be_Null (Component) + then + Error_Msg_N + ("(Ada 0Y) NULL not allowed in null-excluding components", + Positional_Expr); + end if; + if Present (Get_Value (Component, Component_Associations (N))) then Error_Msg_NE ("more than one value supplied for Component &", N, Component); @@ -2896,7 +2961,7 @@ package body Sem_Aggr is if Mbox_Present and then Is_Limited_Type (Etype (Component)) then - -- Ada0Y (AI-287): In case of default initialization of a limited + -- Ada 0Y (AI-287): In case of default initialization of a limited -- component we pass the limited component to the expander. The -- expander will generate calls to the corresponding initiali- -- zation subprograms. @@ -2937,7 +3002,7 @@ package body Sem_Aggr is if Nkind (Selectr) = N_Others_Choice then - -- Ada0Y (AI-287): others choice may have expression or mbox + -- Ada 0Y (AI-287): others choice may have expression or mbox if No (Others_Etype) and then not Others_Mbox @@ -3015,6 +3080,21 @@ package body Sem_Aggr is end Step_8; end Resolve_Record_Aggregate; + ----------------------------- + -- Check_Can_Never_Be_Null -- + ----------------------------- + + procedure Check_Can_Never_Be_Null (N : Node_Id; Expr : Node_Id) is + begin + if Extensions_Allowed + and then Nkind (Expr) = N_Null + and then Can_Never_Be_Null (Etype (N)) + then + Error_Msg_N + ("(Ada 0Y) NULL not allowed in null-excluding components", Expr); + end if; + end Check_Can_Never_Be_Null; + --------------------- -- Sort_Case_Table -- --------------------- diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 94e02cb..69930b8 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -6670,7 +6670,10 @@ package body Sem_Ch12 is Decl_Node := Make_Subprogram_Renaming_Declaration (Loc, Specification => New_Spec, - Name => Nam); + Name => Nam); + + -- If we do not have an actual and the formal specified <> then + -- set to get proper default. if No (Actual) and then Box_Present (Formal) then Set_From_Default (Decl_Node); diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 11483c3..b17f870 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -686,6 +686,18 @@ package body Sem_Ch3 is Init_Size_Align (Anon_Type); Set_Depends_On_Private (Anon_Type, Has_Private_Component (Anon_Type)); + -- Ada 0Y (AI-231): Ada 0Y semantics for anonymous access differs from + -- Ada 95 semantics. In Ada 0Y, anonymous access must specify if the + -- null value is allowed; in Ada 95 the null value is not allowed + + if Extensions_Allowed + and then Null_Exclusion_Present (N) + then + Set_Can_Never_Be_Null (Anon_Type); + else + Set_Can_Never_Be_Null (Anon_Type); + end if; + -- The anonymous access type is as public as the discriminated type or -- subprogram that defines it. It is imported (for back-end purposes) -- if the designated type is. @@ -697,6 +709,10 @@ package body Sem_Ch3 is Set_From_With_Type (Anon_Type, From_With_Type (Desig_Type)); + -- Ada 0Y (AI-231): Propagate the access-constant attribute + + Set_Is_Access_Constant (Anon_Type, Constant_Present (N)); + -- The context is either a subprogram declaration or an access -- discriminant, in a private or a full type declaration. In -- the case of a subprogram, If the designated type is incomplete, @@ -800,6 +816,10 @@ package body Sem_Ch3 is Init_Size_Align (T_Name); Set_Directly_Designated_Type (T_Name, Desig_Type); + -- Ada 0Y (AI-231): Propagate the null-excluding attribute + + Set_Can_Never_Be_Null (T_Name, Null_Exclusion_Present (T_Def)); + Check_Restriction (No_Access_Subprograms, T_Def); end Access_Subprogram_Declaration; @@ -893,6 +913,12 @@ package body Sem_Ch3 is Set_Has_Task (T, False); Set_Has_Controlled_Component (T, False); + + -- Ada 0Y (AI-231): Propagate the null-excluding and access-constant + -- attributes + + Set_Can_Never_Be_Null (T, Null_Exclusion_Present (Def)); + Set_Is_Access_Constant (T, Constant_Present (Def)); end Access_Type_Declaration; ----------------------------------- @@ -980,6 +1006,17 @@ package body Sem_Ch3 is Set_Etype (Id, T); Set_Is_Aliased (Id, Aliased_Present (Component_Definition (N))); + -- Ada 0Y (AI-231): Propagate the null-excluding attribute and carry + -- out some static checks + + if Extensions_Allowed + and then (Null_Exclusion_Present (Component_Definition (N)) + or else Can_Never_Be_Null (T)) + then + Set_Can_Never_Be_Null (Id); + Null_Exclusion_Static_Checks (N); + end if; + -- If this component is private (or depends on a private type), -- flag the record type to indicate that some operations are not -- available. @@ -1528,6 +1565,17 @@ package body Sem_Ch3 is end if; end if; + -- Ada 0Y (AI-231): Propagate the null-excluding attribute and carry + -- out some static checks + + if Extensions_Allowed + and then (Null_Exclusion_Present (N) + or else Can_Never_Be_Null (T)) + then + Set_Can_Never_Be_Null (Id); + Null_Exclusion_Static_Checks (N); + end if; + Set_Is_Pure (Id, Is_Pure (Current_Scope)); -- If deferred constant, make sure context is appropriate. We detect @@ -2359,6 +2407,23 @@ package body Sem_Ch3 is Set_Directly_Designated_Type (Id, Designated_Type (T)); + -- Ada 0Y (AI-231): Propagate the null-excluding attribute and + -- carry out some static checks + + if Null_Exclusion_Present (N) + or else Can_Never_Be_Null (T) + then + Set_Can_Never_Be_Null (Id); + + if Null_Exclusion_Present (N) + and then Can_Never_Be_Null (T) + then + Error_Msg_N + ("(Ada 0Y) null exclusion not allowed if parent " + & "is already non-null", Subtype_Indication (N)); + end if; + end if; + -- A Pure library_item must not contain the declaration of a -- named access type, except within a subprogram, generic -- subprogram, task unit, or protected unit (RM 10.2.1(16)). @@ -2942,6 +3007,24 @@ package body Sem_Ch3 is Set_Has_Aliased_Components (Etype (T)); end if; + -- Ada 0Y (AI-231): Propagate the null-excluding attribute to the array + -- to ensure that objects of this type are initialized + + if Extensions_Allowed + and then (Null_Exclusion_Present (Component_Definition (Def)) + or else Can_Never_Be_Null (Element_Type)) + then + Set_Can_Never_Be_Null (T); + + if Null_Exclusion_Present (Component_Definition (Def)) + and then Can_Never_Be_Null (Element_Type) + then + Error_Msg_N + ("(Ada 0Y) already a null-excluding type", + Subtype_Indication (Component_Definition (Def))); + end if; + end if; + Priv := Private_Component (Element_Type); if Present (Priv) then @@ -3062,6 +3145,14 @@ package body Sem_Ch3 is Has_Private_Component (Derived_Type)); Conditional_Delay (Derived_Type, Subt); + -- Ada 0Y (AI-231). Set the null-exclusion attribute + + if Null_Exclusion_Present (Type_Definition (N)) + or else Can_Never_Be_Null (Parent_Type) + then + Set_Can_Never_Be_Null (Derived_Type); + end if; + -- Note: we do not copy the Storage_Size_Variable, since -- we always go to the root type for this information. @@ -5682,10 +5773,10 @@ package body Sem_Ch3 is end loop; -- Build an element list consisting of the expressions given in the - -- discriminant constraint and apply the appropriate range - -- checks. The list is constructed after resolving any named - -- discriminant associations and therefore the expressions appear in - -- the textual order of the discriminants. + -- discriminant constraint and apply the appropriate checks. The list + -- is constructed after resolving any named discriminant associations + -- and therefore the expressions appear in the textual order of the + -- discriminants. Discr := First_Discriminant (T); for J in Discr_Expr'Range loop @@ -5723,6 +5814,9 @@ package body Sem_Ch3 is then null; + elsif Is_Access_Type (Etype (Discr)) then + Apply_Constraint_Check (Discr_Expr (J), Etype (Discr)); + else Apply_Range_Check (Discr_Expr (J), Etype (Discr)); end if; @@ -9180,6 +9274,15 @@ package body Sem_Ch3 is elsif Is_Unchecked_Union (Parent_Type) then Error_Msg_N ("cannot derive from Unchecked_Union type", N); + + -- Ada 0Y (AI-231) + + elsif Is_Access_Type (Parent_Type) + and then Null_Exclusion_Present (Type_Definition (N)) + and then Can_Never_Be_Null (Parent_Type) + then + Error_Msg_N ("(Ada 0Y) null exclusion not allowed if parent is " + & "already non-null", Type_Definition (N)); end if; -- Only composite types other than array types are allowed to have @@ -11425,6 +11528,17 @@ package body Sem_Ch3 is Default_Not_Present := True; end if; + -- Ada 0Y (AI-231): Set the null-excluding attribute and carry out + -- some static checks + + if Extensions_Allowed + and then (Null_Exclusion_Present (Discr) + or else Can_Never_Be_Null (Discr_Type)) + then + Set_Can_Never_Be_Null (Defining_Identifier (Discr)); + Null_Exclusion_Static_Checks (Discr); + end if; + Next (Discr); end loop; @@ -12189,6 +12303,18 @@ package body Sem_Ch3 is Find_Type (S); Check_Incomplete (S); + + -- Ada 0Y (AI-231) + + if Extensions_Allowed + and then Present (Parent (S)) + and then Null_Exclusion_Present (Parent (S)) + and then Nkind (Parent (S)) /= N_Access_To_Object_Definition + and then not Is_Access_Type (Entity (S)) + then + Error_Msg_N + ("(Ada 0Y) null-exclusion part requires an access type", S); + end if; return Entity (S); -- Case of constraint present, so that we have an N_Subtype_Indication diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 0f561d9..06e296a 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -25,6 +25,7 @@ ------------------------------------------------------------------------------ with Atree; use Atree; +with Checks; use Checks; with Debug; use Debug; with Einfo; use Einfo; with Errout; use Errout; @@ -437,6 +438,13 @@ package body Sem_Ch4 is Set_Directly_Designated_Type (Acc_Type, Type_Id); Check_Fully_Declared (Type_Id, N); + -- Ada 0Y (AI-231) + + if Can_Never_Be_Null (Type_Id) then + Error_Msg_N ("(Ada 0Y) qualified expression required", + Expression (N)); + end if; + -- Check restriction against dynamically allocated protected -- objects. Note that when limited aggregates are supported, -- a similar test should be applied to an allocator with a @@ -480,6 +488,15 @@ package body Sem_Ch4 is Check_Restriction (No_Local_Allocators, N); end if; + -- Ada 0Y (AI-231): Static checks + + if Extensions_Allowed + and then (Null_Exclusion_Present (N) + or else Can_Never_Be_Null (Etype (N))) + then + Null_Exclusion_Static_Checks (N); + end if; + if Serious_Errors_Detected > Sav_Errs then Set_Error_Posted (N); Set_Etype (N, Any_Type); diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index d37b951..42db689 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2003 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2004 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- -- @@ -397,6 +397,20 @@ package body Sem_Ch5 is Propagate_Tag (Lhs, Rhs); end if; + -- Ada 0Y (AI-231) + + if Extensions_Allowed + and then Nkind (Rhs) = N_Null + and then Is_Access_Type (T1) + and then not Assignment_OK (Lhs) + and then ((Is_Entity_Name (Lhs) + and then Can_Never_Be_Null (Entity (Lhs))) + or else Can_Never_Be_Null (Etype (Lhs))) + then + Error_Msg_N + ("(Ada 0Y) NULL not allowed in null-excluding objects", Lhs); + end if; + if Is_Scalar_Type (T1) then Apply_Scalar_Range_Check (Rhs, Etype (Lhs)); diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 1382485..bd2a07f 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -970,8 +970,15 @@ package body Sem_Ch6 is Make_Subprogram_Declaration (Loc, Specification => New_Spec); Insert_Before (N, Decl); - Analyze (Decl); Spec_Id := Defining_Unit_Name (New_Spec); + + -- Indicate that the entity comes from source, to ensure that + -- cross-reference information is properly generated. + -- The body itself is rewritten during expansion, and the + -- body entity will not appear in calls to the operation. + + Set_Comes_From_Source (Spec_Id, True); + Analyze (Decl); Set_Has_Completion (Spec_Id); Set_Convention (Spec_Id, Convention_Protected); end; @@ -1724,6 +1731,8 @@ package body Sem_Ch6 is -- Functions that return unconstrained composite types will require -- secondary stack handling, and cannot currently be inlined. + -- Ditto for functions that return controlled types, where controlled + -- actions interfere in complex ways with inlining. elsif Ekind (Subp) = E_Function and then not Is_Scalar_Type (Etype (Subp)) @@ -1733,6 +1742,13 @@ package body Sem_Ch6 is Cannot_Inline ("cannot inline & (unconstrained return type)?", N, Subp); return; + + elsif Ekind (Subp) = E_Function + and then Controlled_Type (Etype (Subp)) + then + Cannot_Inline + ("cannot inline & (controlled return type)?", N, Subp); + return; end if; if Present (Declarations (N)) @@ -4845,7 +4861,7 @@ package body Sem_Ch6 is and then Ekind (Root_Type (Formal_Type)) = E_Incomplete_Type) then - -- Ada0Y (AI-50217): Incomplete tagged types that are made + -- Ada 0Y (AI-50217): Incomplete tagged types that are made -- visible through a limited with_clause are valid formal -- types. @@ -4934,6 +4950,18 @@ package body Sem_Ch6 is end if; end if; + + -- Ada 0Y (AI-231): Static checks + + Ptype := Parameter_Type (Param_Spec); + + if Extensions_Allowed + and then Nkind (Ptype) /= N_Access_Definition + and then (Null_Exclusion_Present (Parent (Formal)) + or else Can_Never_Be_Null (Entity (Ptype))) + then + Null_Exclusion_Static_Checks (Param_Spec); + end if; end if; Next (Param_Spec); @@ -4976,12 +5004,13 @@ package body Sem_Ch6 is ------------------------- procedure Set_Actual_Subtypes (N : Node_Id; Subp : Entity_Id) is - Loc : constant Source_Ptr := Sloc (N); - Decl : Node_Id; - Formal : Entity_Id; - T : Entity_Id; - First_Stmt : Node_Id := Empty; - AS_Needed : Boolean; + Loc : constant Source_Ptr := Sloc (N); + Decl : Node_Id; + Formal : Entity_Id; + T : Entity_Id; + First_Stmt : Node_Id := Empty; + AS_Needed : Boolean; + Null_Exclusion : Boolean := False; begin -- If this is an emtpy initialization procedure, no need to create @@ -5036,6 +5065,17 @@ package body Sem_Ch6 is then AS_Needed := True; + -- Ada 0Y (AI-231) + + elsif Extensions_Allowed + and then Is_Access_Type (T) + and then Null_Exclusion_Present (Parent (Formal)) + and then Nkind (Parameter_Type (Parent (Formal))) + /= N_Access_Definition + then + AS_Needed := True; + Null_Exclusion := True; + -- All other cases do not need an actual subtype else @@ -5047,7 +5087,39 @@ package body Sem_Ch6 is if AS_Needed then - if Nkind (N) = N_Accept_Statement then + -- Ada 0Y (AI-231): Generate actual null-excluding subtype + + if Extensions_Allowed + and then Null_Exclusion + then + declare + Loc : constant Source_Ptr := Sloc (Formal); + Anon : constant Entity_Id := + Make_Defining_Identifier (Loc, + New_Internal_Name ('S')); + Ptype : constant Node_Id + := Parameter_Type (Parent (Formal)); + begin + -- T == Etype (Formal) + Set_Is_Internal (Anon); + Decl := + Make_Subtype_Declaration (Loc, + Defining_Identifier => Anon, + Null_Exclusion_Present => True, + Subtype_Indication => + New_Occurrence_Of (Etype (Ptype), Loc)); + Mark_Rewrite_Insertion (Decl); + Prepend (Decl, Declarations (Parent (N))); + + Rewrite (Ptype, New_Occurrence_Of (Anon, Loc)); + Mark_Rewrite_Insertion (Ptype); + -- Set_Scope (Anon, Scope (Scope (Formal))); + + Set_Etype (Formal, Anon); + Set_Null_Exclusion_Present (Parent (Formal), False); + end; + + elsif Nkind (N) = N_Accept_Statement then -- If expansion is active, The formal is replaced by a local -- variable that renames the corresponding entry of the @@ -5081,6 +5153,16 @@ package body Sem_Ch6 is Analyze (Decl); + -- Ada 0Y (AI-231): Previous analysis leaves the entity of the + -- null-excluding subtype declaration associated with the internal + -- scope; because this declaration has been inserted before the + -- subprogram we associate it now with the enclosing scope. + + if Null_Exclusion then + Set_Scope (Defining_Identifier (Decl), + Scope (Scope (Formal))); + end if; + -- We need to freeze manually the generated type when it is -- inserted anywhere else than in a declarative part. @@ -5141,8 +5223,16 @@ package body Sem_Ch6 is -- set Can_Never_Be_Null, since there is no way to change the value. if Nkind (Parameter_Type (Spec)) = N_Access_Definition then - Set_Is_Known_Non_Null (Formal_Id); - Set_Can_Never_Be_Null (Formal_Id); + + -- Ada 0Y (AI-231): This behaviour has been modified in Ada 0Y. + -- It is only forced if the null_exclusion appears. + + if not Extensions_Allowed + or else Null_Exclusion_Present (Spec) + then + Set_Is_Known_Non_Null (Formal_Id); + Set_Can_Never_Be_Null (Formal_Id); + end if; end if; Set_Mechanism (Formal_Id, Default_Mechanism); diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 62eb47a..3c8ca3d 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -1692,7 +1692,6 @@ package body Sem_Prag is is Id : Node_Id; E1 : Entity_Id; - Comp_Unit : Unit_Number_Type; Cname : Name_Id; procedure Set_Convention_From_Pragma (E : Entity_Id); @@ -1908,12 +1907,9 @@ package body Sem_Prag is end if; -- For the subprogram case, set proper convention for all homonyms - -- in same compilation unit. - -- Is the test of compilation unit really necessary ??? - -- What about subprogram renamings here??? + -- in same scope. else - Comp_Unit := Get_Source_Unit (E); Set_Convention_From_Pragma (E); -- Treat a pragma Import as an implicit body, for GPS use. @@ -1931,7 +1927,10 @@ package body Sem_Prag is -- That is deliberate, we cannot chain the rep item on more -- than one Rep_Item chain, to be fixed later ??? - if Comp_Unit = Get_Source_Unit (E1) then + if Comes_From_Source (E1) + and then Nkind (Original_Node (Parent (E1))) /= + N_Full_Type_Declaration + then Set_Convention_From_Pragma (E1); if Prag_Id = Pragma_Import then @@ -8561,9 +8560,39 @@ package body Sem_Prag is -- Source_File_Name -- ---------------------- + -- There are five forms for this pragma: + + -- pragma Source_File_Name ( + -- [UNIT_NAME =>] unit_NAME, + -- BODY_FILE_NAME => STRING_LITERAL + -- [, [INDEX =>] INTEGER_LITERAL]); + -- pragma Source_File_Name ( - -- [UNIT_NAME =>] unit_NAME, - -- [BODY_FILE_NAME | SPEC_FILE_NAME] => STRING_LITERAL); + -- [UNIT_NAME =>] unit_NAME, + -- SPEC_FILE_NAME => STRING_LITERAL + -- [, [INDEX =>] INTEGER_LITERAL]); + + -- pragma Source_File_Name ( + -- BODY_FILE_NAME => STRING_LITERAL + -- [, DOT_REPLACEMENT => STRING_LITERAL] + -- [, CASING => CASING_SPEC]); + + -- pragma Source_File_Name ( + -- SPEC_FILE_NAME => STRING_LITERAL + -- [, DOT_REPLACEMENT => STRING_LITERAL] + -- [, CASING => CASING_SPEC]); + + -- pragma Source_File_Name ( + -- SUBUNIT_FILE_NAME => STRING_LITERAL + -- [, DOT_REPLACEMENT => STRING_LITERAL] + -- [, CASING => CASING_SPEC]); + + -- CASING_SPEC ::= Uppercase | Lowercase | Mixedcase + + -- Pragma Source_File_Name_Project (SFNP) is equivalent to pragma + -- Source_File_Name (SFN), however their usage is exclusive: + -- SFN can only be used when no project file is used, while + -- SFNP can only be used when a project file is used. -- No processing here. Processing was completed during parsing, -- since we need to have file names set as early as possible. @@ -8580,9 +8609,7 @@ package body Sem_Prag is -- Source_File_Name_Project -- ------------------------------ - -- pragma Source_File_Name_Project ( - -- [UNIT_NAME =>] unit_NAME, - -- [BODY_FILE_NAME | SPEC_FILE_NAME] => STRING_LITERAL); + -- See Source_File_Name for syntax -- No processing here. Processing was completed during parsing, -- since we need to have file names set as early as possible. @@ -8597,6 +8624,7 @@ package body Sem_Prag is -- Check that a pragma Source_File_Name_Project is used only -- in a configuration pragmas file. + -- Pragmas Source_File_Name_Project should only be generated -- by the Project Manager in configuration pragmas files. diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 07d8a31..c05b81b 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -902,7 +902,8 @@ package body Sem_Res is Act1 : Node_Id := First_Actual (N); Act2 : Node_Id := Next_Actual (Act1); Error : Boolean := False; - Is_Binary : constant Boolean := Present (Act2); + Func : constant Entity_Id := Entity (Name (N)); + Is_Binary : constant Boolean := Present (Act2); Op_Node : Node_Id; Opnd_Type : Entity_Id; Orig_Type : Entity_Id := Empty; @@ -1197,6 +1198,20 @@ package body Sem_Res is Set_Etype (Op_Node, Etype (N)); end if; + -- If this is a call to a function that renames a predefined equality, + -- the renaming declaration provides a type that must be used to + -- resolve the operands. This must be done now because resolution of + -- the equality node will not resolve any remaining ambiguity, and it + -- assumes that the first operand is not overloaded. + + if (Op_Name = Name_Op_Eq or else Op_Name = Name_Op_Ne) + and then Ekind (Func) = E_Function + and then Is_Overloaded (Act1) + then + Resolve (Act1, Base_Type (Etype (First_Formal (Func)))); + Resolve (Act2, Base_Type (Etype (First_Formal (Func)))); + end if; + Set_Entity (Op_Node, Op_Id); Generate_Reference (Op_Id, N, ' '); Rewrite (N, Op_Node); @@ -2682,6 +2697,19 @@ package body Sem_Res is else Apply_Range_Check (A, F_Typ); end if; + + -- Ada 0Y (AI-231) + + if Extensions_Allowed + and then Is_Access_Type (F_Typ) + and then (Can_Never_Be_Null (F) + or else Can_Never_Be_Null (F_Typ)) + then + if Nkind (A) = N_Null then + Error_Msg_NE ("(Ada 0Y) not allowed for null-exclusion " & + "formal", A, F_Typ); + end if; + end if; end if; if Ekind (F) = E_Out_Parameter @@ -5140,7 +5168,10 @@ package body Sem_Res is -- anonymous null access values via a debug switch to allow -- for easier transition. - if not Debug_Flag_J + -- Ada 0Y (AI-231): Remove restriction + + if not Extensions_Allowed + and then not Debug_Flag_J and then Ekind (Typ) = E_Anonymous_Access_Type and then Comes_From_Source (N) then diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 4f6e277..36f165f 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -3331,12 +3331,12 @@ package body Sem_Util is then return Is_Dependent_Component_Of_Mutable_Object (Prefix (Object)); - elsif Nkind (Object) = N_Type_Conversion then - -- A type conversion that Is_Variable is a view conversion: - -- go back to the denoted object. - return Is_Dependent_Component_Of_Mutable_Object - (Expression (Object)); + -- A type conversion that Is_Variable is a view conversion: + -- go back to the denoted object. + elsif Nkind (Object) = N_Type_Conversion then + return + Is_Dependent_Component_Of_Mutable_Object (Expression (Object)); end if; end if; diff --git a/gcc/ada/sfn_scan.adb b/gcc/ada/sfn_scan.adb index 4c2a6dc..0ac71ca 100644 --- a/gcc/ada/sfn_scan.adb +++ b/gcc/ada/sfn_scan.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2000-2002 Free Software Foundation, Inc. -- +-- Copyright (C) 2000-2004 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- -- @@ -63,6 +63,11 @@ package body SFN_Scan is -- Local Procedures -- ---------------------- + function Acquire_Integer return Natural; + -- This function skips white space, and then scans and returns + -- an unsigned integer. Raises Error if no integer is present + -- or if the integer is greater than 999. + function Acquire_String (B : Natural; E : Natural) return String; -- This function takes a string scanned out by Scan_String, strips -- the enclosing quote characters and any internal doubled quote @@ -128,6 +133,33 @@ package body SFN_Scan is -- Skips P past any white space characters (end of line -- characters, spaces, comments, horizontal tab characters). + --------------------- + -- Acquire_Integer -- + --------------------- + + function Acquire_Integer return Natural is + N : Natural := 0; + + begin + Skip_WS; + + if S (P) not in '0' .. '9' then + Error ("missing index parameter"); + end if; + + while S (P) in '0' .. '9' loop + N := N * 10 + Character'Pos (S (P)) - Character'Pos ('0'); + + if N > 999 then + Error ("index value greater than 999"); + end if; + + P := P + 1; + end loop; + + return N; + end Acquire_Integer; + -------------------- -- Acquire_String -- -------------------- @@ -310,6 +342,10 @@ package body SFN_Scan is procedure Add_Nat (N : Natural); -- Add chars of integer to error msg buffer + ------------- + -- Add_Nat -- + ------------- + procedure Add_Nat (N : Natural) is begin if N > 9 then @@ -415,7 +451,10 @@ package body SFN_Scan is -- Source_File_Name pragma case - if Check_Token ("source_file_name") then + if Check_Token ("source_file_name") + or else + Check_Token ("source_file_name_project") + then Require_Token ("("); Typ := Check_File_Type; @@ -443,11 +482,24 @@ package body SFN_Scan is declare F : constant String := Acquire_String (B, E); + X : Natural; begin + -- Scan Index parameter if present + + if Check_Token (",") then + if Check_Token ("index") then + Require_Token ("=>"); + end if; + + X := Acquire_Integer; + else + X := 0; + end if; + Require_Token (")"); Require_Token (";"); - SFN_Ptr.all (Typ, U, F); + SFN_Ptr.all (Typ, U, F, X); end; end; diff --git a/gcc/ada/sfn_scan.ads b/gcc/ada/sfn_scan.ads index 93e13bd..0b18bad 100644 --- a/gcc/ada/sfn_scan.ads +++ b/gcc/ada/sfn_scan.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2000-2001 Free Software Foundation, Inc. -- +-- Copyright (C) 2000-2004 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- -- @@ -46,12 +46,17 @@ package SFN_Scan is -- of these procedures: type Set_File_Name_Ptr is access - procedure (Typ : Character; U : String; F : String); + procedure + (Typ : Character; + U : String; + F : String; + Index : Natural); -- The procedure with this profile is called when a Source_File_Name -- pragma of the form having a unit name parameter. Typ is 'b' for -- a body file name, and 's' for a spec file name. U is a string that -- contains the unit name, exactly as it appeared in the source file, - -- and F is the file taken from the second parameter. + -- and F is the file taken from the second parameter. Index is taken + -- from the third parameter, or is set to zero if no third parameter. type Set_File_Name_Pattern_Ptr is access procedure (Pat : String; Typ : Character; Dot : String; Cas : Character); diff --git a/gcc/ada/sinfo.adb b/gcc/ada/sinfo.adb index 03d5b13..e19321a 100644 --- a/gcc/ada/sinfo.adb +++ b/gcc/ada/sinfo.adb @@ -196,6 +196,7 @@ package body Sinfo is (N : Node_Id) return Boolean is begin pragma Assert (False + or else NT (N).Nkind = N_Access_Definition or else NT (N).Nkind = N_Access_To_Object_Definition); return Flag15 (N); end All_Present; @@ -457,6 +458,7 @@ package body Sinfo is (N : Node_Id) return Boolean is begin pragma Assert (False + or else NT (N).Nkind = N_Access_Definition or else NT (N).Nkind = N_Access_To_Object_Definition or else NT (N).Nkind = N_Object_Declaration); return Flag17 (N); @@ -1832,6 +1834,24 @@ package body Sinfo is return Flag13 (N); end Null_Present; + function Null_Exclusion_Present + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Access_Definition + or else NT (N).Nkind = N_Access_Function_Definition + or else NT (N).Nkind = N_Access_Procedure_Definition + or else NT (N).Nkind = N_Access_To_Object_Definition + or else NT (N).Nkind = N_Allocator + or else NT (N).Nkind = N_Component_Definition + or else NT (N).Nkind = N_Derived_Type_Definition + or else NT (N).Nkind = N_Discriminant_Specification + or else NT (N).Nkind = N_Object_Declaration + or else NT (N).Nkind = N_Parameter_Specification + or else NT (N).Nkind = N_Subtype_Declaration); + return Flag9 (N); + end Null_Exclusion_Present; + function Null_Record_Present (N : Node_Id) return Boolean is begin @@ -2662,6 +2682,7 @@ package body Sinfo is (N : Node_Id; Val : Boolean := True) is begin pragma Assert (False + or else NT (N).Nkind = N_Access_Definition or else NT (N).Nkind = N_Access_To_Object_Definition); Set_Flag15 (N, Val); end Set_All_Present; @@ -2923,6 +2944,7 @@ package body Sinfo is (N : Node_Id; Val : Boolean := True) is begin pragma Assert (False + or else NT (N).Nkind = N_Access_Definition or else NT (N).Nkind = N_Access_To_Object_Definition or else NT (N).Nkind = N_Object_Declaration); Set_Flag17 (N, Val); @@ -4288,6 +4310,24 @@ package body Sinfo is Set_Flag13 (N, Val); end Set_Null_Present; + procedure Set_Null_Exclusion_Present + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Access_Definition + or else NT (N).Nkind = N_Access_Function_Definition + or else NT (N).Nkind = N_Access_Procedure_Definition + or else NT (N).Nkind = N_Access_To_Object_Definition + or else NT (N).Nkind = N_Allocator + or else NT (N).Nkind = N_Component_Definition + or else NT (N).Nkind = N_Derived_Type_Definition + or else NT (N).Nkind = N_Discriminant_Specification + or else NT (N).Nkind = N_Object_Declaration + or else NT (N).Nkind = N_Parameter_Specification + or else NT (N).Nkind = N_Subtype_Declaration); + Set_Flag9 (N, Val); + end Set_Null_Exclusion_Present; + procedure Set_Null_Record_Present (N : Node_Id; Val : Boolean := True) is begin diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index 434ad71..c6ea9e8 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -1883,6 +1883,7 @@ package Sinfo is -- N_Subtype_Declaration -- Sloc points to SUBTYPE -- Defining_Identifier (Node1) + -- Null_Exclusion_Present (Flag9) (set to False if not present) -- Subtype_Indication (Node5) -- Generic_Parent_Type (Node4-Sem) (set for an actual derived type). -- Exception_Junk (Flag11-Sem) @@ -1989,6 +1990,7 @@ package Sinfo is -- Defining_Identifier (Node1) -- Aliased_Present (Flag4) set if ALIASED appears -- Constant_Present (Flag17) set if CONSTANT appears + -- Null_Exclusion_Present (Flag9) (set to False if not present) -- Object_Definition (Node4) subtype indication/array type definition -- Expression (Node3) (set to Empty if not present) -- Handler_List_Entry (Node2-Sem) @@ -2044,6 +2046,7 @@ package Sinfo is -- N_Derived_Type_Definition -- Sloc points to NEW -- Abstract_Present (Flag4) + -- Null_Exclusion_Present (Flag9) (set to False if not present) -- Subtype_Indication (Node5) -- Record_Extension_Part (Node3) (set to Empty if not present) @@ -2338,6 +2341,7 @@ package Sinfo is -- N_Component_Definition -- Sloc points to ALIASED, ACCESS or to first token of subtype mark -- Aliased_Present (Flag4) + -- Null_Exclusion_Present (Flag9) (set to False if not present) -- Subtype_Indication (Node5) (set to Empty if not present) -- Access_Definition (Node3) (set to Empty if not present) @@ -2410,6 +2414,7 @@ package Sinfo is -- N_Discriminant_Specification -- Sloc points to first identifier -- Defining_Identifier (Node1) + -- Null_Exclusion_Present (Flag9) (set to False if not present) -- Discriminant_Type (Node5) subtype mark or -- access parameter definition -- Expression (Node3) (set to Empty if no default expression) @@ -2641,6 +2646,7 @@ package Sinfo is -- N_Access_To_Object_Definition -- Sloc points to ACCESS -- All_Present (Flag15) + -- Null_Exclusion_Present (Flag9) (set to False if not present) -- Subtype_Indication (Node5) -- Constant_Present (Flag17) @@ -2668,12 +2674,14 @@ package Sinfo is -- N_Access_Function_Definition -- Sloc points to ACCESS + -- Null_Exclusion_Present (Flag9) (set to False if not present) -- Protected_Present (Flag15) -- Parameter_Specifications (List3) (set to No_List if no formal part) -- Subtype_Mark (Node4) result subtype -- N_Access_Procedure_Definition -- Sloc points to ACCESS + -- Null_Exclusion_Present (Flag9) (set to False if not present) -- Protected_Present (Flag15) -- Parameter_Specifications (List3) (set to No_List if no formal part) @@ -2685,6 +2693,9 @@ package Sinfo is -- N_Access_Definition -- Sloc points to ACCESS + -- Null_Exclusion_Present (Flag9) (set to False if not present) + -- All_Present (Flag15) + -- Constant_Present (Flag17) -- Subtype_Mark (Node4) ----------------------------------------- @@ -3482,6 +3493,7 @@ package Sinfo is -- N_Allocator -- Sloc points to NEW -- Expression (Node3) subtype indication or qualified expression + -- Null_Exclusion_Present (Flag9) (set to False if not present) -- Storage_Pool (Node1-Sem) -- Procedure_To_Call (Node4-Sem) -- No_Initialization (Flag13-Sem) @@ -3996,6 +4008,7 @@ package Sinfo is -- Defining_Identifier (Node1) -- In_Present (Flag15) -- Out_Present (Flag17) + -- Null_Exclusion_Present (Flag9) (set to False if not present) -- Parameter_Type (Node2) subtype mark or access definition -- Expression (Node3) (set to Empty if no default expression present) -- Do_Accessibility_Check (Flag13-Sem) @@ -7444,6 +7457,9 @@ package Sinfo is function Null_Present (N : Node_Id) return Boolean; -- Flag13 + function Null_Exclusion_Present + (N : Node_Id) return Boolean; -- Flag9 + function Null_Record_Present (N : Node_Id) return Boolean; -- Flag17 @@ -8230,6 +8246,9 @@ package Sinfo is procedure Set_Null_Present (N : Node_Id; Val : Boolean := True); -- Flag13 + procedure Set_Null_Exclusion_Present + (N : Node_Id; Val : Boolean := True); -- Flag9 + procedure Set_Null_Record_Present (N : Node_Id; Val : Boolean := True); -- Flag17 @@ -8661,6 +8680,7 @@ package Sinfo is pragma Inline (No_Initialization); pragma Inline (No_Truncation); pragma Inline (Null_Present); + pragma Inline (Null_Exclusion_Present); pragma Inline (Null_Record_Present); pragma Inline (Object_Definition); pragma Inline (OK_For_Stream); @@ -8919,6 +8939,7 @@ package Sinfo is pragma Inline (Set_No_Initialization); pragma Inline (Set_No_Truncation); pragma Inline (Set_Null_Present); + pragma Inline (Set_Null_Exclusion_Present); pragma Inline (Set_Null_Record_Present); pragma Inline (Set_Object_Definition); pragma Inline (Set_OK_For_Stream); diff --git a/gcc/ada/sinput-l.adb b/gcc/ada/sinput-l.adb index 68da307..7a2917f 100644 --- a/gcc/ada/sinput-l.adb +++ b/gcc/ada/sinput-l.adb @@ -30,7 +30,7 @@ with Debug; use Debug; with Einfo; use Einfo; with Errout; use Errout; with Namet; use Namet; -with Opt; +with Opt; use Opt; with Osint; use Osint; with Output; use Output; with Prep; use Prep; @@ -78,9 +78,8 @@ package body Sinput.L is -- Used to initialize the preprocessor. function Load_File - (N : File_Name_Type; - T : Osint.File_Type) - return Source_File_Index; + (N : File_Name_Type; + T : Osint.File_Type) return Source_File_Index; -- Load a source file, a configuration pragmas file or a definition file -- Coding also allows preprocessing file, but not a library file ??? @@ -265,8 +264,7 @@ package body Sinput.L is ---------------------- function Load_Config_File - (N : File_Name_Type) - return Source_File_Index + (N : File_Name_Type) return Source_File_Index is begin return Load_File (N, Osint.Config); @@ -277,8 +275,7 @@ package body Sinput.L is -------------------------- function Load_Definition_File - (N : File_Name_Type) - return Source_File_Index + (N : File_Name_Type) return Source_File_Index is begin return Load_File (N, Osint.Definition); @@ -289,9 +286,8 @@ package body Sinput.L is --------------- function Load_File - (N : File_Name_Type; - T : Osint.File_Type) - return Source_File_Index + (N : File_Name_Type; + T : Osint.File_Type) return Source_File_Index is Src : Source_Buffer_Ptr; X : Source_File_Index; @@ -301,11 +297,21 @@ package body Sinput.L is Preprocessing_Needed : Boolean := False; begin - for J in 1 .. Source_File.Last loop - if Source_File.Table (J).File_Name = N then - return J; - end if; - end loop; + -- If already there, don't need to reload file. An exception occurs + -- in multiple unit per file mode. It would be nice in this case to + -- share the same source file for each unit, but this leads to many + -- difficulties with assumptions (e.g. in the body of lib), that a + -- unit can be found by locating its source file index. Since we do + -- not expect much use of this mode, it's no big deal to waste a bit + -- of space and time by reading and storing the source multiple times. + + if Multiple_Unit_Index = 0 then + for J in 1 .. Source_File.Last loop + if Source_File.Table (J).File_Name = N then + return J; + end if; + end loop; + end if; -- Here we must build a new entry in the file table @@ -584,8 +590,7 @@ package body Sinput.L is ---------------------------------- function Load_Preprocessing_Data_File - (N : File_Name_Type) - return Source_File_Index + (N : File_Name_Type) return Source_File_Index is begin return Load_File (N, Osint.Preprocessing_Data); @@ -596,8 +601,7 @@ package body Sinput.L is ---------------------- function Load_Source_File - (N : File_Name_Type) - return Source_File_Index + (N : File_Name_Type) return Source_File_Index is begin return Load_File (N, Osint.Source); diff --git a/gcc/ada/sinput-l.ads b/gcc/ada/sinput-l.ads index a7f5e00..3d71afd 100644 --- a/gcc/ada/sinput-l.ads +++ b/gcc/ada/sinput-l.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2002, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2004, 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- -- @@ -54,14 +54,14 @@ package Sinput.L is -- The file is never preprocessed. function Load_Definition_File - (N : File_Name_Type) - return Source_File_Index; - -- Needs comments ??? + (N : File_Name_Type) return Source_File_Index; + -- Loads preprocessing definition file. Similar to Load_Source_File + -- except that this file is not itself preprocessed. function Load_Preprocessing_Data_File - (N : File_Name_Type) - return Source_File_Index; - -- Similar to Load_Source_File, except that the file is never preprocessed. + (N : File_Name_Type) return Source_File_Index; + -- Loads preprocessing data file. Similar to Load_Source_File except + -- that this file is not itself preprocessed. procedure Complete_Source_File_Entry; -- Called on completing the parsing of a source file. This call completes diff --git a/gcc/ada/sprint.adb b/gcc/ada/sprint.adb index 2b584bb..8c93670 100644 --- a/gcc/ada/sprint.adb +++ b/gcc/ada/sprint.adb @@ -692,10 +692,24 @@ package body Sprint is Write_Char (';'); when N_Access_Definition => + + -- Ada 0Y (AI-231) + + if Null_Exclusion_Present (Node) then + Write_Str ("not null "); + end if; + Write_Str_With_Col_Check_Sloc ("access "); Sprint_Node (Subtype_Mark (Node)); when N_Access_Function_Definition => + + -- Ada 0Y (AI-231) + + if Null_Exclusion_Present (Node) then + Write_Str ("not null "); + end if; + Write_Str_With_Col_Check_Sloc ("access "); if Protected_Present (Node) then @@ -708,6 +722,12 @@ package body Sprint is Sprint_Node (Subtype_Mark (Node)); when N_Access_Procedure_Definition => + -- Ada 0Y (AI-231) + + if Null_Exclusion_Present (Node) then + Write_Str ("not null "); + end if; + Write_Str_With_Col_Check_Sloc ("access "); if Protected_Present (Node) then @@ -726,6 +746,12 @@ package body Sprint is Write_Str_With_Col_Check ("constant "); end if; + -- Ada 0Y (AI-231) + + if Null_Exclusion_Present (Node) then + Write_Str ("not null "); + end if; + Sprint_Node (Subtype_Indication (Node)); when N_Aggregate => @@ -774,6 +800,12 @@ package body Sprint is when N_Allocator => Write_Str_With_Col_Check_Sloc ("new "); + -- Ada 0Y (AI-231) + + if Null_Exclusion_Present (Node) then + Write_Str ("not null "); + end if; + Sprint_Node (Expression (Node)); if Present (Storage_Pool (Node)) then @@ -962,6 +994,12 @@ package body Sprint is Write_Str_With_Col_Check ("aliased "); end if; + -- Ada 0Y (AI-231) + + if Null_Exclusion_Present (Node) then + Write_Str (" not null "); + end if; + Sprint_Node (Subtype_Indication (Node)); else pragma Assert (False); @@ -1084,6 +1122,13 @@ package body Sprint is end if; Write_Str_With_Col_Check_Sloc ("new "); + + -- Ada 0Y (AI-231) + + if Null_Exclusion_Present (Node) then + Write_Str_With_Col_Check ("not null "); + end if; + Sprint_Node (Subtype_Indication (Node)); if Present (Record_Extension_Part (Node)) then @@ -1117,6 +1162,11 @@ package body Sprint is if Write_Identifiers (Node) then Write_Str (" : "); + + if Null_Exclusion_Present (Node) then + Write_Str ("not null "); + end if; + Sprint_Node (Discriminant_Type (Node)); if Present (Expression (Node)) then @@ -1688,6 +1738,12 @@ package body Sprint is Write_Str_With_Col_Check ("constant "); end if; + -- Ada 0Y (AI-231) + + if Null_Exclusion_Present (Node) then + Write_Str_With_Col_Check ("not null "); + end if; + Sprint_Node (Object_Definition (Node)); if Present (Expression (Node)) then @@ -1942,6 +1998,12 @@ package body Sprint is Write_Str_With_Col_Check ("out "); end if; + -- Ada 0Y (AI-231) + + if Null_Exclusion_Present (Node) then + Write_Str ("not null "); + end if; + Sprint_Node (Parameter_Type (Node)); if Present (Expression (Node)) then @@ -2326,6 +2388,13 @@ package body Sprint is Write_Indent_Str_Sloc ("subtype "); Write_Id (Defining_Identifier (Node)); Write_Str (" is "); + + -- Ada 0Y (AI-231) + + if Null_Exclusion_Present (Node) then + Write_Str ("not null "); + end if; + Sprint_Node (Subtype_Indication (Node)); Write_Char (';'); diff --git a/gcc/ada/switch-c.adb b/gcc/ada/switch-c.adb index 7ac45a0..fab690a 100644 --- a/gcc/ada/switch-c.adb +++ b/gcc/ada/switch-c.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2003 Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2004 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- -- @@ -220,6 +220,12 @@ package body Switch.C is ASIS_Mode := True; end if; + -- Processing for C switch + + when 'C' => + Ptr := Ptr + 1; + Scan_Pos (Switch_Chars, 999, Ptr, Multiple_Unit_Index); + -- Processing for d switch when 'd' => |