+2009-04-20 Robert Dewar <dewar@adacore.com>
+
+ * sinfo.ads: Minor comment fixes
+
+ * exp_disp.adb: Minor reformatting
+
+ * gnat1drv.adb: Minor reformatting
+
+ * output.adb: Minor reformatting
+
+ * s-vxwext-kernel.ads: Minor reformatting
+
+ * sem.ads: Minor reformatting
+
+ * sem.adb: Minor reformatting
+
+ * sem_elim.adb: Minor reformatting
+
+ * uname.ads: Minor reformatting
+
+2009-04-20 Eric Botcazou <ebotcazou@adacore.com>
+
+ * init.c (__gnat_adjust_context_for_raise): On x86{-64}/Linux, add
+ a small dope of 4 words to the adjustment to the stack pointer.
+
+2009-04-20 Thomas Quinot <quinot@adacore.com>
+
+ * xoscons.adb: generate C header s-oscons.h in
+ addition to s-oscons.ads.
+
+ * socket.c: On VMS, use s-oscons.h.
+
+ * sem_ch3.adb: Minor reformatting
+
+ * exp_ch9.adb: Minor reformatting
+
2009-04-20 Eric Botcazou <ebotcazou@adacore.com>
* gcc-interface/trans.c (check_for_eliminated_entity): Remove.
when N_Subprogram_Body =>
- -- Do not create bodies for eliminated operations.
+ -- Do not create bodies for eliminated operations
if not Is_Eliminated (Defining_Entity (Op_Body))
and then not Is_Eliminated (Corresponding_Spec (Op_Body))
New_Op_Body :=
Build_Unprotected_Subprogram_Body (Op_Body, Pid);
- -- Propagate the finalization chain to the new body.
- -- In the unlikely event that the subprogram contains a
- -- declaration or allocator for an object that requires
- -- finalization, the corresponding chain is created when
- -- analyzing the body, and attached to its entity. This
- -- entity is not further elaborated, and so the chain
- -- properly belongs to the newly created subprogram body.
+ -- Propagate the finalization chain to the new body. In the
+ -- unlikely event that the subprogram contains a declaration
+ -- or allocator for an object that requires finalization,
+ -- the corresponding chain is created when analyzing the
+ -- body, and attached to its entity. This entity is not
+ -- further elaborated, and so the chain properly belongs to
+ -- the newly created subprogram body.
Chain :=
Finalization_Chain_Entity (Defining_Entity (Op_Body));
-- appear that this is needed only if this is a visible
-- operation of the type, or if it is an interrupt handler,
-- and this was the strategy used previously in GNAT.
- -- However, the operation may be exported through a
- -- 'Access to an external caller. This is the common idiom
- -- in code that uses the Ada 2005 Timing_Events package
- -- As a result we need to produce the protected body for
- -- both visible and private operations.
+ -- However, the operation may be exported through a 'Access
+ -- to an external caller. This is the common idiom in code
+ -- that uses the Ada 2005 Timing_Events package. As a result
+ -- we need to produce the protected body for both visible
+ -- and private operations.
if Present (Corresponding_Spec (Op_Body)) then
Op_Decl :=
or else
(not Comes_From_Source (Defining_Entity (D))
and then
- Has_Unknown_Discriminants (Etype (Defining_Entity (D)))
+ Has_Unknown_Discriminants (Etype (Defining_Entity (D)))
and then
- not Comes_From_Source (First_Subtype (Defining_Entity (D))))
+ not Comes_From_Source
+ (First_Subtype (Defining_Entity (D))))
then
null;
-
else
Insert_List_After_And_Analyze (Last (Target_List),
Make_DT (Defining_Entity (D)));
-- Check_Library_Items --
-------------------------
+ -- Walk_Library_Items has plenty of assertions, so all we need to do is
+ -- call it, just for these assertions, not actually doing anything else.
+
procedure Check_Library_Items is
- -- Walk_Library_Items has plenty of assertions, so all we need to do is
- -- call it.
procedure Action (Item : Node_Id);
-- Action passed to Walk_Library_Items to do nothing
+ ------------
+ -- Action --
+ ------------
+
procedure Action (Item : Node_Id) is
begin
null;
procedure Walk is new Sem.Walk_Library_Items (Action);
- -- Start of processing for Check_Library_Items
+ -- Start of processing for Check_Library_Items
+
begin
Walk;
end Check_Library_Items;
by the time the EH return is executed.
We therefore adjust the saved value of the stack pointer by the size
- of one page, in order to make sure that it points to an accessible
- address in case it's used as the target CFA. The stack checking code
- guarantees that this page is unused by the time this happens. */
+ of one page + a small dope of 4 words, in order to make sure that it
+ points to an accessible address in case it's used as the target CFA.
+ The stack checking code guarantees that this address is unused by the
+ time this happens. */
#if defined (i386)
unsigned long pattern = *(unsigned long *)mcontext->gregs[REG_EIP];
/* The pattern is "orl $0x0,(%esp)" for a probe in 32-bit mode. */
if (signo == SIGSEGV && pattern == 0x00240c83)
- mcontext->gregs[REG_ESP] += 4096;
+ mcontext->gregs[REG_ESP] += 4096 + 4 * sizeof (unsigned long);
#elif defined (__x86_64__)
unsigned long pattern = *(unsigned long *)mcontext->gregs[REG_RIP];
/* The pattern is "orq $0x0,(%rsp)" for a probe in 64-bit mode. */
if (signo == SIGSEGV && (pattern & 0xffffffffff) == 0x00240c8348)
- mcontext->gregs[REG_RSP] += 4096;
+ mcontext->gregs[REG_RSP] += 4096 + 4 * sizeof (unsigned long);
#elif defined (__ia64__)
/* ??? The IA-64 unwinder doesn't compensate for signals. */
mcontext->sc_ip++;
procedure Indent is
begin
+ -- The "mod" in the following assignment is to cause a wrap around in
+ -- the case where there is too much indentation.
+
Cur_Indentation :=
(Cur_Indentation + Indentation_Amount) mod Indentation_Limit;
- -- The "mod" is to wrap around in case there's too much indentation
end Indent;
-------------
procedure Outdent is
begin
+ -- The "mod" here undoes the wrap around from Indent above
+
Cur_Indentation :=
(Cur_Indentation - Indentation_Amount) mod Indentation_Limit;
end Outdent;
type UINT64 is mod 2 ** Long_Long_Integer'Size;
function tickGet return UINT64;
- -- needed for ravenscar-cert
+ -- Needed for ravenscar-cert
pragma Import (C, tickGet, "tick64Get");
end System.VxWorks.Ext;
-- assertions and debugging output.
case Nkind (Item) is
- when N_Generic_Subprogram_Declaration |
- N_Generic_Package_Declaration |
- N_Package_Declaration |
- N_Subprogram_Declaration |
- N_Subprogram_Renaming_Declaration |
- N_Package_Renaming_Declaration |
+ when N_Generic_Subprogram_Declaration |
+ N_Generic_Package_Declaration |
+ N_Package_Declaration |
+ N_Subprogram_Declaration |
+ N_Subprogram_Renaming_Declaration |
+ N_Package_Renaming_Declaration |
N_Generic_Function_Renaming_Declaration |
- N_Generic_Package_Renaming_Declaration |
+ N_Generic_Package_Renaming_Declaration |
N_Generic_Procedure_Renaming_Declaration =>
null; -- Specs are OK
-- All other cases cannot happen
when N_Function_Instantiation |
- N_Procedure_Instantiation |
- N_Package_Instantiation =>
+ N_Procedure_Instantiation |
+ N_Package_Instantiation =>
pragma Assert (False, "instantiation");
null;
Write_Int (Int (Get_Cunit_Unit_Number (CU)));
Write_Str (", ");
Write_Str (Node_Kind'Image (Nkind (Item)));
+
if Item /= Original_Node (Item) then
Write_Str (", orig = ");
Write_Str (Node_Kind'Image (Nkind (Original_Node (Item))));
end if;
+
Write_Eol;
end if;
- else -- Must be Standard
+ else
+ -- Must be Standard
+
pragma Assert (Item = Stand.Standard_Package_Node);
+
if Enable_Output then
Write_Line ("Standard");
end if;
Action (Item);
end Do_Action;
+ -- Local Declarations
+
Cur : Elmt_Id := First_Elmt (Comp_Unit_List);
- -- Start of processing for Walk_Library_Items
+ -- Start of processing for Walk_Library_Items
begin
if Enable_Output then
declare
CU : constant Node_Id := Node (Cur);
N : constant Node_Id := Unit (CU);
+
begin
pragma Assert (Nkind (CU) = N_Compilation_Unit);
case Nkind (N) is
+
-- If it's a body, then ignore it, unless it's an instance (in
-- which case we do the spec), or it's the main unit (in which
-- case we do it). Note that it could be both.
when N_Package_Body | N_Subprogram_Body =>
declare
Entity : Node_Id := N;
+
begin
if Nkind (N) = N_Subprogram_Body then
Entity := Specification (Entity);
end if;
+
Entity := Defining_Unit_Name (Entity);
+
if Nkind (Entity) not in N_Entity then
+
-- Must be N_Defining_Program_Unit_Name
+
Entity := Defining_Identifier (Entity);
end if;
end;
if CU = Cunit (Main_Unit) then
+
-- Must come last
pragma Assert (No (Next_Elmt (Cur)));
-- is the N_Package_Declaration node for package Standard. Bodies are not
-- included, except for the main unit itself, which always comes last.
--
- -- Item is never a subunit.
+ -- Item is never a subunit
--
-- Item is never an instantiation. Instead, the instance declaration is
-- passed, and (if the instantiation is the main unit), the instance body.
-- This does not apply if the base type is a generic type, whose
-- declaration is independent of the current derived definition.
- if B /= T
- and then not Is_Generic_Type (B)
- then
+ if B /= T and then not Is_Generic_Type (B) then
Ensure_Freeze_Node (B);
Set_First_Subtype_Link (Freeze_Node (B), T);
end if;
-- A type that is imported through a limited_with clause cannot
- -- generate any code, and thus need not be frozen. However, an
- -- access type with an imported designated type needs a finalization
- -- list, which may be referenced in some other package that has
- -- non-limited visibility on the designated type. Thus we must
- -- create the finalization list at the point the access type is
- -- frozen, to prevent unsatisfied references at link time.
-
- if not From_With_Type (T)
- or else Is_Access_Type (T)
- then
+ -- generate any code, and thus need not be frozen. However, an access
+ -- type with an imported designated type needs a finalization list,
+ -- which may be referenced in some other package that has non-limited
+ -- visibility on the designated type. Thus we must create the
+ -- finalization list at the point the access type is frozen, to
+ -- prevent unsatisfied references at link time.
+
+ if not From_With_Type (T) or else Is_Access_Type (T) then
Set_Has_Delayed_Freeze (T);
end if;
end;
- -- Case of T is the full declaration of some private type which has
+ -- Case where T is the full declaration of some private type which has
-- been swapped in Defining_Identifier (N).
if T /= Def_Id and then Is_Private_Type (Def_Id) then
Generate_Definition (Def_Id);
end if;
- if Chars (Scope (Def_Id)) = Name_System
+ if Chars (Scope (Def_Id)) = Name_System
and then Chars (Def_Id) = Name_Address
and then Is_Predefined_File_Name (Unit_File_Name (Get_Source_Unit (N)))
then
begin
if Is_Eliminated (Ultimate_Subp) and then not Inside_A_Generic then
-
Enclosing_Subp := Current_Subprogram;
while Present (Enclosing_Subp) loop
if Is_Eliminated (Enclosing_Subp) then
-- There is no explicit node in the tree for a compilation, since in
-- general the compiler is processing only a single compilation unit
-- at a time. It is possible to parse multiple units in syntax check
- -- only mode, but they the trees are discarded in any case.
+ -- only mode, but the trees are discarded in that case.
------------------------------
-- 10.1.1 Compilation Unit --
-- There is no explicit node in the tree for library item, instead
-- the declaration or body, and the flag for private if present,
- -- appear in the N_Compilation_Unit clause.
+ -- appear in the N_Compilation_Unit node.
--------------------------------------
-- 10.1.1 Library Unit Declaration --
/* This file provides a portable binding to the sockets API */
#include "gsocket.h"
+#ifdef VMS
+/*
+ * For VMS, gsocket.h can't include sockets-related DEC C header files
+ * when building the runtime (because these files are in DEC C archives,
+ * not accessable to GCC). So, we generate a separate header file along
+ * with s-oscons.ads and include it here.
+ */
+# include "s-oscons.h"
+#endif
#if defined(HAVE_SOCKETS)
-- Unit Name Conventions --
---------------------------
- -- Units are associated with a unique ASCII name as follows. First we
- -- have the fully expanded name of the unit, with lower case letters
- -- (except for the use of upper case letters for encoding upper half
- -- and wide characters, as described in Namet), and periods. Following
- -- this is one of the following suffixes:
+ -- Units are associated with a unique ASCII name as follows. First we have
+ -- the fully expanded name of the unit, with lower case letters (except
+ -- for the use of upper case letters for encoding upper half and wide
+ -- characters, as described in Namet), and periods. Following this is one
+ -- of the following suffixes:
-- %s for package/subprogram/generic declarations (specs)
-- %b for package/subprogram/generic bodies and subunits
function New_Child
(Old : Unit_Name_Type;
Newp : Unit_Name_Type) return Unit_Name_Type;
- -- Old is a child unit name (for either a body or spec). Newp is the
- -- unit name of the actual parent (this may be different from the
- -- parent in old). The returned unit name is formed by taking the
- -- parent name from Newp and the child unit name from Old, with the
- -- result being a body or spec depending on Old. For example:
+ -- Old is a child unit name (for either a body or spec). Newp is the unit
+ -- name of the actual parent (this may be different from the parent in
+ -- old). The returned unit name is formed by taking the parent name from
+ -- Newp and the child unit name from Old, with the result being a body or
+ -- spec depending on Old. For example:
--
-- Old = A.B.C (body)
-- Newp = A.R (spec)
Table_Initial => 100,
Table_Increment => 10);
- Max_Constant_Name_Len : Natural := 0;
+ Max_Const_Name_Len : Natural := 0;
Max_Constant_Value_Len : Natural := 0;
-- Longest name and longest value lengths
- procedure Output_Info (OFile : Sfile; Info_Index : Integer);
+ type Language is (Lang_Ada, Lang_C);
+
+ procedure Output_Info
+ (Lang : Language;
+ OFile : Sfile;
+ Info_Index : Integer);
-- Output information from the indicated asm info line
procedure Parse_Asm_Line (Line : String);
function Contains_Template_Name (S : String) return Boolean is
begin
- return Index (Source => To_Lower (S), Pattern => Tmpl_Name) > 0;
+ if Index (Source => To_Lower (S), Pattern => Tmpl_Name) > 0 then
+ return True;
+ else
+ return False;
+ end if;
end Contains_Template_Name;
-----------------
-- Output_Info --
-----------------
- procedure Output_Info (OFile : Sfile; Info_Index : Integer) is
+ procedure Output_Info
+ (Lang : Language;
+ OFile : Sfile;
+ Info_Index : Integer)
+ is
Info : Asm_Info renames Asm_Infos.Table (Info_Index);
procedure Put (S : String);
if Info.Kind /= TXT then
-- TXT case is handled by the common code below
- Put (" ");
- Put (Info.Constant_Name.all);
- Put (Spaces (Max_Constant_Name_Len - Info.Constant_Name'Length));
+ case Lang is
+ when Lang_Ada =>
+ Put (" " & Info.Constant_Name.all);
+ Put (Spaces (Max_Const_Name_Len - Info.Constant_Name'Length));
- Put (" : constant := ");
+ Put (" : constant := ");
+
+ when Lang_C =>
+ Put ("#define " & Info.Constant_Name.all & " ");
+ Put (Spaces (Max_Const_Name_Len - Info.Constant_Name'Length));
+ end case;
if Info.Kind = CND then
if not Info.Int_Value.Positive then
Put (Info.Text_Value.all);
end if;
- Put (";");
+ if Lang = Lang_Ada then
+ Put (";");
- if Info.Comment'Length > 0 then
- Put (Spaces (Max_Constant_Value_Len - Info.Value_Len));
- Put (" -- ");
+ if Info.Comment'Length > 0 then
+ Put (Spaces (Max_Constant_Value_Len - Info.Value_Len));
+ Put (" -- ");
+ end if;
end if;
end if;
- Put (Info.Comment.all);
+ if Lang = Lang_Ada then
+ Put (Info.Comment.all);
+ end if;
+
New_Line (OFile);
end Output_Info;
Find_Colon (Index2);
Info.Constant_Name := Field_Alloc;
- if Info.Constant_Name'Length > Max_Constant_Name_Len then
- Max_Constant_Name_Len := Info.Constant_Name'Length;
+ if Info.Constant_Name'Length > Max_Const_Name_Len then
+ Max_Const_Name_Len := Info.Constant_Name'Length;
end if;
Index1 := Index2 + 1;
-- Local declarations
- Asm_File_Name : constant String := Tmpl_Name & ".s";
+ -- Input files
+
Tmpl_File_Name : constant String := Tmpl_Name & ".i";
+ Asm_File_Name : constant String := Tmpl_Name & ".s";
+
+ -- Output files
+
Ada_File_Name : constant String := Unit_Name & ".ads";
+ C_File_Name : constant String := Unit_Name & ".h";
Asm_File : Ada.Text_IO.File_Type;
Tmpl_File : Ada.Text_IO.File_Type;
- OFile : Sfile;
+ Ada_OFile : Sfile;
+ C_OFile : Sfile;
Line : String (1 .. 256);
Last : Integer;
-- Load C template and output definitions
Open (Tmpl_File, In_File, Tmpl_File_Name);
- Create (OFile, Out_File, Ada_File_Name);
+ Create (Ada_OFile, Out_File, Ada_File_Name);
+ Create (C_OFile, Out_File, C_File_Name);
Current_Line := 0;
Current_Info := Asm_Infos.First;
elsif In_Template then
if In_Comment then
if Line (1 .. Last) = "*/" then
+ Put_Line (C_OFile, Line (1 .. Last));
In_Comment := False;
else
- Put_Line (OFile, Line (1 .. Last));
+ Put_Line (Ada_OFile, Line (1 .. Last));
+ Put_Line (C_OFile, Line (1 .. Last));
end if;
elsif Line (1 .. Last) = "/*" then
+ Put_Line (C_OFile, Line (1 .. Last));
In_Comment := True;
elsif Asm_Infos.Table (Current_Info).Line_Number = Current_Line then
- Output_Info (OFile, Current_Info);
+ Output_Info (Lang_Ada, Ada_OFile, Current_Info);
+ Output_Info (Lang_C, C_OFile, Current_Info);
Current_Info := Current_Info + 1;
end if;
Current_Line := Current_Line + 1;
OSDN Git Service
