diff options
| author | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2004-03-29 12:03:27 +0000 |
|---|---|---|
| committer | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2004-03-29 12:03:27 +0000 |
| commit | fa7497e853a70dd5d253a1313d0dfa7ddbc02eec (patch) | |
| tree | b41024c63720bbb6fd3edef3c99d72097d058a4e /gcc/ada | |
| parent | 611a00932367c28e71b5682cb244fb548eeac5e7 (diff) | |
| download | gcc-fa7497e853a70dd5d253a1313d0dfa7ddbc02eec.tar.gz | |
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
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@80055 138bc75d-0d04-0410-961f-82ee72b054a4
Diffstat (limited to 'gcc/ada')
51 files changed, 1783 insertions, 399 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 1229cfa3907..26c8ef5099a 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 886cf7943bd..419fd0b4b1d 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 327ddb66509..b16fcc18c2f 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 d6ad2bde5a5..dcb4606775d 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 795d69e5ad1..a8180e4c971 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 e6e42315eb2..c8a28aab6f2 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 a08cd1f145c..08ec7d507b5 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 b8d8ed2d76f..469bae6caa4 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 0864da74696..f60980ac25f 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 8dc14b7b51f..62568f513a1 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 962b335747d..28977e734e4 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 9852688d686..00af708cae6 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 aad0e253d31..d829a206e24 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 b771772556a..fd3e92e9e07 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 380b617f780..151971cf6ef 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 45a2c5a0f3e..a544e55534e 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 212c465c733..b294a84305f 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 1cafffe9afd..bc6bfe54bf9 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 5e909307264..124ca39552d 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 5dae5819ab6..2a94f86ead9 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 39ffb82eafb..a36e52b88a7 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 2c78b75b2a7..77468fa319c 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 d925abf7f77..7914b1b3805 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 93cdb12a0e1..fcf4e13289d 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 ec86234b586..0e87e9a4948 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 475f0c35509..985d9e328cc 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 c5f24646bce..7940fe4c505 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 0334034b76d..b56c8b0b6c8 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 cc0e8981740..964a9a60aa7 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 3910a107351..30dd830a51b 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 fef50e03f81..23f280c4aba 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 56629ef436f..1a1d9750a96 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 bed3415e9e7..6fdb3bba0e3 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 b381bacab09..c03e191bf42 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 897e9b500af..4d8a67d9a17 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 94e02cb1504..69930b81a04 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 11483c3def7..b17f870ae12 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 0f561d9ce35..06e296a0aa4 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 d37b951aac6..42db6899373 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 138248507d8..bd2a07fcd10 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 62eb47a5c0a..3c8ca3df41b 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 07d8a3198cc..c05b81b304c 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 4f6e2779e2f..36f165f1e32 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 4c2a6dcdfc4..0ac71ca4d42 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 93e13bd8ce8..0b18bad2e15 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 03d5b13f924..e19321adeb1 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 434ad7172ae..c6ea9e86316 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 68da3074d25..7a2917fba1e 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 a7f5e00c9f0..3d71afd0dee 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 2b584bb2779..8c936705b47 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 7ac45a0f3df..fab690a2a2f 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' => |