+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
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 \
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 \
-- 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.
-- 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;
-------------------------------
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
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;
end if;
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 --
----------------------------------
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 --
--------------------------
-- --
-- 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- --
-- 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
-- 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
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).
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,
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;
(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
-- 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).
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),
-- 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;
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;
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));
-- --
-- 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- --
--
-- 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
-- --
-- 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- --
-- 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.
-- 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;
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;
---------------------------
with Opt; use Opt;
with Osint; use Osint;
with Table;
+with Uname; use Uname;
with Widechar; use Widechar;
with GNAT.HTable;
--------------------------------------------------------
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
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 --
-------------------
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 --
----------------
-- 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;
Cas : Casing_Type)
is
L : constant Nat := SFN_Patterns.Last;
+
begin
SFN_Patterns.Increment_Last;
-- 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;
-- 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
-- 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;
-- --
-- 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- --
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 --
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
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);
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);
-- --
-- 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- --
-- 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;
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.
-- 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;
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),
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,
-- 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
end if;
if Present (Error_Node) then
-
if Is_Predefined_File_Name (Fname) then
Error_Msg_Name_1 := Uname_Actual;
Error_Msg
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
Ident_String => Empty,
Loading => True,
Main_Priority => Default_Main_Priority,
+ Munit_Index => 0,
Serial_Number => 0,
Source_Index => Src_Ind,
Unit_File_Name => Fname,
-- 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
Ident_String => Empty,
Loading => False,
Main_Priority => -1,
+ Munit_Index => 0,
Serial_Number => 0,
Version => 0,
Error_Location => No_Location);
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
Ident_String => Empty,
Loading => False,
Main_Priority => -1,
+ Munit_Index => 0,
Serial_Number => 0,
Version => 0,
Error_Location => No_Location);
-- 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;
---------------
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
-- --
-- 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- --
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;
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;
function Increment_Serial_Number return Nat is
TSN : Int renames Units.Table (Current_Sem_Unit).Serial_Number;
-
begin
TSN := TSN + 1;
return TSN;
-- 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
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;
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);
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;
-- --
------------------------------------------------------------------------------
--- 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.
Lock_Task.all;
if First_Call then
-
First_Call := False;
-- We first log deallocation call
-- 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
-- --
-- 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- --
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).
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 --
procedure Close_Debug_File is
Status : Boolean;
+
begin
Close (Output_FD, Status);
procedure Close_Output_Library_Info is
Status : Boolean;
+
begin
Close (Output_FD, Status);
procedure Close_Repinfo_File is
Status : Boolean;
+
begin
Close (Output_FD, Status);
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;
-- 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
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");
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".
-- 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;
------------------
-------------------
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;
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
-- 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
-- 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.
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;
-- 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
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, " &
when Error_Resync =>
Set_Fatal_Error (Current_Source_Unit);
return Error;
-
end P_Compilation_Unit;
--------------------------
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;
-- 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
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;
-- 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,
-- 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;
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);
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
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);
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
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
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
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
-- 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);
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
-- 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;
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
-- 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;
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);
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;
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
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
-- 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
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;
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);
-- 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
-- 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
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);
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);
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
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;
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;
-- 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;
-- --
-- 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- --
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
begin
Specification_List := New_List;
-
Specification_Loop : loop
begin
if Token = Tok_Pragma then
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;
(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
-- 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
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
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
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);
-- 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]);
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
-- 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
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;
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);
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
-- Set defaults for Casing and Dot_Separator parameters
Cas := All_Lower_Case;
-
Dot := new String'(".");
-- Process second and third arguments if present
("file name required for first % pragma in file",
Pragma_Sloc);
raise Error_Resync;
-
else
Fname := No_Name;
end if;
-- --
-- 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- --
with Table;
with Tbuild; use Tbuild;
+---------
+-- Par --
+---------
+
function Par (Configuration_Pragmas : Boolean) return List_Id is
Num_Library_Units : Natural := 0;
-- 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;
-- 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
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;
-- 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
-- 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;
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.
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;
-- 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
-- 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;
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
-- 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;
-- 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;
-- 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
-- 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
-- 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
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
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
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.
-- 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
-- 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
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
-- 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
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)));
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;
Set_Comes_From_Source_Default (False);
return Empty_List;
end if;
-
end Par;
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);
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) :=
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
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
(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;
-- 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
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.
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;
function Project_Path_Name_Of
(Project_File_Name : String;
- Directory : String)
- return String
+ Directory : String) return String
is
Result : String_Access;
-- --
-- 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- --
-- 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 --
------------------------------------------------------
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;
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
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
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.
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;
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.
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;
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
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))
-- 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).
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;
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;
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);
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.
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
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 --
---------------------
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);
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.
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,
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;
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;
-----------------------------------
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.
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
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)).
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
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.
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
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;
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
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;
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
------------------------------------------------------------------------------
with Atree; use Atree;
+with Checks; use Checks;
with Debug; use Debug;
with Einfo; use Einfo;
with Errout; use Errout;
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
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);
-- --
-- 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- --
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));
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;
-- 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))
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))
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.
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);
-------------------------
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
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
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
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.
-- 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);
is
Id : Node_Id;
E1 : Entity_Id;
- Comp_Unit : Unit_Number_Type;
Cname : Name_Id;
procedure Set_Convention_From_Pragma (E : Entity_Id);
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.
-- 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
-- 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.
-- 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.
-- 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.
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;
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);
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
-- 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
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;
-- --
-- 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- --
-- 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
-- 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 --
--------------------
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
-- 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;
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;
-- --
-- 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- --
-- 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);
(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;
(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);
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
(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;
(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);
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
-- 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)
-- 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)
-- 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)
-- 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)
-- 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)
-- 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)
-- 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)
-- 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)
-----------------------------------------
-- 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)
-- 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)
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
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
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);
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);
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;
-- 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 ???
----------------------
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);
--------------------------
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);
---------------
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;
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
----------------------------------
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);
----------------------
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);
-- --
-- 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- --
-- 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
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
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
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 =>
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
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);
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
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
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
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
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 (';');
-- --
-- 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- --
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' =>
projects / gcc.git / commitdiff