+2013-01-29 Robert Dewar <dewar@adacore.com>
+
+ * par-ch6.adb (No_Constraint_Maybe_Expr_Func): New procedure.
+ * par-util.adb (No_Constraint): Undo special handling, moved
+ to par-ch6.adb.
+
+2013-01-29 Robert Dewar <dewar@adacore.com>
+
+ * aspects.ads: Aspect Warnings is implementation defined Add
+ some other missing entries to impl-defined list Mark Warnings
+ as GNAT pragma in main list.
+ * sem_ch8.adb: Process aspects for all cases of renaming
+ declarations.
+
+2013-01-29 Robert Dewar <dewar@adacore.com>
+
+ * sem_ch6.adb (Analyze_Function_Call): Set In_Assertion flag.
+ * sem_elab.adb (Check_Internal_Call_Continue): Do not issue
+ warnings about possible elaboration error if call is within
+ an assertion.
+ * sinfo.ads, sinfo.adb (In_Assertion): New flag in N_Function_Call node.
+
+2013-01-29 Robert Dewar <dewar@adacore.com>
+
+ * a-calend-vms.adb, g-eacodu-vms.adb, g-trasym-vms-alpha.adb,
+ * s-auxdec-vms-ia64.adb, s-mastop-vms.adb, s-osprim-vms.adb,
+ s-tasdeb-vms.adb: Replace pragma Interface by pragma Import.
+
+2013-01-29 Robert Dewar <dewar@adacore.com>
+
+ * opt.ads (Ignore_Style_Checks_Pragmas): New flag.
+ * par-prag.adb (Par, case Style_Checks): Recognize
+ Ignore_Style_Checks_Pragmas.
+ * sem_prag.adb (Analyze_Pragma, case Style_Checks): Recognize
+ Ignore_Style_Checks_Pragmas.
+ * switch-c.adb: Recognize -gnateY switch.
+ * usage.adb: Add documentation for "-gnateY".
+ * vms_data.ads: Add IGNORE_STYLE_CHECKS_PRAGMAS (-gnateY).
+
+2013-01-29 Vincent Celier <celier@adacore.com>
+
+ * clean.adb (Clean_Executables): Add Sid component when calling
+ Queue.Insert.
+ * make.adb: When inserting in the Queue, add the Source_Id
+ (Sid) when it is known (Start_Compile_If_Possible): When the
+ Source_Id is known (Sid), get the path name of the ALI file
+ (Full_Lib_File) from it, to avoid finding old ALI files in other
+ object directories.
+ * makeutl.ads (Source_Info): New Source_Id component Sid in
+ Format_Gnatmake variant.
+
+2013-01-29 Robert Dewar <dewar@adacore.com>
+
+ * gnat_ugn.texi: Document -gnateY.
+
+2013-01-29 Doug Rupp <rupp@adacore.com>
+
+ * s-osinte-vms.ads, s-taprop-vms.adb, system-vms_64.ads,
+ system-vms-ia64.ads: Replace pragma Interface by pragma Import.
+
2013-01-29 Robert Dewar <dewar@adacore.com>
* atree.ads, atree.adb (Node30): New function.
-- on various targets, a system independent model is incorporated into
-- Ada.Calendar. The idea behind the design is to encapsulate all target
-- dependent machinery in a single package, thus providing a uniform
- -- interface to all existing and any potential children.
+ -- pragma Import to all existing and any potential children.
-- package Ada.Calendar
-- procedure Split (5 parameters) -------+
Timbuf : out Unsigned_Word_Array;
Timadr : Time);
- pragma Interface (External, Numtim);
+ pragma Import (External, Numtim);
pragma Import_Valued_Procedure
(Numtim, "SYS$NUMTIM",
Input_Time : Unsigned_Word_Array;
Resultant_Time : out Time);
- pragma Interface (External, Cvt_Vectim);
+ pragma Import (External, Cvt_Vectim);
pragma Import_Valued_Procedure
(Cvt_Vectim, "LIB$CVT_VECTIM",
Aspect_Unsuppress,
Aspect_Value_Size, -- GNAT
Aspect_Variable_Indexing,
- Aspect_Warnings,
+ Aspect_Warnings, -- GNAT
Aspect_Write,
-- The following aspects correspond to library unit pragmas
Aspect_Favor_Top_Level => True,
Aspect_Global => True,
Aspect_Inline_Always => True,
+ Aspect_Invariant => True,
Aspect_Lock_Free => True,
Aspect_Object_Size => True,
Aspect_Persistent_BSS => True,
Aspect_Pure_12 => True,
Aspect_Pure_Function => True,
Aspect_Remote_Access_Type => True,
- Aspect_Shared => True,
Aspect_Scalar_Storage_Order => True,
+ Aspect_Shared => True,
Aspect_Simple_Storage_Pool => True,
Aspect_Simple_Storage_Pool_Type => True,
Aspect_Suppress_Debug_Info => True,
Aspect_Test_Case => True,
- Aspect_Universal_Data => True,
Aspect_Universal_Aliasing => True,
+ Aspect_Universal_Data => True,
Aspect_Unmodified => True,
Aspect_Unreferenced => True,
Aspect_Unreferenced_Objects => True,
Aspect_Value_Size => True,
+ Aspect_Warnings => True,
others => False);
-- The following array indicates aspects for which multiple occurrences of
File => Main_Lib_File,
Unit => No_Unit_Name,
Index => 0,
- Project => No_Project));
+ Project => No_Project,
+ Sid => No_Source));
end if;
while not Queue.Is_Empty loop
File => Withs.Table (K).Afile,
Unit => No_Unit_Name,
Index => 0,
- Project => No_Project));
+ Project => No_Project,
+ Sid => No_Source));
end if;
end loop;
end loop;
-- --
-- B o d y --
-- --
--- Copyright (C) 2003-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 2003-2012, 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- --
Addres : Address := Address_Zero;
Acmode : Access_Mode_Type := Access_Mode_Zero;
Prvhnd : Unsigned_Longword := 0);
- pragma Interface (External, Setexv);
+ pragma Import (External, Setexv);
pragma Import_Valued_Procedure (Setexv, "SYS$SETEXV",
(Cond_Value_Type, Unsigned_Longword, Address, Access_Mode_Type,
Unsigned_Longword),
(Value, Value, Value, Value, Value));
procedure Lib_Signal (I : Integer);
- pragma Interface (C, Lib_Signal);
+ pragma Import (C, Lib_Signal);
pragma Import_Procedure (Lib_Signal, "LIB$SIGNAL", Mechanism => (Value));
begin
Setexv (Status, 1, Address_Zero, 3);
-- --
-- B o d y --
-- --
--- Copyright (C) 1999-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2012, 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- --
User_Arg_Value : User_Arg_Type := 0);
-- Comment on above procedure required ???
- pragma Interface (External, Symbolize);
+ pragma Import (External, Symbolize);
pragma Import_Valued_Procedure
(Symbolize, "TBK$SYMBOLIZE",
@cindex @option{-gnateV} (@command{gcc})
Check validity of subprogram parameters.
+@item ^-gnateY^/IGNORE_SUPPRESS_SYLE_CHECK_PRAGMAS^
+@cindex @option{-gnateY} (@command{gcc})
+Ignore all STYLE_CHECKS pragmas. Full legality checks
+are still carried out, but the pragmas have no effect
+on what style checks are active. This allows all style
+checking options to be controlled from the command line.
+
@item -gnatE
@cindex @option{-gnatE} (@command{gcc})
Full dynamic elaboration checks.
File => Sfile,
Unit => No_Unit_Name,
Project => No_Project,
- Index => 0))
+ Index => 0,
+ Sid => No_Source))
then
if Is_In_Obsoleted (Sfile) then
Executable_Obsolete := True;
ALI : ALI_Id;
Source_Index : Int;
Sfile : File_Name_Type;
+ Sid : Prj.Source_Id;
Uname : Unit_Name_Type;
Unit_Name : Name_Id;
Uid : Prj.Unit_Index;
loop
Sfile := Withs.Table (K).Sfile;
Uname := Withs.Table (K).Uname;
+ Sid := No_Source;
-- If project files are used, find the proper source to
-- compile in case Sfile is the spec but there is a body.
then
Sfile := Uid.File_Names (Impl).File;
Source_Index := Uid.File_Names (Impl).Index;
+ Sid := Uid.File_Names (Impl);
elsif Uid.File_Names (Spec) /= null
and then not Uid.File_Names (Spec).Locally_Removed
then
Sfile := Uid.File_Names (Spec).File;
Source_Index := Uid.File_Names (Spec).Index;
+ Sid := Uid.File_Names (Spec);
end if;
end if;
end if;
File => Sfile,
Project => ALI_P.Project,
Unit => Withs.Table (K).Uname,
- Index => Source_Index));
+ Index => Source_Index,
+ Sid => Sid));
end if;
end if;
end loop;
is
In_Lib_Dir : Boolean;
Need_To_Compile : Boolean;
- Pid : Process_Id;
+ Pid : Process_Id := Invalid_Pid;
Process_Created : Boolean;
Source : Queue.Source_Info;
- Full_Source_File : File_Name_Type;
+ Full_Source_File : File_Name_Type := No_File;
Source_File_Attr : aliased File_Attributes;
-- The full name of the source file and its attributes (size, ...)
Lib_File : File_Name_Type;
- Full_Lib_File : File_Name_Type;
+ Full_Lib_File : File_Name_Type := No_File;
Lib_File_Attr : aliased File_Attributes;
Read_Only : Boolean := False;
ALI : ALI_Id;
then
Queue.Extract (Found, Source);
- Osint.Full_Source_Name
- (Source.File,
- Full_File => Full_Source_File,
- Attr => Source_File_Attr'Access);
+ -- If it is a source in a project, first look for the ALI file
+ -- in the object directory. When the project is extending another
+ -- the ALI file may not be found, but the source does not
+ -- necessarily need to be compiled, as it may already be up to
+ -- date in the project being extended. In this case, look for an
+ -- ALI file in all the object directories, as is done when
+ -- gnatmake is not invoked with a project file.
+
+ if Source.Sid /= No_Source then
+ Initialize_Source_Record (Source.Sid);
+ Full_Source_File :=
+ File_Name_Type (Source.Sid.Path.Display_Name);
+ Lib_File := Source.Sid.Dep_Name;
+ Full_Lib_File := File_Name_Type (Source.Sid.Dep_Path);
+ Lib_File_Attr := Unknown_Attributes;
+
+ if Full_Lib_File /= No_File then
+ declare
+ FLF : constant String :=
+ Get_Name_String (Full_Lib_File) & ASCII.NUL;
+ begin
+ if not Is_Regular_File
+ (FLF'Address, Lib_File_Attr'Access)
+ then
+ Full_Lib_File := No_File;
+ end if;
+ end;
+ end if;
+ end if;
- Lib_File := Osint.Lib_File_Name (Source.File, Source.Index);
+ if Full_Lib_File = No_File then
+ Osint.Full_Source_Name
+ (Source.File,
+ Full_File => Full_Source_File,
+ Attr => Source_File_Attr'Access);
- -- ??? This call could be avoided when using projects, since we
- -- know where the ALI file is supposed to be. That would avoid
- -- searches in the object directories, including in the runtime
- -- dir. However, that would require getting access to the
- -- Source_Id.
+ Lib_File := Osint.Lib_File_Name (Source.File, Source.Index);
- Osint.Full_Lib_File_Name
- (Lib_File,
- Lib_File => Full_Lib_File,
- Attr => Lib_File_Attr);
+ Osint.Full_Lib_File_Name
+ (Lib_File,
+ Lib_File => Full_Lib_File,
+ Attr => Lib_File_Attr);
+ end if;
-- If source has already been compiled, executable is obsolete
File => Main_Source,
Project => Main_Project,
Unit => No_Unit_Name,
- Index => Main_Index));
+ Index => Main_Index,
+ Sid => No_Source));
First_Compiled_File := No_File;
Most_Recent_Obj_File := No_File;
Put_In_Q : Boolean := Into_Q;
Unit : Unit_Index;
Sfile : File_Name_Type;
+ Sid : Prj.Source_Id;
Index : Int;
Project : Project_Id;
Unit := Units_Htable.Get_First (Project_Tree.Units_HT);
while Unit /= null loop
Sfile := No_File;
+ Sid := No_Source;
Index := 0;
Project := No_Project;
if Sinput.P.Source_File_Is_Subunit (Src_Ind) then
Sfile := No_File;
Index := 0;
+ Sid := No_Source;
else
Sfile := Unit.File_Names (Impl).Display_File;
Index := Unit.File_Names (Impl).Index;
+ Sid := Unit.File_Names (Impl);
end if;
end;
else
Sfile := Unit.File_Names (Impl).Display_File;
Index := Unit.File_Names (Impl).Index;
+ Sid := Unit.File_Names (Impl);
end if;
end if;
Sfile := Unit.File_Names (Spec).Display_File;
Index := Unit.File_Names (Spec).Index;
+ Sid := Unit.File_Names (Spec);
Project := Unit.File_Names (Spec).Project;
end if;
File => Sfile,
Project => Project,
Unit => No_Unit_Name,
- Index => Index));
+ Index => Index,
+ Sid => Sid));
end if;
if not Put_In_Q and then Sfile /= No_File then
record
case Format is
when Format_Gprbuild =>
- Tree : Project_Tree_Ref := null;
- Id : Source_Id := null;
+ Tree : Project_Tree_Ref := No_Project_Tree;
+ Id : Source_Id := No_Source;
when Format_Gnatmake =>
File : File_Name_Type := No_File;
Unit : Unit_Name_Type := No_Unit_Name;
Index : Int := 0;
Project : Project_Id := No_Project;
+ Sid : Source_Id := No_Source;
end case;
end record;
-- Information about files stored in the queue. The exact information
-- code from foreign compilers for checking or ASIS purposes. Can be
-- set True by use of -gnatI.
+ Ignore_Style_Checks_Pragmas : Boolean := False;
+ -- GNAT
+ -- Set True to ignore all Style_Checks pragmas. Can be set True by use
+ -- of -gnateY.
+
Implementation_Unit_Warnings : Boolean := True;
-- GNAT
-- Set True to active warnings for use of implementation internal units.
function P_Return_Object_Declaration return Node_Id;
procedure P_Return_Subtype_Indication (Decl_Node : Node_Id);
- -- Decl_Node is a N_Object_Declaration.
- -- Set the Null_Exclusion_Present and Object_Definition fields of
- -- Decl_Node.
+ -- Decl_Node is a N_Object_Declaration. Set the Null_Exclusion_Present and
+ -- Object_Definition fields of Decl_Node.
procedure Check_Junk_Semicolon_Before_Return;
-
-- Check for common error of junk semicolon before RETURN keyword of
- -- function specification. If present, skip over it with appropriate
- -- error message, leaving Scan_Ptr pointing to the RETURN after. This
- -- routine also deals with a possibly misspelled version of Return.
+ -- function specification. If present, skip over it with appropriate error
+ -- message, leaving Scan_Ptr pointing to the RETURN after. This routine
+ -- also deals with a possibly misspelled version of Return.
+
+ procedure No_Constraint_Maybe_Expr_Func;
+ -- Called after scanning return subtype to check for missing constraint,
+ -- taking into account the possibility of an occurrence of an expression
+ -- function where the IS has been forgotten.
----------------------------------------
-- Check_Junk_Semicolon_Before_Return --
end if;
end Check_Junk_Semicolon_Before_Return;
+ -----------------------------------
+ -- No_Constraint_Maybe_Expr_Func --
+ -----------------------------------
+
+ procedure No_Constraint_Maybe_Expr_Func is
+ begin
+ -- If we have a left paren at the start of the line, then assume this is
+ -- the case of an expression function with missing IS. We do not have to
+ -- diagnose the missing IS, that is done elsewhere. We do this game in
+ -- Ada 2012 mode where expression functions are legal.
+
+ if Token = Tok_Left_Paren
+ and Ada_Version >= Ada_2012
+ and Token_Is_At_Start_Of_Line
+ then
+ -- One exception if we have "(token .." then this is a constraint
+
+ declare
+ Scan_State : Saved_Scan_State;
+
+ begin
+ Save_Scan_State (Scan_State);
+ Scan; -- past left paren
+ Scan; -- past following token
+
+ -- If we have "(token .." then restore scan state and treat as
+ -- unexpected constraint.
+
+ if Token = Tok_Dot_Dot then
+ Restore_Scan_State (Scan_State);
+ No_Constraint;
+
+ -- Otherwise we treat this as an expression function
+
+ else
+ Restore_Scan_State (Scan_State);
+ end if;
+ end;
+
+ -- Otherwise use standard routine to check for no constraint present
+
+ else
+ No_Constraint;
+ end if;
+ end No_Constraint_Maybe_Expr_Func;
+
-----------------------------------------------------
-- 6.1 Subprogram (Also 6.3, 8.5.4, 10.1.3, 12.3) --
-----------------------------------------------------
else
Result_Node := P_Subtype_Mark;
- No_Constraint;
+ No_Constraint_Maybe_Expr_Func;
end if;
else
else
Result_Node := P_Subtype_Mark;
- No_Constraint;
+ No_Constraint_Maybe_Expr_Func;
end if;
Set_Null_Exclusion_Present (Specification_Node, Result_Not_Null);
end if;
if J = Slen then
- Set_Style_Check_Options (Options, OK, Ptr);
+ if not Ignore_Style_Checks_Pragmas then
+ Set_Style_Check_Options (Options, OK, Ptr);
+ end if;
+
exit;
else
OK := False;
elsif Chars (A) = Name_All_Checks then
- if GNAT_Mode then
- Stylesw.Set_GNAT_Style_Check_Options;
- else
- Stylesw.Set_Default_Style_Check_Options;
+ if not Ignore_Style_Checks_Pragmas then
+ if GNAT_Mode then
+ Stylesw.Set_GNAT_Style_Check_Options;
+ else
+ Stylesw.Set_Default_Style_Check_Options;
+ end if;
end if;
elsif Chars (A) = Name_On then
- Style_Check := True;
+ if not Ignore_Style_Checks_Pragmas then
+ Style_Check := True;
+ end if;
elsif Chars (A) = Name_Off then
- Style_Check := False;
+ if not Ignore_Style_Checks_Pragmas then
+ Style_Check := False;
+ end if;
else
OK := False;
procedure No_Constraint is
begin
- -- If next token is at start of line, don't object, it seems relatively
- -- unlikely that a constraint would be on its own starting a line.
-
- if Token_Is_At_Start_Of_Line then
- return;
- end if;
-
- -- Otherwise if we have a token that could start a constraint, object
+ -- If we have a token that could start a constraint on the same line
+ -- then cnsider this an illegal constraint. It seems unlikely it could
+ -- be anything else if it is on the same line.
if Token in Token_Class_Consk then
Error_Msg_SC ("constraint not allowed here");
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2012, 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- --
procedure SYS_PAL_INSQHIL
(STATUS : out Integer; Header : Address; ITEM : Address);
- pragma Interface (External, SYS_PAL_INSQHIL);
+ pragma Import (External, SYS_PAL_INSQHIL);
pragma Import_Valued_Procedure (SYS_PAL_INSQHIL, "SYS$PAL_INSQHIL",
(Integer, Address, Address),
(Value, Value, Value));
procedure SYS_PAL_REMQHIL
(Remret : out Remq; Header : Address);
- pragma Interface (External, SYS_PAL_REMQHIL);
+ pragma Import (External, SYS_PAL_REMQHIL);
pragma Import_Valued_Procedure
(SYS_PAL_REMQHIL, "SYS$PAL_REMQHIL",
(Remq, Address),
procedure SYS_PAL_INSQTIL
(STATUS : out Integer; Header : Address; ITEM : Address);
- pragma Interface (External, SYS_PAL_INSQTIL);
+ pragma Import (External, SYS_PAL_INSQTIL);
pragma Import_Valued_Procedure (SYS_PAL_INSQTIL, "SYS$PAL_INSQTIL",
(Integer, Address, Address),
(Value, Value, Value));
procedure SYS_PAL_REMQTIL
(Remret : out Remq; Header : Address);
- pragma Interface (External, SYS_PAL_REMQTIL);
+ pragma Import (External, SYS_PAL_REMQTIL);
pragma Import_Valued_Procedure (SYS_PAL_REMQTIL, "SYS$PAL_REMQTIL",
(Remq, Address),
(Value, Value));
-- B o d y --
-- (Version for Alpha/VMS) --
-- --
--- Copyright (C) 2001-2010, AdaCore --
+-- Copyright (C) 2001-2012, AdaCore --
-- --
-- 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- --
Invo_Handle : Invo_Handle_Type;
Invo_Context : out Invo_Context_Blk_Type);
- pragma Interface (External, Get_Invo_Context);
+ pragma Import (External, Get_Invo_Context);
pragma Import_Valued_Procedure (Get_Invo_Context, "LIB$GET_INVO_CONTEXT",
(Unsigned_Longword, Invo_Handle_Type, Invo_Context_Blk_Type),
Result : out Invo_Handle_Type; -- return value
ICB : Invo_Handle_Type);
- pragma Interface (External, Get_Prev_Invo_Handle);
+ pragma Import (External, Get_Prev_Invo_Handle);
pragma Import_Valued_Procedure
(Get_Prev_Invo_Handle, "LIB$GET_PREV_INVO_HANDLE",
procedure Get_Curr_Invo_Context
(Invo_Context : out Invo_Context_Blk_Type);
- pragma Interface (External, Get_Curr_Invo_Context);
+ pragma Import (External, Get_Curr_Invo_Context);
pragma Import_Valued_Procedure
(Get_Curr_Invo_Context, "LIB$GET_CURR_INVO_CONTEXT",
Result : out Invo_Handle_Type; -- return value
Invo_Context : Invo_Context_Blk_Type);
- pragma Interface (External, Get_Invo_Handle);
+ pragma Import (External, Get_Invo_Handle);
pragma Import_Valued_Procedure (Get_Invo_Handle, "LIB$GET_INVO_HANDLE",
(Invo_Handle_Type, Invo_Context_Blk_Type),
Acmode : unsigned_short := 0;
Mbxnam : String := String'Null_Parameter;
Flags : unsigned_long := 0);
- pragma Interface (External, Sys_Assign);
+ pragma Import (External, Sys_Assign);
pragma Import_Valued_Procedure
(Sys_Assign, "SYS$ASSIGN",
(Cond_Value_Type, String, unsigned_short,
(Status : out Cond_Value_Type;
Reqidt : Address;
Acmode : unsigned);
- pragma Interface (External, Sys_Cantim);
+ pragma Import (External, Sys_Cantim);
pragma Import_Valued_Procedure
(Sys_Cantim, "SYS$CANTIM",
(Cond_Value_Type, Address, unsigned),
Acmode : unsigned_short := 0;
Lognam : String;
Flags : unsigned_long := 0);
- pragma Interface (External, Sys_Crembx);
+ pragma Import (External, Sys_Crembx);
pragma Import_Valued_Procedure
(Sys_Crembx, "SYS$CREMBX",
(Cond_Value_Type, unsigned_char, unsigned_short,
P5 : unsigned_long := 0;
P6 : unsigned_long := 0);
- pragma Interface (External, Sys_QIO);
+ pragma Import (External, Sys_QIO);
pragma Import_Valued_Procedure
(Sys_QIO, "SYS$QIO",
(Cond_Value_Type, unsigned_long, unsigned_short, unsigned_long,
AST : AST_Handler;
Reqidt : Address;
Flags : unsigned_long);
- pragma Interface (External, Sys_Setimr);
+ pragma Import (External, Sys_Setimr);
pragma Import_Valued_Procedure
(Sys_Setimr, "SYS$SETIMR",
(Cond_Value_Type, unsigned_long, Long_Integer,
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2012, Free Software Foundation, Inc. --
-- --
-- GNARL 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- --
Reptim : Long_Integer := Long_Integer'Null_Parameter
);
- pragma Interface (External, Sys_Schdwk);
+ pragma Import (External, Sys_Schdwk);
-- VMS system call to schedule a wakeup event
pragma Import_Valued_Procedure
(Sys_Schdwk, "SYS$SCHDWK",
Tim : out OS_Time
);
-- VMS system call to get the current system time
- pragma Interface (External, Sys_Gettim);
+ pragma Import (External, Sys_Gettim);
pragma Import_Valued_Procedure
(Sys_Gettim, "SYS$GETTIM",
(Cond_Value_Type, OS_Time),
procedure Sys_Hiber (Status : out Cond_Value_Type);
-- VMS system call to hibernate the current process
- pragma Interface (External, Sys_Hiber);
+ pragma Import (External, Sys_Hiber);
pragma Import_Valued_Procedure
(Sys_Hiber, "SYS$HIBER",
(Cond_Value_Type),
return System.Aux_DEC.Unsigned_Word;
-- DBGEXT is imported from s-tasdeb.adb and its parameter re-typed
-- as Address to avoid having a VMS specific s-tasdeb.ads.
- pragma Interface (C, DBGEXT);
+ pragma Import (C, DBGEXT);
pragma Import_Function (DBGEXT, "GNAT$DBGEXT");
type Facility_Type is range 0 .. 65535;
-- --
-- B o d y --
-- --
--- Copyright (C) 2008-2011, Free Software Foundation, Inc. --
+-- Copyright (C) 2008-2012, 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- --
Item_Req : Unsigned_Word;
Out_Buff : Unsigned_Longword;
Buff_Siz : Unsigned_Word);
- pragma Interface (External, Debug_Get);
+ pragma Import (External, Debug_Get);
pragma Import_Procedure (Debug_Get, "CMA$DEBUG_GET",
(OSI.Thread_Id, Unsigned_Word, System.Address, Unsigned_Word),
Outlen : out Unsigned_Word;
Outbuf : out String;
Prmlst : Unsigned_Longword_Array);
- pragma Interface (External, FAOL);
+ pragma Import (External, FAOL);
pragma Import_Valued_Procedure (FAOL, "SYS$FAOL",
(Cond_Value_Type, String, Unsigned_Word, String, Unsigned_Longword_Array),
Message_String : String);
procedure Put_Output (Message_String : String);
- pragma Interface (External, Put_Output);
+ pragma Import (External, Put_Output);
pragma Import_Valued_Procedure (Put_Output, "LIB$PUT_OUTPUT",
(Cond_Value_Type, String),
Number_Of_Arguments : Integer := Integer'Null_Parameter;
FAO_Argument_1 : Unsigned_Longword :=
Unsigned_Longword'Null_Parameter);
- pragma Interface (External, Signal);
+ pragma Import (External, Signal);
pragma Import_Procedure (Signal, "LIB$SIGNAL",
(Cond_Value_Type, Integer, Unsigned_Longword),
end if;
Analyze_Call (N);
+
+ -- Mark function call if within assertion
+
+ if In_Assertion_Expr /= 0 then
+ Set_In_Assertion (N);
+ end if;
end Analyze_Function_Call;
-----------------------------
Set_Renamed_Object (Id, Entity (Nam));
end if;
end if;
+
+ -- Implementation-defined aspect specifications can appear in a renaming
+ -- declaration, but not language-defined ones. The call to procedure
+ -- Analyze_Aspect_Specifications will take care of this error check.
+
+ if Has_Aspects (N) then
+ Analyze_Aspect_Specifications (N, Id);
+ end if;
end Analyze_Exception_Renaming;
---------------------------
Check_Library_Unit_Renaming (N, Old_P);
end if;
+
+ -- Implementation-defined aspect specifications can appear in a renaming
+ -- declaration, but not language-defined ones. The call to procedure
+ -- Analyze_Aspect_Specifications will take care of this error check.
+
+ if Has_Aspects (N) then
+ Analyze_Aspect_Specifications (N, New_P);
+ end if;
end Analyze_Generic_Renaming;
-----------------------------
then
null;
- -- A renaming of an unchecked union does not have an
- -- actual subtype.
+ -- A renaming of an unchecked union has no actual subtype
elsif Is_Unchecked_Union (Typ) then
null;
-- when the renaming is generated in removing side effects of an
-- already-analyzed expression.
- if Nkind (Nam) = N_Selected_Component
- and then Analyzed (Nam)
- then
+ if Nkind (Nam) = N_Selected_Component and then Analyzed (Nam) then
T := Etype (Nam);
Dec := Build_Actual_Subtype_Of_Component (Etype (Nam), Nam);
end if;
Set_Renamed_Object (Id, Nam);
+
+ -- Implementation-defined aspect specifications can appear in a renaming
+ -- declaration, but not language-defined ones. The call to procedure
+ -- Analyze_Aspect_Specifications will take care of this error check.
+
+ if Has_Aspects (N) then
+ Analyze_Aspect_Specifications (N, Id);
+ end if;
+
+ -- Deal with dimensions
+
Analyze_Dimension (N);
end Analyze_Object_Renaming;
end;
end if;
end if;
+
+ -- Implementation-defined aspect specifications can appear in a renaming
+ -- declaration, but not language-defined ones. The call to procedure
+ -- Analyze_Aspect_Specifications will take care of this error check.
+
+ if Has_Aspects (N) then
+ Analyze_Aspect_Specifications (N, New_P);
+ end if;
end Analyze_Package_Renaming;
-------------------------------
if not Suppress_Elaboration_Warnings (E)
and then not Elaboration_Checks_Suppressed (E)
+
+ -- Suppress this warning if we have a function call that occurred
+ -- within an assertion expression, since we can get false warnings
+ -- in this case, due to the out of order handling in this case.
+
+ and then (Nkind (Original_Node (N)) /= N_Function_Call
+ or else not In_Assertion (Original_Node (N)))
then
if Inst_Case then
Error_Msg_NE
-- Implemented --
-----------------
- -- pragma Implemented (procedure_LOCAL_NAME, implementation_kind);
- -- implementation_kind ::=
+ -- pragma Implemented (procedure_LOCAL_NAME, IMPLEMENTATION_KIND);
+
+ -- IMPLEMENTATION_KIND ::=
-- By_Entry | By_Protected_Procedure | By_Any | Optional
-- "By_Any" and "Optional" are treated as synonyms in order to
E := Entity (E_Id);
- if E = Any_Id then
- return;
- else
- loop
- Set_Suppress_Style_Checks (E,
- (Chars (Get_Pragma_Arg (Arg1)) = Name_Off));
- exit when No (Homonym (E));
- E := Homonym (E);
- end loop;
+ if not Ignore_Style_Checks_Pragmas then
+ if E = Any_Id then
+ return;
+ else
+ loop
+ Set_Suppress_Style_Checks
+ (E, Chars (Get_Pragma_Arg (Arg1)) = Name_Off);
+ exit when No (Homonym (E));
+ E := Homonym (E);
+ end loop;
+ end if;
end if;
end;
-- them in the parser.
if J = Slen then
- Set_Style_Check_Options (Options);
+ if not Ignore_Style_Checks_Pragmas then
+ Set_Style_Check_Options (Options);
+ end if;
+
exit;
end if;
elsif Nkind (A) = N_Identifier then
if Chars (A) = Name_All_Checks then
- if GNAT_Mode then
- Set_GNAT_Style_Check_Options;
- else
- Set_Default_Style_Check_Options;
+ if not Ignore_Style_Checks_Pragmas then
+ if GNAT_Mode then
+ Set_GNAT_Style_Check_Options;
+ else
+ Set_Default_Style_Check_Options;
+ end if;
end if;
elsif Chars (A) = Name_On then
- Style_Check := True;
+ if not Ignore_Style_Checks_Pragmas then
+ Style_Check := True;
+ end if;
elsif Chars (A) = Name_Off then
- Style_Check := False;
+ if not Ignore_Style_Checks_Pragmas then
+ Style_Check := False;
+ end if;
end if;
end if;
end if;
return Flag16 (N);
end Import_Interface_Present;
+ function In_Assertion
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Function_Call);
+ return Flag4 (N);
+ end In_Assertion;
+
function In_Present
(N : Node_Id) return Boolean is
begin
Set_Flag16 (N, Val);
end Set_Import_Interface_Present;
+ procedure Set_In_Assertion
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Function_Call);
+ Set_Flag4 (N, Val);
+ end Set_In_Assertion;
+
procedure Set_In_Present
(N : Node_Id; Val : Boolean := True) is
begin
-- pragma of the other kind is also present. This is used to avoid
-- generating some unwanted error messages.
+ -- In_Assertion (Flag4-Sem)
+ -- This flag is present in N_Function_Call nodes. It is set if the
+ -- function is called from within an assertion expression. This is
+ -- used to avoid some bogus warnings about early elaboration.
+
-- Includes_Infinities (Flag11-Sem)
-- This flag is present in N_Range nodes. It is set for the range of
-- unconstrained float types defined in Standard, which include not only
-- actual parameter part)
-- First_Named_Actual (Node4-Sem)
-- Controlling_Argument (Node1-Sem) (set to Empty if not dispatching)
+ -- In_Assertion (Flag4-Sem)
-- Is_Expanded_Build_In_Place_Call (Flag11-Sem)
-- Do_Tag_Check (Flag13-Sem)
-- No_Elaboration_Check (Flag14-Sem)
function Import_Interface_Present
(N : Node_Id) return Boolean; -- Flag16
+ function In_Assertion
+ (N : Node_Id) return Boolean; -- Flag4
+
function In_Present
(N : Node_Id) return Boolean; -- Flag15
procedure Set_Import_Interface_Present
(N : Node_Id; Val : Boolean := True); -- Flag16
+ procedure Set_In_Assertion
+ (N : Node_Id; Val : Boolean := True); -- Flag4
+
procedure Set_In_Present
(N : Node_Id; Val : Boolean := True); -- Flag15
pragma Inline (Interface_Present);
pragma Inline (Includes_Infinities);
pragma Inline (Import_Interface_Present);
+ pragma Inline (In_Assertion);
pragma Inline (In_Present);
pragma Inline (Inherited_Discriminant);
pragma Inline (Instance_Spec);
pragma Inline (Set_Interface_List);
pragma Inline (Set_Interface_Present);
pragma Inline (Set_Import_Interface_Present);
+ pragma Inline (Set_In_Assertion);
pragma Inline (Set_In_Present);
pragma Inline (Set_Inherited_Discriminant);
pragma Inline (Set_Instance_Spec);
Ptr := Ptr + 1;
Check_Validity_Of_Parameters := True;
+ -- -gnateY (ignore Style_Checks pragmas)
+
+ when 'Y' =>
+ Ignore_Style_Checks_Pragmas := True;
+ Ptr := Ptr + 1;
+
-- -gnatez (final delimiter of explicit switches)
-- All switches that come after -gnatez have been added by
----------------------------
procedure Lib_Stop (Cond_Value : Integer);
- pragma Interface (C, Lib_Stop);
+ pragma Import (C, Lib_Stop);
pragma Import_Procedure (Lib_Stop, "LIB$STOP", Mechanism => (Value));
-- Interface to VMS condition handling. Used by RTSfind and pragma
-- {Import,Export}_Exception. Put here because this is the only
----------------------------
procedure Lib_Stop (Cond_Value : Integer);
- pragma Interface (C, Lib_Stop);
+ pragma Import (C, Lib_Stop);
pragma Import_Procedure (Lib_Stop, "LIB$STOP", Mechanism => (Value));
-- Interface to VMS condition handling. Used by RTSfind and pragma
-- {Import,Export}_Exception. Put here because this is the only
Write_Switch_Char ("eV");
Write_Line ("Validity checks on subprogram parameters");
+ -- Line for -gnateY switch
+
+ Write_Switch_Char ("eY");
+ Write_Line ("Ignore all Style_Checks pragmas in source");
+
-- Line for -gnatez switch
Write_Switch_Char ("ez");
"-gnati1";
-- NODOC (see /IDENTIFIER_CHARACTER_SET)
- S_GCC_Ignore : aliased constant S := "/IGNORE_REP_CLAUSES " &
+ S_GCC_IgnoreR : aliased constant S := "/IGNORE_REP_CLAUSES " &
"-gnatI";
-- /IGNORE_REP_CLAUSES
--
-- comments. Useful when compiling foreign code (for example when ASIS
-- is used to analyze such code).
+ S_GCC_IgnoreS : aliased constant S := "/IGNORE_STYLE_CHECKS_PRAGMAS " &
+ "-gnateY";
+ -- /IGNORE_STYLE_CHECKS_PRAGMAS
+ --
+ -- Causes all Style_Checks pragmas to be checked for legality, but
+ -- otherwise ignored. Allows style checks to be fully controlled by
+ -- command line qualifiers.
+
S_GCC_Immed : aliased constant S := "/IMMEDIATE_ERRORS " &
"-gnatdO";
-- /NOIMMEDIATE_ERRORS (D)
S_GCC_Help 'Access,
S_GCC_Ident 'Access,
S_GCC_IdentX 'Access,
- S_GCC_Ignore 'Access,
+ S_GCC_IgnoreR 'Access,
+ S_GCC_IgnoreS 'Access,
S_GCC_Immed 'Access,
S_GCC_Inline 'Access,
S_GCC_InlineX 'Access,
projects / gcc.git / commitdiff