+2015-05-22 Robert Dewar <dewar@adacore.com>
+
+ * debug.adb: Update documentation.
+ * einfo.ads, einfo.adb (Needs_Typedef): New flag
+ * exp_unst.adb (Unnest_Subprogram): Mark AREC types as needing
+ typedef's in C.
+ * frontend.adb: Update comments.
+ * gnat1drv.adb (Adjust_Global_Switches): Set all needed flags
+ for -gnatd.V
+ * opt.ads (Generate_C_Code): New switch.
+ * osint-c.adb (Write_C_File_Info): Removed, not used
+ (Write_H_File_Info): Removed, not used
+ * osint-c.ads (Write_C_File_Info): Removed, not used
+ (Write_H_File_Info): Removed, not used
+ * osint.ads (Write_Info): Minor comment updates.
+ (Output_FD): Moved from private part to public part of spec.
+ * sem.adb (Semantics): Force expansion on if in Generate_C_Code
+ mode.
+ * atree.ads: minor typo in comment.
+ * sem_prag.adb (Process_Atomic_Independent_Shared_Volatile):
+ Do not allow VFA on composite object with aliased component.
+
2015-05-22 Arnaud Charlet <charlet@adacore.com>
* osint-c.adb, osint-c.ads (Set_File_Name): Move back to spec.
-- These flags are used in the usual manner in Sinfo and Einfo
Is_Ignored_Ghost_Node : Boolean;
- -- Flag denothing whether the node is subject to pragma Ghost with
+ -- Flag denoting whether the node is subject to pragma Ghost with
-- policy Ignore. The name of the flag should be Flag4, however this
-- requires changing the names of all remaining 300+ flags.
-- the order in which units are walked. This is primarily for use in
-- debugging CodePeer mode.
- -- d.X A previous version of GNAT allowed indexing aspects to be
- -- redefined on derived container types, while the default iterator
- -- was inherited from the aprent type. This non-standard extension
- -- is preserved temporarily for use by the modelling project under
- -- debug flag d.X.
+ -- d.X A previous version of GNAT allowed indexing aspects to be redefined
+ -- on derived container types, while the default iterator was
+ -- inherited from the aprent type. This non-standard extension is
+ -- preserved temporarily for use by the modelling project under debug
+ -- flag d.X.
-- d.Z Normally we always enable expansion in configurable run-time mode
-- to make sure we get error messages about unsupported features even
-- Is_Uplevel_Referenced_Entity Flag283
-- Is_Unimplemented Flag284
-- Has_Volatile_Full_Access Flag285
+ -- Needs_Typedef Flag286
- -- (unused) Flag286
-- (unused) Flag287
-- (unused) Flag288
-- (unused) Flag289
return Flag22 (Id);
end Needs_No_Actuals;
+ function Needs_Typedef (Id : E) return B is
+ begin
+ pragma Assert (Is_Type (Id));
+ return Flag286 (Id);
+ end Needs_Typedef;
+
function Never_Set_In_Source (Id : E) return B is
begin
return Flag115 (Id);
Set_Flag22 (Id, V);
end Set_Needs_No_Actuals;
+ procedure Set_Needs_Typedef (Id : E; V : B := True) is
+ begin
+ pragma Assert (Is_Type (Id));
+ Set_Flag286 (Id, V);
+ end Set_Needs_Typedef;
+
procedure Set_Never_Set_In_Source (Id : E; V : B := True) is
begin
Set_Flag115 (Id, V);
W ("Must_Have_Preelab_Init", Flag208 (Id));
W ("Needs_Debug_Info", Flag147 (Id));
W ("Needs_No_Actuals", Flag22 (Id));
+ W ("Needs_Typedef", Flag286 (Id));
W ("Never_Set_In_Source", Flag115 (Id));
W ("No_Dynamic_Predicate_On_actual", Flag276 (Id));
W ("No_Pool_Assigned", Flag131 (Id));
-- Has_Aliased_Components (Flag135) [implementation base type only]
-- Defined in array type entities. Indicates that the component type
--- of the array is aliased.
+-- of the array is aliased. Should this also be set for records to
+-- indicate that at least one component is aliased (see processing in
+-- Sem_Prag.Process_Atomic_Independent_Shared_Volatile???)
-- Has_Alignment_Clause (Flag46)
-- Defined in all type entities and objects. Indicates if an alignment
-- interpreted as an indexing of the result of the call. It is also
-- used to resolve various cases of entry calls.
+-- Needs_Typedef (Flag286)
+-- Defined for all types and subtypes. Set if it is essential to generate
+-- a typedef when we are generating C code from Cprint. Normally we
+-- generate typedef's only for source entities, and not for internally
+-- generated types, but there are cases, notably the AREC types generated
+-- in Exp_Unst when we are unnesting subprograms where we must generate
+-- typedef's for non-source types.
+
-- Never_Set_In_Source (Flag115)
-- Defined in all entities, but can be set only for variables and
-- parameters. This flag is set if the object is never assigned a value
-- May_Inherit_Delayed_Rep_Aspects (Flag262)
-- Must_Be_On_Byte_Boundary (Flag183)
-- Must_Have_Preelab_Init (Flag208)
+ -- Needs_Typedef (Flag286)
-- Optimize_Alignment_Space (Flag241)
-- Optimize_Alignment_Time (Flag242)
-- Partial_View_Has_Unknown_Discr (Flag280)
function Must_Have_Preelab_Init (Id : E) return B;
function Needs_Debug_Info (Id : E) return B;
function Needs_No_Actuals (Id : E) return B;
+ function Needs_Typedef (Id : E) return B;
function Never_Set_In_Source (Id : E) return B;
function Next_Inlined_Subprogram (Id : E) return E;
function No_Dynamic_Predicate_On_Actual (Id : E) return B;
procedure Set_Must_Have_Preelab_Init (Id : E; V : B := True);
procedure Set_Needs_Debug_Info (Id : E; V : B := True);
procedure Set_Needs_No_Actuals (Id : E; V : B := True);
+ procedure Set_Needs_Typedef (Id : E; V : B := True);
procedure Set_Never_Set_In_Source (Id : E; V : B := True);
procedure Set_Next_Inlined_Subprogram (Id : E; V : E);
procedure Set_No_Dynamic_Predicate_On_Actual (Id : E; V : B := True);
pragma Inline (Must_Have_Preelab_Init);
pragma Inline (Needs_Debug_Info);
pragma Inline (Needs_No_Actuals);
+ pragma Inline (Needs_Typedef);
pragma Inline (Never_Set_In_Source);
pragma Inline (Next_Index);
pragma Inline (Next_Inlined_Subprogram);
pragma Inline (Set_Must_Have_Preelab_Init);
pragma Inline (Set_Needs_Debug_Info);
pragma Inline (Set_Needs_No_Actuals);
+ pragma Inline (Set_Needs_Typedef);
pragma Inline (Set_Never_Set_In_Source);
pragma Inline (Set_Next_Inlined_Subprogram);
pragma Inline (Set_No_Dynamic_Predicate_On_Actual);
Analyze (Decl_ARECnP, Suppress => All_Checks);
Pop_Scope;
+ -- Mark the types as needing typedefs
+
+ Set_Needs_Typedef (STJ.ARECnT);
+ Set_Needs_Typedef (STJ.ARECnPT);
+
-- Next step, for each uplevel referenced entity, add
-- assignment operations to set the component in the
-- activation record.
Sprint.Source_Dump;
- -- Check again for configuration pragmas that appear in the context of
- -- the main unit. These pragmas only affect the main unit, and the
+ -- Check again for configuration pragmas that appear in the context
+ -- of the main unit. These pragmas only affect the main unit, and the
-- corresponding flag is reset after each call to Semantics, but they
-- may affect the generated ali for the unit, and therefore the flag
-- must be set properly after compilation. Currently we only check for
Modify_Tree_For_C := True;
end if;
+ -- Other flags set if we are generating C code
+
+ if Debug_Flag_Dot_VV then
+ Generate_C_Code := True;
+ Unnest_Subprogram_Mode := True;
+ end if;
+
-- -gnatd.E sets Error_To_Warning mode, causing selected error messages
-- to be treated as warnings instead of errors.
-- the name is of the form .xxx, then to name.xxx where name is the source
-- file name with extension stripped.
+ Generate_C_Code : Boolean := False;
+ -- GNAT
+ -- If True, the Cprint circuitry to generate C code output is activated.
+ -- Set True by use of -gnatd.V.
+
Generate_CodePeer_Messages : Boolean := False;
-- GNAT
-- Generate CodePeer messages. Ignored if CodePeer_Mode is false. This is
Tree_Write_Initialize (Output_FD);
end Tree_Create;
- -----------------------
- -- Write_C_File_Info --
- -----------------------
-
- procedure Write_C_File_Info (Info : String) renames Write_Info;
-
-----------------------
-- Write_Debug_Info --
-----------------------
procedure Write_Debug_Info (Info : String) renames Write_Info;
- -----------------------
- -- Write_H_File_Info --
- -----------------------
-
- procedure Write_H_File_Info (Info : String) renames Write_Info;
-
------------------------
-- Write_Library_Info --
------------------------
-- Close current debug file created by the most recent call to
-- Create_Repinfo_File.
+ procedure Set_File_Name (Ext : String);
+ -- Sets a default file name from the main compiler source name. Ext is the
+ -- extension, e.g. "ali" for a library information file. The name is in
+ -- Name_Buffer (with length in Name_Len) on return. This is visible in
+ -- the spec since it used directly by clients in the .Net case.
+
--------------------------------
-- Library Information Output --
--------------------------------
-- returned by Next_Main_Source) for appending. This is used to append
-- the globals computed in flow analysis in gnatprove mode.
- procedure Set_File_Name (Ext : String);
- -- Sets a default file name from the main compiler source name. Ext is
- -- the extension, e.g. "ali" for a library information file.
- -- The name is in Name_Buffer (with length in Name_Len) on return.
-
procedure Write_Library_Info (Info : String);
-- Writes the contents of the referenced string to the library information
-- file for the main source file currently being compiled (i.e. the file
-- These routines are used by the compiler when the C translation option
-- is activated to write *.c and *.h files to the current object directory.
-- Each routine exists in a C and an H form for the two kinds of files.
- -- Only one of these files can be written at a time.
+ -- Only one of these files can be written at a time. Note that the files
+ -- are written via the Output package routines, using Output_FD.
procedure Create_C_File;
procedure Create_H_File;
-- being compiled (i.e. the file which was most recently returned by
-- Next_Main_Source).
- procedure Write_C_File_Info (Info : String);
- procedure Write_H_File_Info (Info : String);
- -- Writes the contents of the referenced string to the *.c or *.h file for
- -- the main source file currently being compiled (i.e. the file which was
- -- most recently opened with a call to Read_Next_File). Info represents
- -- a line in the file with a line termination character at the end (which
- -- is not present in the info string).
-
procedure Close_C_File;
procedure Close_H_File;
-- Closes the file created by Create_C_File or Create_H file, flushing any
Project_Include_Path_File : constant String := "ADA_PRJ_INCLUDE_FILE";
Project_Objects_Path_File : constant String := "ADA_PRJ_OBJECTS_FILE";
+ Output_FD : File_Descriptor;
+ -- File descriptor for current library info, list, tree, C, H, or binder
+ -- output. Only one of these is open at a time, so we need only one FD.
+
procedure Initialize;
-- Initialize internal tables
Target_Object_Suffix : constant String := Get_Target_Object_Suffix.all;
-- The suffix used for the target object files
- Output_FD : File_Descriptor;
- -- File descriptor for current library info, list, tree, C, H, or binder
- -- output. Only one of these is open at a time, so we need only one FD.
-
Output_File_Name : File_Name_Type;
-- File_Name_Type for name of open file whose FD is in Output_FD, the name
-- stored does not include the trailing NUL character.
-- for this file. This routine merely constructs the name.
procedure Write_Info (Info : String);
- -- Implement Write_Binder_Info, Write_Debug_Info, Write_C_File_Info,
- -- Write_H_File_Info, and Write_Library_Info (identical)
+ -- Implement Write_Binder_Info, Write_Debug_Info, and Write_Library_Info
procedure Write_With_Check (A : Address; N : Integer);
-- Writes N bytes from buffer starting at address A to file whose FD is
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2015, 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- --
(Operating_Mode = Generate_Code
- -- or if special debug flag -gnatdx is set
+ -- Or if special debug flag -gnatdx is set
or else Debug_Flag_X
+ -- Or if we are generating C code
+
+ or else Generate_C_Code
+
-- Or if in configuration run-time mode. We do this so we get
-- error messages about missing entities in the run-time even
-- if we are compiling in -gnatc (no code generation) mode.
("cannot have Volatile_Full_Access and Atomic for same entity");
end if;
+ -- Check for applying VFA to an entity which has volatile component
+
+ if Prag_Id = Pragma_Volatile_Full_Access then
+ declare
+ Comp : Entity_Id;
+ Aliased_Comp : Boolean := False;
+ -- Set True if aliased component present
+
+ begin
+ if Is_Array_Type (Etype (E)) then
+ Aliased_Comp := Has_Aliased_Components (Etype (E));
+
+ -- Record case, too bad Has_Aliased_Components is not also
+ -- set for records, should it be ???
+
+ elsif Is_Record_Type (Etype (E)) then
+ Comp := First_Component_Or_Discriminant (Etype (E));
+ while Present (Comp) loop
+ if Is_Aliased (Comp)
+ or else Is_Aliased (Etype (Comp))
+ then
+ Aliased_Comp := True;
+ exit;
+ end if;
+
+ Next_Component_Or_Discriminant (Comp);
+ end loop;
+ end if;
+
+ if Aliased_Comp then
+ Error_Pragma
+ ("cannot apply Volatile_Full_Access (aliased component "
+ & "present)");
+ end if;
+ end;
+ end if;
+
-- Now check appropriateness of the entity
if Is_Type (E) then
projects / gcc.git / commitdiff