+2004-09-09 Vincent Celier <celier@gnat.com>
+
+ * a-direct.ads: Add pragma Ada_05
+ (Directory_Entry_Type): Give default value to component Kind to avoid
+ not initialized warnings.
+
+ * a-direct.adb (Current_Directory): Remove directory separator at the
+ end.
+ (Delete_Directory, Delete_Tree): Raise Name_Error if Directory is not
+ an existing directory.
+ (Fetch_Next_Entry): Give default value to variable Kind to avoid warning
+ (Size (String)): Function C_Size returns Long_Integer, not File_Size.
+ Convert the result to File_Size.
+
+ * prj.ads: (Project_Error): New exception
+
+ * prj-attr.adb: Except in procedure Initialize, Fail comes from
+ Prj.Com, not from Osint.
+ (Attrs, Package_Attributes): Tables moved to private part of spec
+ (Add_Attribute, Add_Unknown_Package): Moved to new child package
+ Prj.Attr.PM.
+ (Register_New_Package (Name, Attributes), Register_New_Attribute): Raise
+ Prj.Project_Error after call to Fail.
+ (Register_New_Package (Name, Id)): Set Id to Empty_Package after calling
+ Fail. Check that package name is not already in use.
+
+ * prj-attr.ads: Comment updates to indicate that all subprograms may be
+ used by tools, not only by the project manager, and to indicate that
+ exception Prj.Prj_Error may be raised in case of problem.
+ (Add_Unknown_Package, Add_Attribute): Moved to new child package
+ Prj.Attr.PM.
+ (Attrs, Package_Attributes): Table instantiations moved from the body to
+ the private part to be accessible from Prj.Attr.PM body.
+
+ * prj-dect.adb (Parse_Package_Declaration): Call Add_Unknown_Package
+ from new package Prj.Attr.PM.
+ (Parse_Attribute_Declaration): Call Add_Attribute from new package
+ Prj.Attr.PM.
+
+ * Makefile.in: Add prj-attr-pm.o to gnatmake object list
+
+ * gnatbind.adb (Gnatbind): Correct warning message (Elaboration_Check
+ instead of Elaboration_Checks).
+
+ * a-calend.adb: Minor reformatting
+
+2004-09-09 Richard Kenner <kenner@vlsi1.ultra.nyu.edu>
+
+ * gigi.h (maybe_pad_type): New declaration.
+ (create_subprog_type): New arg RETURNS_BY_TARGET_PTR.
+
+ * ada-tree.h: (TYPE_RETURNS_BY_TARGET_PTR_P): New macro.
+
+ * cuintp.c: Convert to use buildN.
+
+ * decl.c (maybe_pad_type): No longer static.
+ (gnat_to_gnu_entity, case E_Function): Handle case of returning by
+ target pointer.
+ Convert to use buildN.
+
+ * trans.c (call_to_gnu): Add arg GNU_TARGET; support
+ TYPE_RETURNS_BY_TARGET_PTR_P. All callers changed.
+ (gnat_to_gnu, case N_Assignment_Statement): Call call_to_gnu if call on
+ RHS.
+ (gnat_to_gnu, case N_Return): Handle TYPE_RETURN_BY_TARGET_PTR_P.
+ (gnat_gimplify_expr, case ADDR_EXPR): New case.
+ Convert to use buildN.
+
+ * utils2.c (gnat_build_constructor): Also set TREE_INVARIANT and
+ TREE_READONLY for const.
+ Convert to use buildN.
+
+ * utils.c (create_subprog_type): New operand RETURNS_BY_TARGET_PTR.
+ (create_var_decl): Refine when TREE_STATIC is set.
+ Convert to use buildN.
+
+2004-09-09 Gary Dismukes <dismukes@gnat.com>
+
+ * gnat_ugn.texi: Delete text relating to checking of ali and object
+ consistency.
+
+ * a-except.adb (Rcheck_*): Add pragmas No_Return for each of these
+ routines.
+
+2004-09-09 Jose Ruiz <ruiz@act-europe.fr>
+
+ * gnat_ugn.texi: Add Detect_Blocking to the list of configuration
+ pragmas recognized by GNAT.
+
+ * gnat_rm.texi: Document pragma Detect_Blocking.
+
+ * s-solita.adb (Timed_Delay_T): When pragma Detect_Blocking is active,
+ raise Program_Error if called from a protected operation.
+
+ * s-taprob.adb (Lock): When pragma Detect_Blocking is active increase
+ the protected action nesting level.
+ (Lock_Read_Only): When pragma Detect_Blocking is active increase the
+ protected action nesting level.
+ (Unlock): When pragma Detect_Blocking is active decrease the protected
+ action nesting level.
+
+ * s-taskin.adb (Initialize_ATCB): Initialize to 0 the
+ Protected_Action_Nesting.
+
+ * s-taskin.ads: Adding the field Protected_Action_Nesting to the
+ Common_ATCB record. It contains the dynamic level of protected action
+ nesting for each task. It is needed for checking whether potentially
+ blocking operations are called from protected operations.
+ (Detect_Blocking): Adding a Boolean constant reflecting whether pragma
+ Detect_Blocking is active or not in the partition.
+
+ * s-tasren.adb (Call_Simple): When pragma Detect_Blocking is active,
+ raise Program_Error if called from a protected operation.
+ (Task_Entry_Call): When pragma Detect_Blocking is active, raise
+ Program_Error if called from a protected operation.
+ (Timed_Task_Entry_Call): When pragma Detect_Blocking is active, raise
+ Program_Error if called from a protected operation.
+
+ * s-tassta.adb (Abort_Tasks): When pragma Detect_Blocking is active,
+ raise Program_Error if called from a protected operation.
+
+ * s-tpoben.adb (Lock_Entries): When pragma Detect_Blocking is active,
+ raise Program_Error if called from a protected operation, and increase
+ the protected action nesting level.
+ (Lock_Read_Only_Entries): When pragma Detect_Blocking is active, raise
+ Program_Error if called from a protected operation, and increase the
+ protected action nesting level.
+ (Unlock_Entries): When pragma Detect_Blocking is active decrease the
+ protected action nesting level.
+
+ * s-tposen.adb (Lock_Entry): When pragma Detect_Blocking is active,
+ raise Program_Error if called from a protected operation, and increase
+ the protected action nesting level.
+ (Lock_Read_Only_Entry): When pragma Detect_Blocking is active, raise
+ Program_Error if called from a protected operation, and increase the
+ protected action nesting level.
+ (Protected_Single_Entry_Call): When pragma Detect_Blocking is active,
+ raise Program_Error if called from a protected operation.
+ (Timed_Protected_Single_Entry_Call): When pragma Detect_Blocking is
+ active, raise Program_Error if called from a protected operation.
+ (Unlock_Entry): When pragma Detect_Blocking is active decrease the
+ protected action nesting level.
+
+ * sem_util.adb (Check_Potentially_Blocking_Operation): Remove the
+ insertion of the statement raising Program_Error. The run time
+ contains the required machinery for handling that.
+
+ * sem_util.ads: Change comment associated to procedure
+ Check_Potentially_Blocking_Operation.
+ This procedure does not insert a call for raising the exception because
+ that is currently done by the run time.
+
+ * raise.h (__gnat_set_globals): Pass the detect_blocking parameter.
+
+ * init.c: Add the global variable __gl_detect_blocking that indicates
+ whether pragma Detect_Blocking is active (1) or not (0). Needed for
+ making the pragma available at run time.
+ (__gnat_set_globals): Pass and update the detect_blocking parameter.
+
+ * lib-writ.adb (Write_ALI): Set the DB flag in the ali file if
+ pragma Detect_Blocking is active.
+
+ * lib-writ.ads: Document the Detect_Blocking flag (DB) in ali files.
+
+ * ali.adb (Scan_ALI): Set the Detect_Blocking value to true if the flag
+ DB is found in the ali file. Any unit compiled with pragma
+ Detect_Blocking active forces its effect in the whole partition.
+
+ * a-retide.adb (Delay_Until): Raise Program_Error if pragma
+ Detect_Blocking is active and delay is called from a protected
+ operation.
+
+ * bindgen.adb (Gen_Adainit_Ada): When generating the call to
+ __gnat_set_globals, pass 1 as Detect_Blocking parameter if pragma
+ Detect_Blocking is active (0 otherwise).
+ (Gen_Adainit_C): When generating the call to __gnat_set_globals, pass 1
+ as Detect_Blocking parameter if pragma Detect_Blocking is active (0
+ otherwise).
+
+2004-09-09 Thomas Quinot <quinot@act-europe.fr>
+
+ * gnat_rm.texi: Rename GNAT.Perfect_Hash.Generators to
+ GNAT.Perfect_Hash_Generators, and remove the empty GNAT.Perfect_Hash
+ package.
+
+ * s-parint.ads, s-parint.adb (Get_RAS_Info): New subprogram.
+ (Register_Receiving_Stub): Add Subp_Info formal parameter.
+ Update API in placeholder implemetation of s-parint to reflect changes
+ in distribution runtime library.
+
+ * sem_ch3.adb (Expand_Derived_Record): Rename to
+ Expand_Record_Extension.
+
+ * sem_disp.adb (Check_Controlling_Formals): Improve error message for
+ primitive operations of potentially distributed object types that have
+ non-controlling anonymous access formals.
+
+ * sem_dist.ads, sem_dist.adb (Build_RAS_Primitive_Specification): New
+ subprogram.
+ New implementation of expansion for remote access-to-subprogram types,
+ based on the RACW infrastructure.
+ This version of sem_dist is compatible with PolyORB/DSA as well as
+ GLADE.
+
+ * sem_prag.adb (Analyze_Pragma, case Pragma_Asynchronous): For a pragma
+ Asynchrronous that applies to a remote access-to-subprogram type, mark
+ the underlying RACW type as asynchronous.
+
+ * link.c: FreeBSD uses GNU ld: set __gnat_objlist_file_supported and
+ __gnat_using_gnu_linker to 1.
+
+ * Makefile.rtl, impunit.adb, g-perhas.ads, g-pehage.ads,
+ g-pehage.adb: Rename GNAT.Perfect_Hash.Generators to
+ GNAT.Perfect_Hash_Generators, and remove the empty
+ GNAT.Perfect_Hash package.
+
+ * atree.adb: Minor reformatting
+
+ * exp_ch3.adb (Expand_Derived_Record): Rename to
+ Expand_Record_Extension.
+ (Build_Record_Init_Proc.Build_Assignment): The default expression in
+ a component declaration must remain attached at that point in the
+ tree so New_Copy_Tree copies it if the enclosing record type is derived.
+ It is therefore necessary to take a copy of the expression when building
+ the corresponding assignment statement in the init proc.
+ As a side effect, in the case of a derived record type, we now see the
+ original expression, without any rewriting that could have occurred
+ during expansion of the ancestor type's init proc, and we do not need
+ to go back to Original_Node.
+
+ * exp_ch3.ads (Expand_Derived_Record): Rename to
+ Expand_Record_Extension.
+
+ * exp_dist.ads, exp_dist.adb (Underlying_RACW_Type): New subprogram.
+ Returns the RACW type used to implement a remote access-to-subprogram
+ type.
+ (Add_RAS_Proxy_And_Analyze, Build_Remote_Subprogram_Proxy_Type):
+ New subprograms. Used to create a proxy tagged object for a remote
+ subprogram. The proxy object is used as the designated object
+ for RAS values on the same partition (unless All_Calls_Remote applies).
+ (Build_Get_Unique_RP_Call): New subprogram. Build a call to
+ System.Partition_Interface.Get_Unique_Remote_Pointer.
+ (Add_RAS_Access_TSS, Add_RAS_Dereference_TSS):
+ Renamed from Add_RAS_*_Attribute.
+ (Add_Receiving_Stubs_To_Declarations): Generate a table of local
+ subprograms.
+ New implementation of expansion for remote access-to-subprogram types,
+ based on the RACW infrastructure.
+
+ * exp_dist.ads (Copy_Specification): Update comment to note that this
+ function can copy the specification from either a subprogram
+ specification or an access-to-subprogram type definition.
+
+2004-09-09 Ed Schonberg <schonberg@gnat.com>
+
+ * sem_type.adb (Disambiguate): Handle properly an accidental ambiguity
+ in an instance, between an explicit subprogram an one inherited from a
+ type derived from an actual.
+
+ * exp_ch6.adb (Expand_N_Subprogram_Body): If polling is enabled, do not
+ add a polling call if the subprogram is to be inlined by the back-end,
+ to avoid repeated calls with multiple inlinings.
+
+ * checks.adb (Apply_Alignment_Check): If the expression in the address
+ clause is a call whose name is not a static entity (e.g. a dispatching
+ call), treat as dynamic.
+
+2004-09-09 Robert Dewar <dewar@gnat.com>
+
+ * g-trasym.ads: Minor reformatting
+
+ * exp_ch3.adb (Component_Needs_Simple_Initialization): Don't except
+ packed arrays, since unused bits are expected to be zero for a
+ comparison.
+
+2004-09-09 Eric Botcazou <ebotcazou@act-europe.fr>
+
+ * exp_pakd.ads: Fix an inacurracy and a couple of typos in the head
+ comment.
+
+2004-09-09 Pascal Obry <obry@gnat.com>
+
+ * mdll.ads, mdll.adb (Build_Dynamic_Library): New parameter Map_File to
+ enable map file generation. Add the right option to generate the map
+ file if Map_File is set to True.
+
+ * gnatdll.adb (Gen_Map_File): New variable.
+ (Syntax): Add info about new -m (Map_File) option.
+ (Parse_Command_Line): Add support for -m option.
+ (gnatdll): Pass Gen_Map_File to Build_Dynamic_Library calls.
+ Minor reformatting.
+
+2004-09-09 Laurent Pautet <pautet@act-europe.fr>
+
+ * gnatls.adb: Add a very verbose mode -V. Such mode is required by the
+ new gnatdist implementation.
+ Define a subpackage isolating the output routines specific to this
+ verbose mode.
+
+2004-09-09 Joel Brobecker <brobecker@gnat.com>
+
+ * Makefile.rtl: (GNATRTL_NONTASKING_OBJS): Add g-dynhta.
+
+ * gnat_ugn.texi (Main Subprograms): Fix typo. Deduced, not deducted.
+
+2004-09-09 Cyrille Comar <comar@act-europe.fr>
+
+ * opt.adb (Set_Opt_Config_Switches): Use Ada_Version_Runtime to compile
+ internal unit.
+
+ * opt.ads: Add Ada_Version_Runtime constant used to decide which
+ version of the language is used to compile the run time.
+
+2004-09-09 Arnaud Charlet <charlet@act-europe.fr>
+
+ * sem_util.adb (Requires_Transient_Scope): Re-enable handling
+ of variable length temporaries for function return now that the
+ back-end and gigi support it.
+
2004-09-01 Richard Kenner <kenner@vlsi1.ultra.nyu.edu>
* misc.c (gnat_print_type): Use TYPE_RM_SIZE_NUM.
gnatmake.o gnatvsn.o hostparm.o interfac.o i-c.o i-cstrin.o krunch.o lib.o \
make.o makeusg.o makeutl.o mlib.o mlib-fil.o mlib-prj.o mlib-tgt.o mlib-utl.o \
namet.o nlists.o opt.o osint.o osint-m.o output.o \
- prj.o prj-attr.o prj-com.o prj-dect.o prj-env.o prj-err.o prj-ext.o prj-nmsc.o \
+ prj.o prj-attr.o prj-attr-pm.o prj-com.o prj-dect.o prj-env.o prj-err.o prj-ext.o prj-nmsc.o \
prj-pars.o prj-part.o prj-proc.o prj-strt.o prj-tree.o prj-util.o \
rident.o s-exctab.o s-secsta.o s-stalib.o s-stoele.o \
scans.o scng.o sdefault.o sfn_scan.o s-purexc.o s-htable.o \
g-diopit$(objext) \
g-dirope$(objext) \
g-dyntab$(objext) \
+ g-dynhta$(objext) \
g-except$(objext) \
g-excact$(objext) \
g-exctra$(objext) \
g-memdum$(objext) \
g-moreex$(objext) \
g-os_lib$(objext) \
- g-perhas$(objext) \
g-pehage$(objext) \
g-regexp$(objext) \
g-regpat$(objext) \
end if;
-- Check for Day value too large (one might expect mktime to do this
- -- check, as well as the basi checks we did with 'Valid, but it seems
+ -- check, as well as the basic checks we did with 'Valid, but it seems
-- that at least on some systems, this built-in check is too weak).
if Day > Days_In_Month (Month)
with GNAT.Directory_Operations; use GNAT.Directory_Operations;
with GNAT.OS_Lib; use GNAT.OS_Lib;
with GNAT.Regexp; use GNAT.Regexp;
+-- ??? Ada units cannot depend on GNAT units
with System;
package body Ada.Directories is
type Search_Data is record
- Is_Valid : Boolean := False;
- Name : Ada.Strings.Unbounded.Unbounded_String;
- Pattern : Regexp;
- Filter : Filter_Type;
- Dir : Dir_Type;
+ Is_Valid : Boolean := False;
+ Name : Ada.Strings.Unbounded.Unbounded_String;
+ Pattern : Regexp;
+ Filter : Filter_Type;
+ Dir : Dir_Type;
Entry_Fetched : Boolean := False;
Dir_Entry : Directory_Entry_Type;
end record;
+ -- Comment required ???
Empty_String : constant String := (1 .. 0 => ASCII.NUL);
+ -- Comment required ???
procedure Free is new Ada.Unchecked_Deallocation (Search_Data, Search_Ptr);
Name : String;
Extension : String := "") return String
is
- Result : String (1 ..
- Containing_Directory'Length +
- Name'Length + Extension'Length + 2);
+ Result : String (1 .. Containing_Directory'Length +
+ Name'Length + Extension'Length + 2);
Last : Natural;
begin
begin
-- First, the invalid cases
- if (not Is_Valid_Path_Name (Source_Name)) or else
- (not Is_Valid_Path_Name (Target_Name)) or else
- (not Is_Regular_File (Source_Name))
+ if not Is_Valid_Path_Name (Source_Name)
+ or else not Is_Valid_Path_Name (Target_Name)
+ or else not Is_Regular_File (Source_Name)
then
raise Name_Error;
-----------------------
function Current_Directory return String is
- begin
+
-- The implementation uses GNAT.Directory_Operations.Get_Current_Dir
- return Get_Current_Dir;
+ Cur : constant String := Get_Current_Dir;
+
+ begin
+ if Cur'Length > 1 and then Cur (Cur'Last) = Dir_Separator then
+ return Cur (1 .. Cur'Last - 1);
+ else
+ return Cur;
+ end if;
end Current_Directory;
----------------------
procedure Delete_Directory (Directory : String) is
begin
- -- First, the invalid case
+ -- First, the invalid cases
if not Is_Valid_Path_Name (Directory) then
raise Name_Error;
+ elsif not Is_Directory (Directory) then
+ raise Name_Error;
+
else
-- The implementation uses GNAT.Directory_Operations.Remove_Dir
procedure Delete_Tree (Directory : String) is
begin
- -- First, the invalid case
+ -- First, the invalid cases
if not Is_Valid_Path_Name (Directory) then
raise Name_Error;
+ elsif not Is_Directory (Directory) then
+ raise Name_Error;
+
else
-- The implementation uses GNAT.Directory_Operations.Remove_Dir
raise Name_Error;
else
- -- Look fir the first dot that is not followed by a directory
- -- separator.
+ -- Look for first dot that is not followed by a directory separator
for Pos in reverse Name'Range loop
- -- If a directory separator is found before a dot, there is no
- -- extension.
+ -- If a directory separator is found before a dot, there
+ -- is no extension.
if Name (Pos) = Dir_Separator then
return Empty_String;
begin
Result := Name (Pos + 1 .. Name'Last);
return Result;
+ -- This should be done with a subtype conversion, avoiding
+ -- the unnecessary junk copy ???
end;
end if;
end loop;
procedure Fetch_Next_Entry (Search : Search_Type) is
Name : String (1 .. 255);
Last : Natural;
- Kind : File_Kind;
+
+ Kind : File_Kind := Ordinary_File;
+ -- Initialized to avoid a compilation warning
begin
-- Search.Value.Is_Valid is always True when Fetch_Next_Entry is called
Compose
(To_String
(Search.Value.Name), Name (1 .. Last));
- Found : Boolean := False;
+ Found : Boolean := False;
begin
if File_Exists (Full_Name) then
begin
C_Name (1 .. Name'Length) := Name;
C_Name (C_Name'Last) := ASCII.NUL;
-
return C_File_Exists (C_Name (1)'Address) = 1;
end File_Exists;
raise Name_Error;
else
- -- Build the return value with lower bound 1.
- -- Use GNAT.OS_Lib.Normalize_Pathname.
+ -- Build the return value with lower bound 1
+
+ -- Use GNAT.OS_Lib.Normalize_Pathname
declare
Value : constant String := Normalize_Pathname (Name);
begin
Result := Value;
return Result;
+ -- Should use subtype conversion, not junk copy ???
end;
end if;
end Full_Name;
raise Use_Error;
else
- -- The implemewntation uses GNAT.OS_Lib.Rename_File
+ -- The implementation uses GNAT.OS_Lib.Rename_File
Rename_File (Old_Name, New_Name, Success);
raise Name_Error;
else
- -- Build the value to return with lower bound 1.
- -- The implementation uses GNAT.Directory_Operations.Base_Name.
+ -- Build the value to return with lower bound 1
+
+ -- The implementation uses GNAT.Directory_Operations.Base_Name
declare
- Value : constant String :=
+ Value : constant String :=
GNAT.Directory_Operations.Base_Name (Name);
Result : String (1 .. Value'Length);
begin
Result := Value;
return Result;
+ -- Should use subtype conversion instead of junk copy ???
end;
end if;
end Simple_Name;
function Size (Name : String) return File_Size is
C_Name : String (1 .. Name'Length + 1);
- function C_Size (Name : System.Address) return File_Size;
+ function C_Size (Name : System.Address) return Long_Integer;
pragma Import (C, C_Size, "__gnat_named_file_length");
begin
else
C_Name (1 .. Name'Length) := Name;
C_Name (C_Name'Last) := ASCII.NUL;
- return C_Size (C_Name'Address);
+ return File_Size (C_Size (C_Name'Address));
end if;
end Size;
package Ada.Directories is
+ pragma Ada_05;
+ -- To be removed later ???
+
-----------------------------------
-- Directory and File Operations --
-----------------------------------
Is_Valid : Boolean := False;
Simple : Ada.Strings.Unbounded.Unbounded_String;
Full : Ada.Strings.Unbounded.Unbounded_String;
- Kind : File_Kind;
+ Kind : File_Kind := Ordinary_File;
end record;
-- The type Search_Data is defined in the body, so that the spec does not
pragma Export (C, Rcheck_28, "__gnat_rcheck_28");
pragma Export (C, Rcheck_29, "__gnat_rcheck_29");
+ pragma No_Return (Rcheck_00);
+ pragma No_Return (Rcheck_01);
+ pragma No_Return (Rcheck_02);
+ pragma No_Return (Rcheck_03);
+ pragma No_Return (Rcheck_04);
+ pragma No_Return (Rcheck_05);
+ pragma No_Return (Rcheck_06);
+ pragma No_Return (Rcheck_07);
+ pragma No_Return (Rcheck_08);
+ pragma No_Return (Rcheck_09);
+ pragma No_Return (Rcheck_10);
+ pragma No_Return (Rcheck_11);
+ pragma No_Return (Rcheck_12);
+ pragma No_Return (Rcheck_13);
+ pragma No_Return (Rcheck_14);
+ pragma No_Return (Rcheck_15);
+ pragma No_Return (Rcheck_16);
+ pragma No_Return (Rcheck_17);
+ pragma No_Return (Rcheck_18);
+ pragma No_Return (Rcheck_19);
+ pragma No_Return (Rcheck_20);
+ pragma No_Return (Rcheck_21);
+ pragma No_Return (Rcheck_22);
+ pragma No_Return (Rcheck_23);
+ pragma No_Return (Rcheck_24);
+ pragma No_Return (Rcheck_25);
+ pragma No_Return (Rcheck_26);
+ pragma No_Return (Rcheck_27);
+ pragma No_Return (Rcheck_28);
+ pragma No_Return (Rcheck_29);
+
---------------------------------------------
-- Reason Strings for Run-Time Check Calls --
---------------------------------------------
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2004, 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- --
-- --
------------------------------------------------------------------------------
+with Ada.Exceptions;
+-- Used for Raise_Exception
+
+with System.Tasking;
+-- Used for Task_Id
+
with System.Task_Primitives.Operations;
-- Used for Timed_Delay
+-- Self
package body Ada.Real_Time.Delays is
package STPO renames System.Task_Primitives.Operations;
+ ----------------
+ -- Local Data --
+ ----------------
+
Absolute_RT : constant := 2;
-----------------
-----------------
procedure Delay_Until (T : Time) is
+ Self_Id : constant System.Tasking.Task_Id := STPO.Self;
+
begin
- STPO.Timed_Delay (STPO.Self, To_Duration (T), Absolute_RT);
+ -- If pragma Detect_Blocking is active, Program_Error must be
+ -- raised if this potentially blocking operation is called from a
+ -- protected action.
+
+ if System.Tasking.Detect_Blocking
+ and then Self_Id.Common.Protected_Action_Nesting > 0
+ then
+ Ada.Exceptions.Raise_Exception
+ (Program_Error'Identity, "potentially blocking operation");
+ else
+ STPO.Timed_Delay (Self_Id, To_Duration (T), Absolute_RT);
+ end if;
end Delay_Until;
-----------------
#define TYPE_RETURNS_BY_REF_P(NODE) \
TYPE_LANG_FLAG_4 (FUNCTION_TYPE_CHECK (NODE))
+/* For FUNCTION_TYPEs, nonzero if function returns by being passed a pointer
+ to a place to store its result. */
+#define TYPE_RETURNS_BY_TARGET_PTR_P(NODE) \
+ TYPE_LANG_FLAG_5 (FUNCTION_TYPE_CHECK (NODE))
+
/* For VOID_TYPE, ENUMERAL_TYPE, UNION_TYPE, and RECORD_TYPE, nonzero if this
is a dummy type, made to correspond to a private or incomplete type. */
#define TYPE_DUMMY_P(NODE) TYPE_LANG_FLAG_4 (NODE)
Checkc ('E');
ALIs.Table (Id).Compile_Errors := True;
+ -- Processing for DB
+
+ elsif C = 'D' then
+ Checkc ('B');
+ Detect_Blocking := True;
+
-- Processing for FD/FG/FI
elsif C = 'F' then
Set_Field5
(New_Node, Copy_Field_With_Replacement (Field5 (New_Node)));
-
-- Adjust Sloc of new node if necessary
if New_Sloc /= No_Location then
-- Num_Interrupt_States : Integer;
-- Unreserve_All_Interrupts : Integer;
-- Exception_Tracebacks : Integer;
- -- Zero_Cost_Exceptions : Integer);
+ -- Zero_Cost_Exceptions : Integer;
+ -- Detect_Blocking : Integer);
-- Main_Priority is the priority value set by pragma Priority in the
-- main program. If no such pragma is present, the value is -1.
-- this partition, and to zero if longjmp/setjmp exceptions are used.
-- the use of zero
+ -- Detect_Blocking indicates whether pragma Detect_Blocking is
+ -- active or not. A value of zero indicates that the pragma is not
+ -- present, while a value of 1 signals its presence in the
+ -- partition.
+
-----------------------
-- Local Subprograms --
-----------------------
WBI (" Locking_Policy : Character;");
WBI (" Queuing_Policy : Character;");
WBI (" Task_Dispatching_Policy : Character;");
+
WBI (" Restrictions : System.Address;");
WBI (" Interrupt_States : System.Address;");
WBI (" Num_Interrupt_States : Integer;");
WBI (" Unreserve_All_Interrupts : Integer;");
WBI (" Exception_Tracebacks : Integer;");
- WBI (" Zero_Cost_Exceptions : Integer);");
+ WBI (" Zero_Cost_Exceptions : Integer;");
+ WBI (" Detect_Blocking : Integer);");
WBI (" pragma Import (C, Set_Globals, ""__gnat_set_globals"");");
-- Import entry point for elaboration time signal handler
Set_String ("0");
end if;
+ Set_String (",");
+ Write_Statement_Buffer;
+
+ Set_String (" Detect_Blocking => ");
+
+ if Detect_Blocking then
+ Set_Int (1);
+ else
+ Set_Int (0);
+ end if;
+
Set_String (");");
Write_Statement_Buffer;
Set_String (" ");
Set_Int (Boolean'Pos (Zero_Cost_Exceptions_Specified));
- Set_String (");");
+ Set_String (",");
Tab_To (24);
Set_String ("/* Zero_Cost_Exceptions */");
Write_Statement_Buffer;
+
+ Set_String (" ");
+
+ if Detect_Blocking then
+ Set_Int (1);
+ else
+ Set_Int (0);
+ end if;
+
+ Set_String (");");
+ Tab_To (24);
+ Set_String ("/* Detect_Blocking */");
+ Write_Statement_Buffer;
WBI ("");
-- Install elaboration time signal handler
WBI ("extern void __gnat_set_globals");
WBI (" (int, int, char, char, char, char,");
WBI (" const char *, const char *,");
- WBI (" int, int, int, int);");
+ WBI (" int, int, int, int, int);");
WBI ("extern void " & Ada_Final_Name.all & " (void);");
WBI ("extern void " & Ada_Init_Name.all & " (void);");
WBI ("extern void system__standard_library__adafinal (void);");
Expr := Expression (Expr);
elsif Nkind (Expr) = N_Function_Call
+ and then Is_Entity_Name (Name (Expr))
and then Is_RTE (Entity (Name (Expr)), RE_To_Address)
then
Expr := First (Parameter_Associations (Expr));
gnu_ret = build_cst_from_int (comp_type, First);
if (First < 0)
for (Idx++, Length--; Length; Idx++, Length--)
- gnu_ret = fold (build (MINUS_EXPR, comp_type,
- fold (build (MULT_EXPR, comp_type,
- gnu_ret, gnu_base)),
- build_cst_from_int (comp_type,
- Udigits_Ptr[Idx])));
+ gnu_ret = fold (build2 (MINUS_EXPR, comp_type,
+ fold (build2 (MULT_EXPR, comp_type,
+ gnu_ret, gnu_base)),
+ build_cst_from_int (comp_type,
+ Udigits_Ptr[Idx])));
else
for (Idx++, Length--; Length; Idx++, Length--)
- gnu_ret = fold (build (PLUS_EXPR, comp_type,
- fold (build (MULT_EXPR, comp_type,
- gnu_ret, gnu_base)),
- build_cst_from_int (comp_type,
- Udigits_Ptr[Idx])));
+ gnu_ret = fold (build2 (PLUS_EXPR, comp_type,
+ fold (build2 (MULT_EXPR, comp_type,
+ gnu_ret, gnu_base)),
+ build_cst_from_int (comp_type,
+ Udigits_Ptr[Idx])));
}
gnu_ret = convert (type, gnu_ret);
static tree elaborate_expression_1 (Node_Id, Entity_Id, tree, tree,
bool, bool);
static tree make_packable_type (tree);
-static tree maybe_pad_type (tree, tree, unsigned int, Entity_Id, const char *,
- bool, bool, bool);
static tree gnat_to_gnu_field (Entity_Id, tree, int, bool);
static void components_to_record (tree, Node_Id, tree, int, bool, tree *,
bool, bool);
gnu_expr = gnu_address;
else
gnu_expr
- = build (COMPOUND_EXPR, gnu_type,
- build_binary_op
- (MODIFY_EXPR, NULL_TREE,
- build_unary_op (INDIRECT_REF, NULL_TREE,
- gnu_address),
- gnu_expr),
- gnu_address);
+ = build2 (COMPOUND_EXPR, gnu_type,
+ build_binary_op
+ (MODIFY_EXPR, NULL_TREE,
+ build_unary_op (INDIRECT_REF, NULL_TREE,
+ gnu_address),
+ gnu_expr),
+ gnu_address);
}
/* If it has an address clause and we are not defining it, mark it
{
TYPE_MODULAR_P (gnu_type) = 1;
SET_TYPE_MODULUS (gnu_type, gnu_modulus);
- gnu_high = fold (build (MINUS_EXPR, gnu_type, gnu_modulus,
- convert (gnu_type, integer_one_node)));
+ gnu_high = fold (build2 (MINUS_EXPR, gnu_type, gnu_modulus,
+ convert (gnu_type, integer_one_node)));
}
/* If we have to set TYPE_PRECISION different from its natural value,
/* Build a reference to the template from a PLACEHOLDER_EXPR that
is the fat pointer. This will be used to access the individual
fields once we build them. */
- tem = build (COMPONENT_REF, gnu_ptr_template,
- build (PLACEHOLDER_EXPR, gnu_fat_type),
- TREE_CHAIN (TYPE_FIELDS (gnu_fat_type)), NULL_TREE);
+ tem = build3 (COMPONENT_REF, gnu_ptr_template,
+ build0 (PLACEHOLDER_EXPR, gnu_fat_type),
+ TREE_CHAIN (TYPE_FIELDS (gnu_fat_type)), NULL_TREE);
gnu_template_reference
= build_unary_op (INDIRECT_REF, gnu_template_type, tem);
TREE_READONLY (gnu_template_reference) = 1;
/* We can't use build_component_ref here since the template
type isn't complete yet. */
- gnu_min = build (COMPONENT_REF, gnu_ind_subtype,
- gnu_template_reference, gnu_min_field, NULL_TREE);
- gnu_max = build (COMPONENT_REF, gnu_ind_subtype,
- gnu_template_reference, gnu_max_field, NULL_TREE);
+ gnu_min = build3 (COMPONENT_REF, gnu_ind_subtype,
+ gnu_template_reference, gnu_min_field,
+ NULL_TREE);
+ gnu_max = build3 (COMPONENT_REF, gnu_ind_subtype,
+ gnu_template_reference, gnu_max_field,
+ NULL_TREE);
TREE_READONLY (gnu_min) = TREE_READONLY (gnu_max) = 1;
/* Make a range type with the new ranges, but using
&& TREE_CODE (gnu_max) == INTEGER_CST
&& TREE_OVERFLOW (gnu_min) && TREE_OVERFLOW (gnu_max)
&& (!TREE_OVERFLOW
- (fold (build (MINUS_EXPR, gnu_index_subtype,
- TYPE_MAX_VALUE (gnu_index_subtype),
- TYPE_MIN_VALUE (gnu_index_subtype))))))
+ (fold (build2 (MINUS_EXPR, gnu_index_subtype,
+ TYPE_MAX_VALUE (gnu_index_subtype),
+ TYPE_MIN_VALUE (gnu_index_subtype))))))
TREE_OVERFLOW (gnu_min) = TREE_OVERFLOW (gnu_max)
= TREE_CONSTANT_OVERFLOW (gnu_min)
= TREE_CONSTANT_OVERFLOW (gnu_max) = 0;
COMPONENT_REF which will be filled in below, once
the parent type can be safely built. */
- gnu_get_parent = build (COMPONENT_REF, void_type_node,
- build (PLACEHOLDER_EXPR, gnu_type),
- build_decl (FIELD_DECL, NULL_TREE,
- NULL_TREE),
- NULL_TREE);
+ gnu_get_parent = build3 (COMPONENT_REF, void_type_node,
+ build0 (PLACEHOLDER_EXPR, gnu_type),
+ build_decl (FIELD_DECL, NULL_TREE,
+ NULL_TREE),
+ NULL_TREE);
if (Has_Discriminants (gnat_entity))
for (gnat_field = First_Stored_Discriminant (gnat_entity);
if (Present (Corresponding_Discriminant (gnat_field)))
save_gnu_tree
(gnat_field,
- build (COMPONENT_REF,
- get_unpadded_type (Etype (gnat_field)),
- gnu_get_parent,
- gnat_to_gnu_entity (Corresponding_Discriminant
- (gnat_field),
+ build3 (COMPONENT_REF,
+ get_unpadded_type (Etype (gnat_field)),
+ gnu_get_parent,
+ gnat_to_gnu_entity (Corresponding_Discriminant
+ (gnat_field),
NULL_TREE, 0),
- NULL_TREE),
+ NULL_TREE),
true);
gnu_parent = gnat_to_gnu_type (Parent_Subtype (gnat_entity));
corresponding GNAT defining identifier. Then add to the
list of fields. */
save_gnu_tree (gnat_field,
- build (COMPONENT_REF, TREE_TYPE (gnu_field),
- build (PLACEHOLDER_EXPR,
- DECL_CONTEXT (gnu_field)),
- gnu_field, NULL_TREE),
+ build3 (COMPONENT_REF, TREE_TYPE (gnu_field),
+ build0 (PLACEHOLDER_EXPR,
+ DECL_CONTEXT (gnu_field)),
+ gnu_field, NULL_TREE),
true);
TREE_CHAIN (gnu_field) = gnu_field_list;
bool volatile_flag = No_Return (gnat_entity);
bool returns_by_ref = false;
bool returns_unconstrained = false;
+ bool returns_by_target_ptr = false;
tree gnu_ext_name = create_concat_name (gnat_entity, 0);
bool has_copy_in_out = false;
int parmnum;
|| Has_Foreign_Convention (gnat_entity)))
gnu_return_type = TREE_TYPE (TYPE_FIELDS (gnu_return_type));
- /* Look at all our parameters and get the type of
- each. While doing this, build a copy-out structure if
- we need one. */
+ /* If the return type is unconstrained, that means it must have a
+ maximum size. We convert the function into a procedure and its
+ caller will pass a pointer to an object of that maximum size as the
+ first parameter when we call the function. */
+ if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_return_type)))
+ {
+ returns_by_target_ptr = true;
+ gnu_param_list
+ = create_param_decl (get_identifier ("TARGET"),
+ build_reference_type (gnu_return_type),
+ true);
+ gnu_return_type = void_type_node;
+ }
/* If the return type has a size that overflows, we cannot have
a function that returns that type. This usage doesn't make
TYPE_SIZE (gnu_return_type) = bitsize_zero_node;
TYPE_SIZE_UNIT (gnu_return_type) = size_zero_node;
TYPE_MAIN_VARIANT (gnu_return_type) = gnu_return_type;
- TYPE_NEXT_VARIANT (gnu_return_type) = 0;
+ TYPE_NEXT_VARIANT (gnu_return_type) = NULL_TREE;
}
+ /* Look at all our parameters and get the type of
+ each. While doing this, build a copy-out structure if
+ we need one. */
+
for (gnat_param = First_Formal (gnat_entity), parmnum = 0;
Present (gnat_param);
gnat_param = Next_Formal_With_Extras (gnat_param), parmnum++)
= create_subprog_type (gnu_return_type, gnu_param_list,
gnu_return_list, returns_unconstrained,
returns_by_ref,
- Function_Returns_With_DSP (gnat_entity));
+ Function_Returns_With_DSP (gnat_entity),
+ returns_by_target_ptr);
/* A subprogram (something that doesn't return anything) shouldn't
be considered Pure since there would be no reason for such a
here. We have to hope it will be at the highest level of the
expression in these cases. */
if (TREE_CODE (gnu_expr) == FIELD_DECL)
- gnu_expr = build (COMPONENT_REF, TREE_TYPE (gnu_expr),
- build (PLACEHOLDER_EXPR, DECL_CONTEXT (gnu_expr)),
- gnu_expr, NULL_TREE);
+ gnu_expr = build3 (COMPONENT_REF, TREE_TYPE (gnu_expr),
+ build0 (PLACEHOLDER_EXPR, DECL_CONTEXT (gnu_expr)),
+ gnu_expr, NULL_TREE);
/* If GNU_EXPR is neither a placeholder nor a constant, nor a variable
that is a constant, make a variable that is initialized to contain the
make_aligning_type (tree type, int align, tree size)
{
tree record_type = make_node (RECORD_TYPE);
- tree place = build (PLACEHOLDER_EXPR, record_type);
+ tree place = build0 (PLACEHOLDER_EXPR, record_type);
tree size_addr_place = convert (sizetype,
build_unary_op (ADDR_EXPR, NULL_TREE,
place));
set to its TYPE_SIZE; otherwise, it's set to the RM_Size of the original
type. */
-static tree
+tree
maybe_pad_type (tree type, tree size, unsigned int align,
Entity_Id gnat_entity, const char *name_trailer,
bool is_user_type, bool definition, bool same_rm_size)
temp = build1 (NEGATE_EXPR, bitsizetype, negative_size);
if (adjust)
- temp = build (MINUS_EXPR, bitsizetype, temp, bitsize_one_node);
+ temp = build2 (MINUS_EXPR, bitsizetype, temp, bitsize_one_node);
return annotate_value (temp);
}
(T : Entity_Id) return Boolean;
-- Determines if a component needs simple initialization, given its
-- type T. This is the same as Needs_Simple_Initialization except
- -- for the following differences. The types Tag and Vtable_Ptr,
- -- which are access types which would normally require simple
- -- initialization to null, do not require initialization as
- -- components, since they are explicitly initialized by other
- -- means. The other relaxation is for packed bit arrays that are
- -- associated with a modular type, which in some cases require
- -- zero initialization to properly support comparisons, except
- -- that comparison of such components always involves an explicit
- -- selection of only the component's specific bits (whether or not
- -- there are adjacent components or gaps), so zero initialization
- -- is never needed for components.
+ -- for the following difference: the types Tag and Vtable_Ptr, which
+ -- are access types which would normally require simple initialization
+ -- to null, do not require initialization as components, since they
+ -- are explicitly initialized by other means.
procedure Constrain_Array
(SI : Node_Id;
Selector_Name => New_Occurrence_Of (Id, Loc));
Set_Assignment_OK (Lhs);
- -- Case of an access attribute applied to the current
- -- instance. Replace the reference to the type by a
- -- reference to the actual object. (Note that this
- -- handles the case of the top level of the expression
- -- being given by such an attribute, but doesn't cover
- -- uses nested within an initial value expression.
- -- Nested uses are unlikely to occur in practice,
- -- but theoretically possible. It's not clear how
- -- to handle them without fully traversing the
- -- expression. ???)
+ -- Case of an access attribute applied to the current instance.
+ -- Replace the reference to the type by a reference to the actual
+ -- object. (Note that this handles the case of the top level of
+ -- the expression being given by such an attribute, but does not
+ -- cover uses nested within an initial value expression. Nested
+ -- uses are unlikely to occur in practice, but are theoretically
+ -- possible. It is not clear how to handle them without fully
+ -- traversing the expression. ???
if Kind = N_Attribute_Reference
and then (Attribute_Name (N) = Name_Unchecked_Access
Attribute_Name => Name_Unrestricted_Access);
end if;
- -- For a derived type the default value is copied from the component
- -- declaration of the parent. In the analysis of the init_proc for
- -- the parent the default value may have been expanded into a local
- -- variable, which is of course not usable here. We must copy the
- -- original expression and reanalyze.
-
- if Nkind (Exp) = N_Identifier
- and then not Comes_From_Source (Exp)
- and then Analyzed (Exp)
- and then not In_Open_Scopes (Scope (Entity (Exp)))
- and then Nkind (Original_Node (Exp)) = N_Aggregate
- then
- Exp := New_Copy_Tree (Original_Node (Exp));
- end if;
-
-- Ada 2005 (AI-231): Generate conversion to the null-excluding
- -- type to force the corresponding run-time check
+ -- type to force the corresponding run-time check.
if Ada_Version >= Ada_05
and then Can_Never_Be_Null (Etype (Id)) -- Lhs
Analyze_And_Resolve (Exp, Etype (Id));
end if;
+ -- Take a copy of Exp to ensure that later copies of this
+ -- component_declaration in derived types see the original tree,
+ -- not a node rewritten during expansion of the init_proc.
+
+ Exp := New_Copy_Tree (Exp);
+
Res := New_List (
Make_Assignment_Statement (Loc,
Name => Lhs,
return
Needs_Simple_Initialization (T)
and then not Is_RTE (T, RE_Tag)
- and then not Is_RTE (T, RE_Vtable_Ptr)
- and then not Is_Bit_Packed_Array (T);
+ and then not Is_RTE (T, RE_Vtable_Ptr);
end Component_Needs_Simple_Initialization;
---------------------
end if;
end Check_Stream_Attributes;
- ---------------------------
- -- Expand_Derived_Record --
- ---------------------------
+ -----------------------------
+ -- Expand_Record_Extension --
+ -----------------------------
-- Add a field _parent at the beginning of the record extension. This is
-- used to implement inheritance. Here are some examples of expansion:
-- D : Int;
-- end;
- procedure Expand_Derived_Record (T : Entity_Id; Def : Node_Id) is
+ procedure Expand_Record_Extension (T : Entity_Id; Def : Node_Id) is
Indic : constant Node_Id := Subtype_Indication (Def);
Loc : constant Source_Ptr := Sloc (Def);
Rec_Ext_Part : Node_Id := Record_Extension_Part (Def);
List_Constr : constant List_Id := New_List;
begin
- -- Expand_Tagged_Extension is called directly from the semantics, so
+ -- Expand_Record_Extension is called directly from the semantics, so
-- we must check to see whether expansion is active before proceeding
if not Expander_Active then
end if;
Analyze (Comp_Decl);
- end Expand_Derived_Record;
+ end Expand_Record_Extension;
------------------------------------
-- Expand_N_Full_Type_Declaration --
elsif Is_Access_Type (T)
or else (Init_Or_Norm_Scalars and then (Is_Scalar_Type (T)))
-
or else (Is_Bit_Packed_Array (T)
and then Is_Modular_Integer_Type (Packed_Array_Type (T)))
then
-- the master for that access type, now that it is known to denote an
-- object with tasks.
- procedure Expand_Derived_Record (T : Entity_Id; Def : Node_Id);
+ procedure Expand_Record_Extension (T : Entity_Id; Def : Node_Id);
-- Add a field _parent in the extension part of the record.
procedure Build_Discr_Checking_Funcs (N : Node_Id);
-- Expand_N_Subprogram_Body --
------------------------------
- -- Add poll call if ATC polling is enabled
+ -- Add poll call if ATC polling is enabled, unless the body will be
+ -- inlined by the back-end.
-- Add return statement if last statement in body is not a return
-- statement (this makes things easier on Gigi which does not want
L := Statements (Handled_Statement_Sequence (N));
end if;
- -- Need poll on entry to subprogram if polling enabled. We only
- -- do this for non-empty subprograms, since it does not seem
- -- necessary to poll for a dummy null subprogram.
-
- if Is_Non_Empty_List (L) then
- Generate_Poll_Call (First (L));
- end if;
-
-- Find entity for subprogram
Body_Id := Defining_Entity (N);
Spec_Id := Body_Id;
end if;
+ -- Need poll on entry to subprogram if polling enabled. We only
+ -- do this for non-empty subprograms, since it does not seem
+ -- necessary to poll for a dummy null subprogram. Do not add polling
+ -- point if calls to this subprogram will be inlined by the back-end,
+ -- to avoid repeated polling points in nested inlinings.
+
+ if Is_Non_Empty_List (L) then
+ if Is_Inlined (Spec_Id)
+ and then Front_End_Inlining
+ and then Optimization_Level > 1
+ then
+ null;
+ else
+ Generate_Poll_Call (First (L));
+ end if;
+ end if;
+
-- If this is a Pure function which has any parameters whose root
-- type is System.Address, reset the Pure indication, since it will
-- likely cause incorrect code to be generated as the parameter is
-- to fake half a derivation to ensure that the subprograms do have
-- the same dispatching table.
+ First_RCI_Subprogram_Id : constant := 2;
+ -- RCI subprograms are numbered starting at 2. The RCI receiver for
+ -- an RCI package can thus identify calls received through remote
+ -- access-to-subprogram dereferences by the fact that they have a
+ -- (primitive) subprogram id of 0, and 1 is used for the internal
+ -- RAS information lookup operation.
+
-----------------------
-- Local subprograms --
-----------------------
+ procedure Add_RAS_Proxy_And_Analyze
+ (Decls : List_Id;
+ Vis_Decl : Node_Id;
+ All_Calls_Remote_E : Entity_Id;
+ Proxy_Object_Addr : out Entity_Id);
+ -- Add the proxy type necessary to call the subprogram declared
+ -- by Vis_Decl through a remote access to subprogram type.
+ -- All_Calls_Remote_E must be Standard_True if a pragma All_Calls_Remote
+ -- applies, Standard_False otherwise. The new proxy type is appended
+ -- to Decls. Proxy_Object_Addr is a constant of type System.Address that
+ -- designates an instance of the proxy object.
+
+ function Build_Remote_Subprogram_Proxy_Type
+ (Loc : Source_Ptr;
+ ACR_Expression : Node_Id) return Node_Id;
+ -- Build and return a tagged record type definition for an RCI
+ -- subprogram proxy type.
+ -- ACR_Expression is use as the initialization value for
+ -- the All_Calls_Remote component.
+
function Get_Subprogram_Id (E : Entity_Id) return Int;
-- Given a subprogram defined in a RCI package, get its subprogram id
-- which will be used for remote calls.
+ function Build_Get_Unique_RP_Call
+ (Loc : Source_Ptr;
+ Pointer : Entity_Id;
+ Stub_Type : Entity_Id) return List_Id;
+ -- Build a call to Get_Unique_Remote_Pointer (Pointer),
+ -- followed by a tag fixup (Get_Unique_Remote_Pointer may have
+ -- changed Pointer'Tag to RACW_Stub_Type'Tag, while the desired
+ -- tag is that of Stub_Type).
+
procedure Build_General_Calling_Stubs
- (Decls : in List_Id;
- Statements : in List_Id;
- Target_Partition : in Entity_Id;
- RPC_Receiver : in Node_Id;
- Subprogram_Id : in Node_Id;
- Asynchronous : in Node_Id := Empty;
- Is_Known_Asynchronous : in Boolean := False;
- Is_Known_Non_Asynchronous : in Boolean := False;
- Is_Function : in Boolean;
- Spec : in Node_Id;
- Object_Type : in Entity_Id := Empty;
- Nod : in Node_Id);
+ (Decls : List_Id;
+ Statements : List_Id;
+ Target_Partition : Entity_Id;
+ RPC_Receiver : Node_Id;
+ Subprogram_Id : Node_Id;
+ Asynchronous : Node_Id := Empty;
+ Is_Known_Asynchronous : Boolean := False;
+ Is_Known_Non_Asynchronous : Boolean := False;
+ Is_Function : Boolean;
+ Spec : Node_Id;
+ Object_Type : Entity_Id := Empty;
+ Nod : Node_Id);
-- Build calling stubs for general purpose. The parameters are:
-- Decls : a place to put declarations
-- Statements : a place to put statements
Dynamically_Asynchronous : Boolean := False;
Stub_Type : Entity_Id := Empty;
Locator : Entity_Id := Empty;
- New_Name : Name_Id := No_Name)
- return Node_Id;
+ New_Name : Name_Id := No_Name) return Node_Id;
-- Build the calling stub for a given subprogram with the subprogram ID
-- being Subp_Id. If Stub_Type is given, then the "addr" field of
-- parameters of this type will be marshalled instead of the object
Dynamically_Asynchronous : Boolean := False;
Stub_Type : Entity_Id := Empty;
RACW_Type : Entity_Id := Empty;
- Parent_Primitive : Entity_Id := Empty)
- return Node_Id;
+ Parent_Primitive : Entity_Id := Empty) return Node_Id;
-- Build the receiving stub for a given subprogram. The subprogram
-- declaration is also built by this procedure, and the value returned
-- is a N_Subprogram_Body. If a parameter of type access to Stub_Type is
function Build_RPC_Receiver_Specification
(RPC_Receiver : Entity_Id;
Stream_Parameter : Entity_Id;
- Result_Parameter : Entity_Id)
- return Node_Id;
+ Result_Parameter : Entity_Id) return Node_Id;
-- Make a subprogram specification for an RPC receiver,
-- with the given defining unit name and formal parameters.
function Build_Ordered_Parameters_List (Spec : Node_Id) return List_Id;
-- Return an ordered parameter list: unconstrained parameters are put
-- at the beginning of the list and constrained ones are put after. If
- -- there are no parameters, an empty list is returned.
+ -- there are no parameters, an empty list is returned. Special case:
+ -- the controlling formal of the equivalent RACW operation for a RAS
+ -- type is always left in first position.
procedure Add_Calling_Stubs_To_Declarations
- (Pkg_Spec : in Node_Id;
- Decls : in List_Id);
+ (Pkg_Spec : Node_Id;
+ Decls : List_Id);
-- Add calling stubs to the declarative part
procedure Add_Receiving_Stubs_To_Declarations
- (Pkg_Spec : in Node_Id;
- Decls : in List_Id);
+ (Pkg_Spec : Node_Id;
+ Decls : List_Id);
-- Add receiving stubs to the declarative part
- procedure Add_RAS_Dereference_Attribute (N : in Node_Id);
- -- Add a subprogram body for RAS dereference
+ procedure Add_RAS_Dereference_TSS (N : Node_Id);
+ -- Add a subprogram body for RAS Dereference TSS
- procedure Add_RAS_Access_Attribute (N : in Node_Id);
- -- Add a subprogram body for RAS Access attribute
+ procedure Add_RAS_Access_TSS (N : Node_Id);
+ -- Add a subprogram body for RAS Access TSS
function Could_Be_Asynchronous (Spec : Node_Id) return Boolean;
-- Return True if nothing prevents the program whose specification is
(Loc : Source_Ptr;
Stream : Node_Id;
Object : Entity_Id;
- Etyp : Entity_Id := Empty)
- return Node_Id;
+ Etyp : Entity_Id := Empty) return Node_Id;
-- Pack Object (of type Etyp) into Stream. If Etyp is not given,
-- then Etype (Object) will be used if present. If the type is
-- constrained, then 'Write will be used to output the object,
(Loc : Source_Ptr;
Stream : Entity_Id;
Object : Node_Id;
- Etyp : Entity_Id)
- return Node_Id;
+ Etyp : Entity_Id) return Node_Id;
-- Similar to above, with an arbitrary node instead of an entity
function Pack_Node_Into_Stream_Access
(Loc : Source_Ptr;
Stream : Node_Id;
Object : Node_Id;
- Etyp : Entity_Id)
- return Node_Id;
+ Etyp : Entity_Id) return Node_Id;
-- Similar to above, with Stream instead of Stream'Access
- function Copy_Specification
- (Loc : Source_Ptr;
- Spec : Node_Id;
- Object_Type : Entity_Id := Empty;
- Stub_Type : Entity_Id := Empty;
- New_Name : Name_Id := No_Name)
- return Node_Id;
- -- Build a specification from another one. If Object_Type is not Empty
- -- and any access to Object_Type is found, then it is replaced by an
- -- access to Stub_Type. If New_Name is given, then it will be used as
- -- the name for the newly created spec.
-
function Scope_Of_Spec (Spec : Node_Id) return Entity_Id;
-- Return the scope represented by a given spec
-- its constrained status.
function Is_RACW_Controlling_Formal
- (Parameter : Node_Id; Stub_Type : Entity_Id)
- return Boolean;
+ (Parameter : Node_Id; Stub_Type : Entity_Id) return Boolean;
-- Return True if the current parameter is a controlling formal argument
-- of type Stub_Type or access to Stub_Type.
-- Mapping between a RCI subprogram and the corresponding calling stubs
procedure Add_Stub_Type
- (Designated_Type : in Entity_Id;
- RACW_Type : in Entity_Id;
- Decls : in List_Id;
+ (Designated_Type : Entity_Id;
+ RACW_Type : Entity_Id;
+ Decls : List_Id;
Stub_Type : out Entity_Id;
Stub_Type_Access : out Entity_Id;
Object_RPC_Receiver : out Entity_Id;
-- anyhow and Existing is set to True.
procedure Add_RACW_Read_Attribute
- (RACW_Type : in Entity_Id;
- Stub_Type : in Entity_Id;
- Stub_Type_Access : in Entity_Id;
- Declarations : in List_Id);
+ (RACW_Type : Entity_Id;
+ Stub_Type : Entity_Id;
+ Stub_Type_Access : Entity_Id;
+ Declarations : List_Id);
-- Add Read attribute in Decls for the RACW type. The Read attribute
-- is added right after the RACW_Type declaration while the body is
-- inserted after Declarations.
procedure Add_RACW_Write_Attribute
- (RACW_Type : in Entity_Id;
- Stub_Type : in Entity_Id;
- Stub_Type_Access : in Entity_Id;
- Object_RPC_Receiver : in Entity_Id;
- Declarations : in List_Id);
+ (RACW_Type : Entity_Id;
+ Stub_Type : Entity_Id;
+ Stub_Type_Access : Entity_Id;
+ Object_RPC_Receiver : Entity_Id;
+ Declarations : List_Id);
-- Same thing for the Write attribute
procedure Add_RACW_Read_Write_Attributes
- (RACW_Type : in Entity_Id;
- Stub_Type : in Entity_Id;
- Stub_Type_Access : in Entity_Id;
- Object_RPC_Receiver : in Entity_Id;
- Declarations : in List_Id);
+ (RACW_Type : Entity_Id;
+ Stub_Type : Entity_Id;
+ Stub_Type_Access : Entity_Id;
+ Object_RPC_Receiver : Entity_Id;
+ Declarations : List_Id);
-- Add Read and Write attributes declarations and bodies for a given
-- RACW type. The declarations are added just after the declaration
-- of the RACW type itself, while the bodies are inserted at the end
function RCI_Package_Locator
(Loc : Source_Ptr;
- Package_Spec : Node_Id)
- return Node_Id;
+ Package_Spec : Node_Id) return Node_Id;
-- Instantiate the generic package RCI_Info in order to locate the
-- RCI package whose spec is given as argument.
function Input_With_Tag_Check
(Loc : Source_Ptr;
Var_Type : Entity_Id;
- Stream : Entity_Id)
- return Node_Id;
+ Stream : Entity_Id) return Node_Id;
-- Return a function with the following form:
-- function R return Var_Type is
-- begin
---------------------------------------
procedure Add_Calling_Stubs_To_Declarations
- (Pkg_Spec : in Node_Id;
- Decls : in List_Id)
+ (Pkg_Spec : Node_Id;
+ Decls : List_Id)
is
- Current_Subprogram_Number : Int := 0;
- Current_Declaration : Node_Id;
+ Current_Subprogram_Number : Int := First_RCI_Subprogram_Id;
+ -- Subprogram id 0 is reserved for calls received from
+ -- remote access-to-subprogram dereferences.
+ Current_Declaration : Node_Id;
Loc : constant Source_Ptr := Sloc (Pkg_Spec);
-
RCI_Instantiation : Node_Id;
-
Subp_Stubs : Node_Id;
begin
-- do the correct dispatching.
Current_Declaration := First (Visible_Declarations (Pkg_Spec));
-
while Current_Declaration /= Empty loop
-
if Nkind (Current_Declaration) = N_Subprogram_Declaration
and then Comes_From_Source (Current_Declaration)
then
Next (Current_Declaration);
end loop;
-
end Add_Calling_Stubs_To_Declarations;
-----------------------
-- Add_RACW_Features --
-----------------------
- procedure Add_RACW_Features (RACW_Type : in Entity_Id)
+ procedure Add_RACW_Features (RACW_Type : Entity_Id)
is
Desig : constant Entity_Id :=
Etype (Designated_Type (RACW_Type));
Loc : constant Source_Ptr := Sloc (Insertion_Node);
Stub_Elements : constant Stub_Structure :=
- Stubs_Table.Get (Designated_Type);
+ Stubs_Table.Get (Designated_Type);
pragma Assert (Stub_Elements /= Empty_Stub_Structure);
Current_Primitive_Elmt :=
First_Elmt (Primitive_Operations (Designated_Type));
-
while Current_Primitive_Elmt /= No_Elmt loop
-
Current_Primitive := Node (Current_Primitive_Elmt);
-- Copy the primitive of all the parents, except predefined
-----------------------------
procedure Add_RACW_Read_Attribute
- (RACW_Type : in Entity_Id;
- Stub_Type : in Entity_Id;
- Stub_Type_Access : in Entity_Id;
- Declarations : in List_Id)
+ (RACW_Type : Entity_Id;
+ Stub_Type : Entity_Id;
+ Stub_Type_Access : Entity_Id;
+ Declarations : List_Id)
is
Loc : constant Source_Ptr := Sloc (RACW_Type);
Source_Address : constant Entity_Id :=
Make_Defining_Identifier
(Loc, New_Internal_Name ('P'));
+ Local_Stub : constant Entity_Id :=
+ Make_Defining_Identifier
+ (Loc, New_Internal_Name ('L'));
Stubbed_Result : constant Entity_Id :=
Make_Defining_Identifier
(Loc, New_Internal_Name ('S'));
Object_Definition =>
New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Local_Stub,
+ Aliased_Present => True,
+ Object_Definition => New_Occurrence_Of (Stub_Type, Loc)),
+
Make_Object_Declaration (Loc,
Defining_Identifier => Stubbed_Result,
Object_Definition =>
- New_Occurrence_Of (Stub_Type_Access, Loc)));
+ New_Occurrence_Of (Stub_Type_Access, Loc),
+ Expression =>
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Local_Stub, Loc),
+ Attribute_Name =>
+ Name_Unchecked_Access)));
-- Read the source Partition_ID and RPC_Receiver from incoming stream
Stream_Parameter,
New_Occurrence_Of (Source_Address, Loc))));
+ -- Build_Get_Unique_RP_Call needs the type of Stubbed_Result
+
+ Set_Etype (Stubbed_Result, Stub_Type_Access);
+
-- If the Address is Null_Address, then return a null object
Append_To (Statements,
Remote_Statements := New_List (
- Make_Assignment_Statement (Loc,
- Name => New_Occurrence_Of (Stubbed_Result, Loc),
- Expression =>
- Make_Allocator (Loc,
- New_Occurrence_Of (Stub_Type, Loc))),
-
Make_Assignment_Statement (Loc,
Name => Make_Selected_Component (Loc,
Prefix => New_Occurrence_Of (Stubbed_Result, Loc),
Expression =>
New_Occurrence_Of (Asynchronous_Flag, Loc)));
- Append_To (Remote_Statements,
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Occurrence_Of (RTE (RE_Get_Unique_Remote_Pointer), Loc),
- Parameter_Associations => New_List (
- Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access),
- New_Occurrence_Of (Stubbed_Result, Loc)))));
+ Append_List_To (Remote_Statements,
+ Build_Get_Unique_RP_Call (Loc, Stubbed_Result, Stub_Type));
+ -- ??? Issue with asynchronous calls here: the Asynchronous
+ -- flag is set on the stub type if, and only if, the RACW type
+ -- has a pragma Asynchronous. This is incorrect for RACWs that
+ -- implement RAS types, because in that case the /designated
+ -- subprogram/ (not the type) might be asynchronous, and
+ -- that causes the stub to need to be asynchronous too.
+ -- A solution is to transport a RAS as a struct containing
+ -- a RACW and an asynchronous flag, and to properly alter
+ -- the Asynchronous component in the stub type in the RAS's
+ -- Input TSS.
Append_To (Remote_Statements,
Make_Assignment_Statement (Loc,
------------------------------------
procedure Add_RACW_Read_Write_Attributes
- (RACW_Type : in Entity_Id;
- Stub_Type : in Entity_Id;
- Stub_Type_Access : in Entity_Id;
- Object_RPC_Receiver : in Entity_Id;
- Declarations : in List_Id)
+ (RACW_Type : Entity_Id;
+ Stub_Type : Entity_Id;
+ Stub_Type_Access : Entity_Id;
+ Object_RPC_Receiver : Entity_Id;
+ Declarations : List_Id)
is
begin
Add_RACW_Write_Attribute
------------------------------
procedure Add_RACW_Write_Attribute
- (RACW_Type : in Entity_Id;
- Stub_Type : in Entity_Id;
- Stub_Type_Access : in Entity_Id;
- Object_RPC_Receiver : in Entity_Id;
- Declarations : in List_Id)
+ (RACW_Type : Entity_Id;
+ Stub_Type : Entity_Id;
+ Stub_Type_Access : Entity_Id;
+ Object_RPC_Receiver : Entity_Id;
+ Declarations : List_Id)
is
Loc : constant Source_Ptr := Sloc (RACW_Type);
+ Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
+
Body_Node : Node_Id;
Proc_Decl : Node_Id;
Attr_Decl : Node_Id;
+ RPC_Receiver : Node_Id;
+
Statements : List_Id;
Local_Statements : List_Id;
Remote_Statements : List_Id;
-- Build the code fragment corresponding to the marshalling of a
-- local object.
+ if Is_RAS then
+
+ -- For a RAS, the RPC receiver is that of the RCI unit,
+ -- not that of the corresponding distributed object type.
+ -- We retrieve its address from the local proxy object.
+
+ RPC_Receiver := Make_Selected_Component (Loc,
+ Prefix =>
+ Unchecked_Convert_To (RTE (RE_RAS_Proxy_Type_Access), Object),
+ Selector_Name =>
+ Make_Identifier (Loc, Name_Receiver));
+
+ else
+ RPC_Receiver := Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Object_RPC_Receiver, Loc),
+ Attribute_Name =>
+ Name_Address);
+ end if;
+
Local_Statements := New_List (
Pack_Entity_Into_Stream_Access (Loc,
Pack_Node_Into_Stream_Access (Loc,
Stream => Stream_Parameter,
- Object => OK_Convert_To (RTE (RE_Unsigned_64),
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Object_RPC_Receiver, Loc),
- Attribute_Name => Name_Address)),
+ Object => OK_Convert_To (RTE (RE_Unsigned_64), RPC_Receiver),
Etyp => RTE (RE_Unsigned_64)),
- Pack_Node_Into_Stream_Access (Loc,
- Stream => Stream_Parameter,
- Object => OK_Convert_To (RTE (RE_Unsigned_64),
- Make_Attribute_Reference (Loc,
- Prefix =>
- Make_Explicit_Dereference (Loc,
- Prefix => Object),
- Attribute_Name => Name_Address)),
- Etyp => RTE (RE_Unsigned_64)));
+ Pack_Node_Into_Stream_Access (Loc,
+ Stream => Stream_Parameter,
+ Object => OK_Convert_To (RTE (RE_Unsigned_64),
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ Make_Explicit_Dereference (Loc,
+ Prefix => Object),
+ Attribute_Name => Name_Address)),
+ Etyp => RTE (RE_Unsigned_64)));
-- Build the code fragment corresponding to the marshalling of
-- a remote object.
Append_To (Declarations, Body_Node);
end Add_RACW_Write_Attribute;
- ------------------------------
- -- Add_RAS_Access_Attribute --
- ------------------------------
+ ------------------------
+ -- Add_RAS_Access_TSS --
+ ------------------------
+
+ procedure Add_RAS_Access_TSS (N : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
- procedure Add_RAS_Access_Attribute (N : in Node_Id) is
Ras_Type : constant Entity_Id := Defining_Identifier (N);
Fat_Type : constant Entity_Id := Equivalent_Type (Ras_Type);
-- Ras_Type is the access to subprogram type while Fat_Type points to
-- the record type corresponding to a remote access to subprogram type.
- Proc_Decls : constant List_Id := New_List;
- Proc_Statements : constant List_Id := New_List;
+ RACW_Type : constant Entity_Id :=
+ Underlying_RACW_Type (Ras_Type);
+ Desig : constant Entity_Id :=
+ Etype (Designated_Type (RACW_Type));
- Proc_Spec : Node_Id;
- Proc : Node_Id;
- Local_Addr : Entity_Id;
- Package_Name : Entity_Id;
- Subp_Id : Entity_Id;
- Asynch_P : Entity_Id;
- Origin : Entity_Id;
- Return_Value : Entity_Id;
+ Stub_Elements : constant Stub_Structure :=
+ Stubs_Table.Get (Desig);
+ pragma Assert (Stub_Elements /= Empty_Stub_Structure);
- All_Calls_Remote : Entity_Id;
+ Proc : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => Make_TSS_Name (Ras_Type, TSS_RAS_Access));
+ Proc_Spec : Node_Id;
+
+ -- Formal parameters
+
+ Package_Name : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => Name_P);
+ -- Target package
+
+ Subp_Id : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => Name_S);
+ -- Target subprogram
+
+ Asynch_P : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => Name_Asynchronous);
+ -- Is the procedure to which the 'Access applies asynchronous?
+
+ All_Calls_Remote : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => Name_All_Calls_Remote);
-- True if an All_Calls_Remote pragma applies to the RCI unit
- -- that contains the subprogram (currently unused, all RAS
- -- dereferences are handled through the PCS).
+ -- that contains the subprogram.
- Loc : constant Source_Ptr := Sloc (N);
+ -- Common local variables
+
+ Proc_Decls : List_Id;
+ Proc_Statements : List_Id;
+
+ Origin : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_Internal_Name ('P'));
+
+ -- Additional local variables for the local case
+
+ Proxy_Addr : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_Internal_Name ('P'));
+
+ -- Additional local variables for the remote case
+
+ Local_Stub : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_Internal_Name ('L'));
+
+ Stub_Ptr : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_Internal_Name ('S'));
function Set_Field
(Field_Name : Name_Id;
Make_Assignment_Statement (Loc,
Name =>
Make_Selected_Component (Loc,
- Prefix => New_Occurrence_Of (Return_Value, Loc),
+ Prefix => New_Occurrence_Of (Stub_Ptr, Loc),
Selector_Name => Make_Identifier (Loc, Field_Name)),
Expression => Value);
end Set_Field;
- -- Start of processing for Add_RAS_Access_Attribute
+ -- Start of processing for Add_RAS_Access_TSS
begin
- Local_Addr := Make_Defining_Identifier (Loc, New_Internal_Name ('L'));
- Package_Name := Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
- Subp_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('N'));
- Asynch_P := Make_Defining_Identifier (Loc, New_Internal_Name ('B'));
- Origin := Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
- Return_Value := Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
- All_Calls_Remote :=
- Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
-
- -- Create the object which will be returned of type Fat_Type
+ Proc_Decls := New_List (
- Append_List_To (Proc_Decls, New_List (
+ -- Common declarations
Make_Object_Declaration (Loc,
Defining_Identifier => Origin,
Parameter_Associations => New_List (
New_Occurrence_Of (Package_Name, Loc)))),
+ -- Declaration use only in the local case: proxy address
+
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Proxy_Addr,
+ Object_Definition =>
+ New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
+
+ -- Declarations used only in the remote case: stub object and
+ -- stub pointer.
+
Make_Object_Declaration (Loc,
- Defining_Identifier => Return_Value,
+ Defining_Identifier => Local_Stub,
+ Aliased_Present => True,
Object_Definition =>
- New_Occurrence_Of (Fat_Type, Loc))));
+ New_Occurrence_Of (Stub_Elements.Stub_Type, Loc)),
+
+ Make_Object_Declaration (Loc,
+ Defining_Identifier =>
+ Stub_Ptr,
+ Object_Definition =>
+ New_Occurrence_Of (Stub_Elements.Stub_Type_Access, Loc),
+ Expression =>
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Local_Stub, Loc),
+ Attribute_Name => Name_Unchecked_Access)));
- -- Initialize the fields of the record type with the appropriate data
+ Set_Etype (Stub_Ptr, Stub_Elements.Stub_Type_Access);
+ -- Build_Get_Unique_RP_Call needs this information.
+
+ -- Note: Here we assume that the Fat_Type is a record
+ -- containing just a pointer to a proxy or stub object.
+
+ Proc_Statements := New_List (
+
+ -- Get_RAS_Info (Pkg, Subp, PA);
+ -- if Origin = Local_Partition_Id and then not All_Calls_Remote then
+ -- return Fat_Type!(PA);
+ -- end if;
+
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Occurrence_Of (RTE (RE_Get_RAS_Info), Loc),
+ Parameter_Associations => New_List (
+ New_Occurrence_Of (Package_Name, Loc),
+ New_Occurrence_Of (Subp_Id, Loc),
+ New_Occurrence_Of (Proxy_Addr, Loc))),
- Append_List_To (Proc_Statements, New_List (
Make_Implicit_If_Statement (N,
Condition =>
Make_And_Then (Loc,
- Left_Opnd =>
- Make_Op_Not (Loc,
- New_Occurrence_Of (All_Calls_Remote, Loc)),
- Right_Opnd =>
+ Left_Opnd =>
Make_Op_Eq (Loc,
Left_Opnd =>
New_Occurrence_Of (Origin, Loc),
Right_Opnd =>
Make_Function_Call (Loc,
New_Occurrence_Of (
- RTE (RE_Get_Local_Partition_Id), Loc)))),
-
+ RTE (RE_Get_Local_Partition_Id), Loc))),
+ Right_Opnd =>
+ Make_Op_Not (Loc,
+ New_Occurrence_Of (All_Calls_Remote, Loc))),
Then_Statements => New_List (
- Set_Field (Name_Ras,
- OK_Convert_To (RTE (RE_Unsigned_64),
- New_Occurrence_Of (Local_Addr, Loc)))),
-
- Else_Statements => New_List (
- Set_Field (Name_Ras,
- Make_Integer_Literal (Loc, Uint_0)))),
+ Make_Return_Statement (Loc,
+ Unchecked_Convert_To (Fat_Type,
+ OK_Convert_To (RTE (RE_Address),
+ New_Occurrence_Of (Proxy_Addr, Loc)))))),
Set_Field (Name_Origin,
- Unchecked_Convert_To (Standard_Integer,
- New_Occurrence_Of (Origin, Loc))),
+ New_Occurrence_Of (Origin, Loc)),
Set_Field (Name_Receiver,
Make_Function_Call (Loc,
Parameter_Associations => New_List (
New_Occurrence_Of (Package_Name, Loc)))),
- Set_Field (Name_Subp_Id,
- New_Occurrence_Of (Subp_Id, Loc)),
+ Set_Field (Name_Addr, New_Occurrence_Of (Proxy_Addr, Loc)),
+
+ Set_Field (Name_Asynchronous,
+ Make_Or_Else (Loc,
+ New_Occurrence_Of (Asynch_P, Loc),
+ New_Occurrence_Of (Boolean_Literals (
+ Is_Asynchronous (Ras_Type)), Loc))));
+ -- E.4.1(9) A remote call is asynchronous if it is a call to
+ -- a procedure, or a call through a value of an access-to-procedure
+ -- type, to which a pragma Asynchronous applies.
+ -- Parameter Asynch_P is true when the procedure is asynchronous;
+ -- Expression Asynch_T is true when the type is asynchronous.
- Set_Field (Name_Async,
- New_Occurrence_Of (Asynch_P, Loc))));
+ Append_List_To (Proc_Statements,
+ Build_Get_Unique_RP_Call
+ (Loc, Stub_Ptr, Stub_Elements.Stub_Type));
-- Return the newly created value
Append_To (Proc_Statements,
Make_Return_Statement (Loc,
Expression =>
- New_Occurrence_Of (Return_Value, Loc)));
-
- Proc :=
- Make_Defining_Identifier (Loc,
- Chars => Make_TSS_Name (Ras_Type, TSS_RAS_Access));
+ Unchecked_Convert_To (Fat_Type,
+ New_Occurrence_Of (Stub_Ptr, Loc))));
Proc_Spec :=
Make_Function_Specification (Loc,
Defining_Unit_Name => Proc,
Parameter_Specifications => New_List (
- Make_Parameter_Specification (Loc,
- Defining_Identifier => Local_Addr,
- Parameter_Type =>
- New_Occurrence_Of (RTE (RE_Address), Loc)),
-
Make_Parameter_Specification (Loc,
Defining_Identifier => Package_Name,
Parameter_Type =>
Make_Parameter_Specification (Loc,
Defining_Identifier => Subp_Id,
Parameter_Type =>
- New_Occurrence_Of (Standard_Natural, Loc)),
+ New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc)),
Make_Parameter_Specification (Loc,
Defining_Identifier => Asynch_P,
Statements => Proc_Statements)));
Set_TSS (Fat_Type, Proc);
+ end Add_RAS_Access_TSS;
- end Add_RAS_Access_Attribute;
-
- -----------------------------------
- -- Add_RAS_Dereference_Attribute --
- -----------------------------------
+ -----------------------------
+ -- Add_RAS_Dereference_TSS --
+ -----------------------------
- procedure Add_RAS_Dereference_Attribute (N : in Node_Id) is
+ procedure Add_RAS_Dereference_TSS (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Type_Def : constant Node_Id := Type_Definition (N);
- Ras_Type : constant Entity_Id := Defining_Identifier (N);
-
- Fat_Type : constant Entity_Id := Equivalent_Type (Ras_Type);
+ RAS_Type : constant Entity_Id := Defining_Identifier (N);
+ Fat_Type : constant Entity_Id := Equivalent_Type (RAS_Type);
+ RACW_Type : constant Entity_Id := Underlying_RACW_Type (RAS_Type);
+ Desig : constant Entity_Id := Etype (Designated_Type (RACW_Type));
- Proc_Decls : constant List_Id := New_List;
- Proc_Statements : constant List_Id := New_List;
+ Stub_Elements : constant Stub_Structure := Stubs_Table.Get (Desig);
+ pragma Assert (Stub_Elements /= Empty_Stub_Structure);
- Inner_Decls : constant List_Id := New_List;
- Inner_Statements : constant List_Id := New_List;
+ RACW_Primitive_Name : Node_Id;
- Direct_Statements : constant List_Id := New_List;
+ Proc : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => Make_TSS_Name (RAS_Type, TSS_RAS_Dereference));
- Proc : Node_Id;
Proc_Spec : Node_Id;
- Param_Specs : constant List_Id := New_List;
+ Param_Specs : List_Id;
Param_Assoc : constant List_Id := New_List;
+ Stmts : constant List_Id := New_List;
- Pointer : Node_Id;
-
- Converted_Ras : Node_Id;
- Target_Partition : Node_Id;
- RPC_Receiver : Node_Id;
- Subprogram_Id : Node_Id;
- Asynchronous : Node_Id;
+ RAS_Parameter : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_Internal_Name ('P'));
Is_Function : constant Boolean :=
Nkind (Type_Def) = N_Access_Function_Definition;
+ Is_Degenerate : Boolean;
+ -- Set to True if the subprogram_specification for this RAS has
+ -- an anonymous access parameter (see Process_Remote_AST_Declaration).
+
Spec : constant Node_Id := Type_Def;
Current_Parameter : Node_Id;
begin
- -- The way to do it is test if the Ras field is non-null and then if
- -- the Origin field is equal to the current partition ID (which is in
- -- fact Current_Package'Partition_ID). If this is the case, then it
- -- is safe to dereference the Ras field directly rather than
- -- performing a remote call.
+ Param_Specs := New_List (
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier => RAS_Parameter,
+ In_Present => True,
+ Parameter_Type =>
+ New_Occurrence_Of (Fat_Type, Loc)));
- Pointer :=
- Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
+ Is_Degenerate := False;
+ Current_Parameter := First (Parameter_Specifications (Type_Def));
+ Parameters : while Current_Parameter /= Empty loop
+ if Nkind (Parameter_Type (Current_Parameter))
+ = N_Access_Definition
+ then
+ Is_Degenerate := True;
+ end if;
+ Append_To (Param_Specs,
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc,
+ Chars => Chars (Defining_Identifier (Current_Parameter))),
+ In_Present => In_Present (Current_Parameter),
+ Out_Present => Out_Present (Current_Parameter),
+ Parameter_Type =>
+ New_Copy_Tree (Parameter_Type (Current_Parameter)),
+ Expression =>
+ New_Copy_Tree (Expression (Current_Parameter))));
+
+ Append_To (Param_Assoc,
+ Make_Identifier (Loc,
+ Chars => Chars (Defining_Identifier (Current_Parameter))));
- Target_Partition :=
- Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
+ Next (Current_Parameter);
+ end loop Parameters;
- Append_To (Proc_Decls,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Target_Partition,
- Constant_Present => True,
- Object_Definition =>
- New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
- Expression =>
- Unchecked_Convert_To (RTE (RE_Partition_ID),
- Make_Selected_Component (Loc,
- Prefix =>
- New_Occurrence_Of (Pointer, Loc),
- Selector_Name =>
- Make_Identifier (Loc, Name_Origin)))));
-
- RPC_Receiver :=
- Make_Selected_Component (Loc,
- Prefix =>
- New_Occurrence_Of (Pointer, Loc),
- Selector_Name =>
- Make_Identifier (Loc, Name_Receiver));
-
- Subprogram_Id :=
- Unchecked_Convert_To (RTE (RE_Subprogram_Id),
- Make_Selected_Component (Loc,
- Prefix =>
- New_Occurrence_Of (Pointer, Loc),
- Selector_Name =>
- Make_Identifier (Loc, Name_Subp_Id)));
-
- -- A function is never asynchronous. A procedure may or may not be
- -- asynchronous depending on whether a pragma Asynchronous applies
- -- on it. Since a RAST may point onto various subprograms, this is
- -- only known at runtime so both versions (synchronous and asynchronous)
- -- must be built every times it is not a function.
+ if Is_Degenerate then
+ Prepend_To (Param_Assoc, New_Occurrence_Of (RAS_Parameter, Loc));
- if Is_Function then
- Asynchronous := Empty;
+ -- Generate a dummy body recursing on the Dereference TSS, since
+ -- actually it will never be executed.
+
+ Append_To (Stmts,
+ Make_Raise_Program_Error (Loc, Reason => PE_Explicit_Raise));
+ RACW_Primitive_Name := New_Occurrence_Of (Proc, Loc);
else
- Asynchronous :=
+ Prepend_To (Param_Assoc,
+ Unchecked_Convert_To (RACW_Type,
+ New_Occurrence_Of (RAS_Parameter, Loc)));
+
+ RACW_Primitive_Name :=
Make_Selected_Component (Loc,
- Prefix =>
- New_Occurrence_Of (Pointer, Loc),
+ Prefix =>
+ New_Occurrence_Of (Scope (RACW_Type), Loc),
Selector_Name =>
- Make_Identifier (Loc, Name_Async));
-
+ Make_Identifier (Loc, Name_Call));
end if;
- if Present (Parameter_Specifications (Type_Def)) then
- Current_Parameter := First (Parameter_Specifications (Type_Def));
-
- while Current_Parameter /= Empty loop
- Append_To (Param_Specs,
- Make_Parameter_Specification (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc,
- Chars =>
- Chars (Defining_Identifier (Current_Parameter))),
- In_Present => In_Present (Current_Parameter),
- Out_Present => Out_Present (Current_Parameter),
- Parameter_Type =>
- New_Copy_Tree (Parameter_Type (Current_Parameter)),
- Expression =>
- New_Copy_Tree (Expression (Current_Parameter))));
-
- Append_To (Param_Assoc,
- Make_Identifier (Loc,
- Chars => Chars (Defining_Identifier (Current_Parameter))));
+ if Is_Function then
+ Append_To (Stmts,
+ Make_Return_Statement (Loc,
+ Expression =>
+ Make_Function_Call (Loc,
+ Name =>
+ RACW_Primitive_Name,
+ Parameter_Associations => Param_Assoc)));
- Next (Current_Parameter);
- end loop;
+ else
+ Append_To (Stmts,
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ RACW_Primitive_Name,
+ Parameter_Associations => Param_Assoc));
end if;
- Proc :=
- Make_Defining_Identifier (Loc,
- Chars => Make_TSS_Name (Ras_Type, TSS_RAS_Dereference));
+ -- Build the complete subprogram.
if Is_Function then
Proc_Spec :=
Entity (Subtype_Mark (Spec)), Loc));
Set_Ekind (Proc, E_Function);
-
Set_Etype (Proc,
New_Occurrence_Of (Entity (Subtype_Mark (Spec)), Loc));
Set_Etype (Proc, Standard_Void_Type);
end if;
- -- Build the calling stubs for the dereference of the RAS
+ Discard_Node (
+ Make_Subprogram_Body (Loc,
+ Specification => Proc_Spec,
+ Declarations => New_List,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => Stmts)));
+
+ Set_TSS (Fat_Type, Proc);
+ end Add_RAS_Dereference_TSS;
- Build_General_Calling_Stubs
- (Decls => Inner_Decls,
- Statements => Inner_Statements,
- Target_Partition => Target_Partition,
- RPC_Receiver => RPC_Receiver,
- Subprogram_Id => Subprogram_Id,
- Asynchronous => Asynchronous,
- Is_Known_Non_Asynchronous => Is_Function,
- Is_Function => Is_Function,
- Spec => Proc_Spec,
- Nod => N);
-
- Converted_Ras :=
- Unchecked_Convert_To (Ras_Type,
- OK_Convert_To (RTE (RE_Address),
- Make_Selected_Component (Loc,
- Prefix => New_Occurrence_Of (Pointer, Loc),
- Selector_Name => Make_Identifier (Loc, Name_Ras))));
+ -------------------------------
+ -- Add_RAS_Proxy_And_Analyze --
+ -------------------------------
- if Is_Function then
- Append_To (Direct_Statements,
- Make_Return_Statement (Loc,
- Expression =>
- Make_Function_Call (Loc,
- Name =>
- Make_Explicit_Dereference (Loc,
- Prefix => Converted_Ras),
- Parameter_Associations => Param_Assoc)));
+ procedure Add_RAS_Proxy_And_Analyze
+ (Decls : List_Id;
+ Vis_Decl : Node_Id;
+ All_Calls_Remote_E : Entity_Id;
+ Proxy_Object_Addr : out Entity_Id)
+ is
+ Loc : constant Source_Ptr := Sloc (Vis_Decl);
- else
- Append_To (Direct_Statements,
+ Subp_Name : constant Entity_Id :=
+ Defining_Unit_Name (Specification (Vis_Decl));
+
+ Pkg_Name : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars =>
+ New_External_Name (Chars (Subp_Name), 'P', -1));
+
+ Proxy_Type : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars =>
+ New_External_Name (
+ Related_Id => Chars (Subp_Name),
+ Suffix => 'P'));
+
+ Proxy_Type_Full_View : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars (Proxy_Type));
+
+ Subp_Decl_Spec : constant Node_Id :=
+ Build_RAS_Primitive_Specification
+ (Subp_Spec => Specification (Vis_Decl),
+ Remote_Object_Type => Proxy_Type);
+
+ Subp_Body_Spec : constant Node_Id :=
+ Build_RAS_Primitive_Specification
+ (Subp_Spec => Specification (Vis_Decl),
+ Remote_Object_Type => Proxy_Type);
+
+ Vis_Decls : constant List_Id := New_List;
+ Pvt_Decls : constant List_Id := New_List;
+ Actuals : constant List_Id := New_List;
+ Formal : Node_Id;
+ Perform_Call : Node_Id;
+
+ begin
+ -- type subpP is tagged limited private;
+
+ Append_To (Vis_Decls,
+ Make_Private_Type_Declaration (Loc,
+ Defining_Identifier => Proxy_Type,
+ Tagged_Present => True,
+ Limited_Present => True));
+
+ -- [subprogram] Call
+ -- (Self : access subpP;
+ -- ...other-formals...)
+ -- [return T];
+
+ Append_To (Vis_Decls,
+ Make_Subprogram_Declaration (Loc,
+ Specification => Subp_Decl_Spec));
+
+ -- A : constant System.Address;
+
+ Proxy_Object_Addr := Make_Defining_Identifier (Loc, Name_uA);
+
+ Append_To (Vis_Decls,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier =>
+ Proxy_Object_Addr,
+ Constant_Present =>
+ True,
+ Object_Definition =>
+ New_Occurrence_Of (RTE (RE_Address), Loc)));
+
+ -- private
+
+ -- type subpP is tagged limited record
+ -- All_Calls_Remote : Boolean := [All_Calls_Remote?];
+ -- ...
+ -- end record;
+
+ Append_To (Pvt_Decls,
+ Make_Full_Type_Declaration (Loc,
+ Defining_Identifier =>
+ Proxy_Type_Full_View,
+ Type_Definition =>
+ Build_Remote_Subprogram_Proxy_Type (Loc,
+ New_Occurrence_Of (All_Calls_Remote_E, Loc))));
+
+ -- Trick semantic analysis into swapping the public and
+ -- full view when freezing the public view.
+
+ Set_Comes_From_Source (Proxy_Type_Full_View, True);
+
+
+ -- procedure Call
+ -- (Self : access O;
+ -- ...other-formals...) is
+ -- begin
+ -- P (...other-formals...);
+ -- end Call;
+
+ -- function Call
+ -- (Self : access O;
+ -- ...other-formals...)
+ -- return T is
+ -- begin
+ -- return F (...other-formals...);
+ -- end Call;
+
+ if Nkind (Subp_Decl_Spec) = N_Procedure_Specification then
+ Perform_Call :=
Make_Procedure_Call_Statement (Loc,
- Name =>
- Make_Explicit_Dereference (Loc,
- Prefix => Converted_Ras),
- Parameter_Associations => Param_Assoc));
+ Name =>
+ New_Occurrence_Of (Subp_Name, Loc),
+ Parameter_Associations =>
+ Actuals);
+ else
+ Perform_Call :=
+ Make_Return_Statement (Loc,
+ Expression =>
+ Make_Function_Call (Loc,
+ Name =>
+ New_Occurrence_Of (Subp_Name, Loc),
+ Parameter_Associations =>
+ Actuals));
end if;
- Prepend_To (Param_Specs,
- Make_Parameter_Specification (Loc,
- Defining_Identifier => Pointer,
- In_Present => True,
- Parameter_Type =>
- New_Occurrence_Of (Fat_Type, Loc)));
+ Formal := First (Parameter_Specifications (Subp_Decl_Spec));
+ pragma Assert (Present (Formal));
+ Next (Formal);
- Append_To (Proc_Statements,
- Make_Implicit_If_Statement (N,
- Condition =>
- Make_And_Then (Loc,
- Left_Opnd =>
- Make_Op_Ne (Loc,
- Left_Opnd =>
- Make_Selected_Component (Loc,
- Prefix => New_Occurrence_Of (Pointer, Loc),
- Selector_Name => Make_Identifier (Loc, Name_Ras)),
- Right_Opnd =>
- Make_Integer_Literal (Loc, Uint_0)),
+ while Present (Formal) loop
+ Append_To (Actuals, New_Occurrence_Of (
+ Defining_Identifier (Formal), Loc));
+ Next (Formal);
+ end loop;
- Right_Opnd =>
- Make_Op_Eq (Loc,
- Left_Opnd =>
- New_Occurrence_Of (Target_Partition, Loc),
- Right_Opnd =>
- Make_Function_Call (Loc,
- New_Occurrence_Of (
- RTE (RE_Get_Local_Partition_Id), Loc)))),
+ -- O : aliased subpP;
- Then_Statements =>
- Direct_Statements,
+ Append_To (Pvt_Decls,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc,
+ Name_uO),
+ Aliased_Present =>
+ True,
+ Object_Definition =>
+ New_Occurrence_Of (Proxy_Type, Loc)));
- Else_Statements => New_List (
- Make_Block_Statement (Loc,
- Declarations => Inner_Decls,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => Inner_Statements)))));
+ -- A : constant System.Address := O'Address;
- Discard_Node (
- Make_Subprogram_Body (Loc,
- Specification => Proc_Spec,
- Declarations => Proc_Decls,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => Proc_Statements)));
+ Append_To (Pvt_Decls,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc,
+ Chars (Proxy_Object_Addr)),
+ Constant_Present =>
+ True,
+ Object_Definition =>
+ New_Occurrence_Of (RTE (RE_Address), Loc),
+ Expression =>
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (
+ Defining_Identifier (Last (Pvt_Decls)), Loc),
+ Attribute_Name =>
+ Name_Address)));
- Set_TSS (Fat_Type, Defining_Unit_Name (Proc_Spec));
+ Append_To (Decls,
+ Make_Package_Declaration (Loc,
+ Specification => Make_Package_Specification (Loc,
+ Defining_Unit_Name => Pkg_Name,
+ Visible_Declarations => Vis_Decls,
+ Private_Declarations => Pvt_Decls,
+ End_Label => Empty)));
+ Analyze (Last (Decls));
- end Add_RAS_Dereference_Attribute;
+ Append_To (Decls,
+ Make_Package_Body (Loc,
+ Defining_Unit_Name =>
+ Make_Defining_Identifier (Loc,
+ Chars (Pkg_Name)),
+ Declarations => New_List (
+ Make_Subprogram_Body (Loc,
+ Specification =>
+ Subp_Body_Spec,
+ Declarations => New_List,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (Perform_Call))))));
+ Analyze (Last (Decls));
+ end Add_RAS_Proxy_And_Analyze;
-----------------------
-- Add_RAST_Features --
return;
end if;
- Add_RAS_Dereference_Attribute (Vis_Decl);
- Add_RAS_Access_Attribute (Vis_Decl);
+ Add_RAS_Dereference_TSS (Vis_Decl);
+ Add_RAS_Access_TSS (Vis_Decl);
end Add_RAST_Features;
-----------------------------------------
-----------------------------------------
procedure Add_Receiving_Stubs_To_Declarations
- (Pkg_Spec : in Node_Id;
- Decls : in List_Id)
+ (Pkg_Spec : Node_Id;
+ Decls : List_Id)
is
Loc : constant Source_Ptr := Sloc (Pkg_Spec);
Pkg_RPC_Receiver_Body : Node_Id;
-- A Pkg_RPC_Receiver is built to decode the request
- Subp_Id : Node_Id;
+ Lookup_RAS_Info : constant Entity_Id :=
+ Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
+ -- A remote subprogram is created to allow peers to look up
+ -- RAS information using subprogram ids.
+
+ Subp_Id : Node_Id;
-- Subprogram_Id as read from the incoming stream
Current_Declaration : Node_Id;
- Current_Subprogram_Number : Int := 0;
+ Current_Subprogram_Number : Int := First_RCI_Subprogram_Id;
Current_Stubs : Node_Id;
- Actuals : List_Id;
+ Subp_Info_Array : constant Entity_Id :=
+ Make_Defining_Identifier (Loc, New_Internal_Name ('I'));
+
+ Subp_Info_List : constant List_Id := New_List;
Dummy_Register_Name : Name_Id;
Dummy_Register_Spec : Node_Id;
Dummy_Register_Decl : Node_Id;
Dummy_Register_Body : Node_Id;
+ All_Calls_Remote_E : Entity_Id;
+ Proxy_Object_Addr : Entity_Id;
+
+ procedure Append_Stubs_To
+ (RPC_Receiver_Cases : List_Id;
+ Declaration : Node_Id;
+ Stubs : Node_Id;
+ Subprogram_Number : Int);
+ -- Add one case to the specified RPC receiver case list
+ -- associating Subprogram_Number with the subprogram declared
+ -- by Declaration, for which we have receiving stubs in Stubs.
+
+ procedure Append_Stubs_To
+ (RPC_Receiver_Cases : List_Id;
+ Declaration : Node_Id;
+ Stubs : Node_Id;
+ Subprogram_Number : Int)
+ is
+ Actuals : constant List_Id :=
+ New_List (New_Occurrence_Of (Stream_Parameter, Loc));
+ begin
+ if Nkind (Specification (Declaration)) = N_Function_Specification
+ or else not
+ Is_Asynchronous (Defining_Entity (Specification (Declaration)))
+ then
+ -- An asynchronous procedure does not want an output parameter
+ -- since no result and no exception will ever be returned.
+
+ Append_To (Actuals,
+ New_Occurrence_Of (Result_Parameter, Loc));
+ end if;
+
+ Append_To (RPC_Receiver_Cases,
+ Make_Case_Statement_Alternative (Loc,
+ Discrete_Choices =>
+ New_List (
+ Make_Integer_Literal (Loc, Subprogram_Number)),
+
+ Statements =>
+ New_List (
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Occurrence_Of (
+ Defining_Entity (Stubs), Loc),
+ Parameter_Associations =>
+ Actuals))));
+ end Append_Stubs_To;
+
+ -- Start of processing for Add_Receiving_Stubs_To_Declarations
+
begin
-- Building receiving stubs consist in several operations:
New_Occurrence_Of (Stream_Parameter, Loc),
New_Occurrence_Of (Subp_Id, Loc))));
+ -- A null subp_id denotes a call through a RAS, in which case the
+ -- next Uint_64 element in the stream is the address of the local
+ -- proxy object, from which we can retrieve the actual subprogram id.
+
+ Append_To (Pkg_RPC_Receiver_Statements,
+ Make_Implicit_If_Statement (Pkg_Spec,
+ Condition =>
+ Make_Op_Eq (Loc,
+ New_Occurrence_Of (Subp_Id, Loc),
+ Make_Integer_Literal (Loc, 0)),
+ Then_Statements => New_List (
+ Make_Assignment_Statement (Loc,
+ Name =>
+ New_Occurrence_Of (Subp_Id, Loc),
+ Expression =>
+ Make_Selected_Component (Loc,
+ Prefix =>
+ Unchecked_Convert_To (RTE (RE_RAS_Proxy_Type_Access),
+ OK_Convert_To (RTE (RE_Address),
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
+ Attribute_Name =>
+ Name_Input,
+ Expressions => New_List (
+ New_Occurrence_Of (Stream_Parameter, Loc))))),
+ Selector_Name =>
+ Make_Identifier (Loc, Name_Subp_Id))))));
+
+ All_Calls_Remote_E := Boolean_Literals (
+ Has_All_Calls_Remote (Defining_Entity (Pkg_Spec)));
+
+ -- Build a subprogram for RAS information lookups
+
+ Current_Declaration :=
+ Make_Subprogram_Declaration (Loc,
+ Specification =>
+ Make_Function_Specification (Loc,
+ Defining_Unit_Name =>
+ Lookup_RAS_Info,
+ Parameter_Specifications => New_List (
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_Subp_Id),
+ In_Present =>
+ True,
+ Parameter_Type =>
+ New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc))),
+ Subtype_Mark =>
+ New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)));
+ Append_To (Decls, Current_Declaration);
+ Analyze (Current_Declaration);
+
+ Current_Stubs := Build_Subprogram_Receiving_Stubs
+ (Vis_Decl => Current_Declaration,
+ Asynchronous => False);
+ Append_To (Decls, Current_Stubs);
+ Analyze (Current_Stubs);
+
+ Append_Stubs_To (Pkg_RPC_Receiver_Cases,
+ Declaration =>
+ Current_Declaration,
+ Stubs =>
+ Current_Stubs,
+ Subprogram_Number => 1);
+
-- For each subprogram, the receiving stub will be built and a
-- case statement will be made on the Subprogram_Id to dispatch
-- to the right subprogram.
Current_Declaration := First (Visible_Declarations (Pkg_Spec));
-
while Current_Declaration /= Empty loop
-
if Nkind (Current_Declaration) = N_Subprogram_Declaration
and then Comes_From_Source (Current_Declaration)
then
Get_Subprogram_Id (Defining_Unit_Name (Specification (
Current_Declaration))));
+ -- Build receiving stub
+
Current_Stubs :=
Build_Subprogram_Receiving_Stubs
(Vis_Decl => Current_Declaration,
(Current_Declaration))));
Append_To (Decls, Current_Stubs);
-
Analyze (Current_Stubs);
- Actuals := New_List (New_Occurrence_Of (Stream_Parameter, Loc));
-
- if Nkind (Specification (Current_Declaration))
- = N_Function_Specification
- or else
- not Is_Asynchronous (
- Defining_Entity (Specification (Current_Declaration)))
- then
- -- An asynchronous procedure does not want an output parameter
- -- since no result and no exception will ever be returned.
-
- Append_To (Actuals,
- New_Occurrence_Of (Result_Parameter, Loc));
-
- end if;
-
- Append_To (Pkg_RPC_Receiver_Cases,
- Make_Case_Statement_Alternative (Loc,
- Discrete_Choices =>
- New_List (
- Make_Integer_Literal (Loc, Current_Subprogram_Number)),
-
- Statements =>
- New_List (
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Occurrence_Of (
- Defining_Entity (Current_Stubs), Loc),
- Parameter_Associations =>
- Actuals))));
-
+ -- Build RAS proxy
+
+ Add_RAS_Proxy_And_Analyze (Decls,
+ Vis_Decl =>
+ Current_Declaration,
+ All_Calls_Remote_E =>
+ All_Calls_Remote_E,
+ Proxy_Object_Addr =>
+ Proxy_Object_Addr);
+
+ -- Add subprogram descriptor (RCI_Subp_Info) to the
+ -- subprograms table for this receiver. The aggregate
+ -- below must be kept consistent with the declaration
+ -- of type RCI_Subp_Info in System.Partition_Interface.
+
+ Append_To (Subp_Info_List,
+ Make_Component_Association (Loc,
+ Choices => New_List (
+ Make_Integer_Literal (Loc,
+ Current_Subprogram_Number)),
+ Expression =>
+ Make_Aggregate (Loc,
+ Component_Associations => New_List (
+ Make_Component_Association (Loc,
+ Choices => New_List (
+ Make_Identifier (Loc, Name_Addr)),
+ Expression =>
+ New_Occurrence_Of (Proxy_Object_Addr, Loc))))));
+
+ Append_Stubs_To (Pkg_RPC_Receiver_Cases,
+ Declaration =>
+ Current_Declaration,
+ Stubs =>
+ Current_Stubs,
+ Subprogram_Number =>
+ Current_Subprogram_Number);
Current_Subprogram_Number := Current_Subprogram_Number + 1;
end if;
New_Occurrence_Of (Subp_Id, Loc),
Alternatives => Pkg_RPC_Receiver_Cases));
+ Append_To (Decls,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Subp_Info_Array,
+ Constant_Present => True,
+ Aliased_Present => True,
+ Object_Definition =>
+ Make_Subtype_Indication (Loc,
+ Subtype_Mark =>
+ New_Occurrence_Of (RTE (RE_RCI_Subp_Info_Array), Loc),
+ Constraint =>
+ Make_Index_Or_Discriminant_Constraint (Loc,
+ New_List (
+ Make_Range (Loc,
+ Low_Bound => Make_Integer_Literal (Loc,
+ First_RCI_Subprogram_Id),
+ High_Bound =>
+ Make_Integer_Literal (Loc,
+ First_RCI_Subprogram_Id
+ + List_Length (Subp_Info_List) - 1))))),
+ Expression =>
+ Make_Aggregate (Loc,
+ Component_Associations => Subp_Info_List)));
+ Analyze (Last (Decls));
+
+ Append_To (Decls,
+ Make_Subprogram_Body (Loc,
+ Specification =>
+ Copy_Specification (Loc, Parent (Lookup_RAS_Info)),
+ Declarations =>
+ No_List,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (
+ Make_Return_Statement (Loc,
+ Expression => OK_Convert_To (RTE (RE_Unsigned_64),
+ Make_Selected_Component (Loc,
+ Prefix =>
+ Make_Indexed_Component (Loc,
+ Prefix =>
+ New_Occurrence_Of (Subp_Info_Array, Loc),
+ Expressions => New_List (
+ Convert_To (Standard_Integer,
+ Make_Identifier (Loc, Name_Subp_Id)))),
+ Selector_Name =>
+ Make_Identifier (Loc, Name_Addr))))))));
+ Analyze (Last (Decls));
+
Pkg_RPC_Receiver_Body :=
Make_Subprogram_Body (Loc,
Specification => Pkg_RPC_Receiver_Spec,
Prefix =>
New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc),
Attribute_Name =>
- Name_Version))))));
+ Name_Version),
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Subp_Info_Array, Loc),
+ Attribute_Name =>
+ Name_Address),
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Subp_Info_Array, Loc),
+ Attribute_Name =>
+ Name_Length))))));
Append_To (Decls, Dummy_Register_Body);
Analyze (Dummy_Register_Body);
-------------------
procedure Add_Stub_Type
- (Designated_Type : in Entity_Id;
- RACW_Type : in Entity_Id;
- Decls : in List_Id;
+ (Designated_Type : Entity_Id;
+ RACW_Type : Entity_Id;
+ Decls : List_Id;
Stub_Type : out Entity_Id;
Stub_Type_Access : out Entity_Id;
Object_RPC_Receiver : out Entity_Id;
Defining_Identifier => Stub_Type_Access,
Type_Definition =>
Make_Access_To_Object_Definition (Loc,
+ All_Present => True,
Subtype_Indication => New_Occurrence_Of (Stub_Type, Loc)));
Append_To (Decls, Stub_Type_Access_Declaration);
Subprogram_Id)));
Current_Parameter := First (Ordered_Parameters_List);
-
while Current_Parameter /= Empty loop
-
declare
Typ : constant Node_Id :=
- Parameter_Type (Current_Parameter);
+ Parameter_Type (Current_Parameter);
Etyp : Entity_Id;
Constrained : Boolean;
Value : Node_Id;
Extra_Parameter : Entity_Id;
begin
-
if Is_RACW_Controlling_Formal (Current_Parameter, Object_Type) then
-- In the case of a controlling formal argument, we marshall
-- have changed since they are remote, so we do not read them
-- from the stream.
- Current_Parameter :=
- First (Ordered_Parameters_List);
-
+ Current_Parameter := First (Ordered_Parameters_List);
while Current_Parameter /= Empty loop
-
declare
Typ : constant Node_Id :=
- Parameter_Type (Current_Parameter);
+ Parameter_Type (Current_Parameter);
Etyp : Entity_Id;
Value : Node_Id;
+
begin
- Value := New_Occurrence_Of
- (Defining_Identifier (Current_Parameter), Loc);
+ Value :=
+ New_Occurrence_Of
+ (Defining_Identifier (Current_Parameter), Loc);
if Nkind (Typ) = N_Access_Definition then
Value := Make_Explicit_Dereference (Loc, Value);
end if;
if (Out_Present (Current_Parameter)
- or else Nkind (Typ) = N_Access_Definition)
+ or else Nkind (Typ) = N_Access_Definition)
and then Etyp /= Object_Type
then
Append_To (Non_Asynchronous_Statements,
Prefix => New_Occurrence_Of (Stream_Parameter, Loc),
Attribute_Name => Name_Access),
New_Occurrence_Of (Standard_True, Loc))));
+
Prepend_To (Non_Asynchronous_Statements,
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Standard_Boolean, Loc),
Prefix => New_Occurrence_Of (Stream_Parameter, Loc),
Attribute_Name => Name_Access),
New_Occurrence_Of (Standard_False, Loc))));
+
Append_To (Statements,
Make_Implicit_If_Statement (Nod,
Condition => Asynchronous,
end if;
end Build_General_Calling_Stubs;
+ ------------------------------
+ -- Build_Get_Unique_RP_Call --
+ ------------------------------
+
+ function Build_Get_Unique_RP_Call
+ (Loc : Source_Ptr;
+ Pointer : Entity_Id;
+ Stub_Type : Entity_Id) return List_Id
+ is
+ begin
+ return New_List (
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Occurrence_Of (RTE (RE_Get_Unique_Remote_Pointer), Loc),
+ Parameter_Associations => New_List (
+ Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access),
+ New_Occurrence_Of (Pointer, Loc)))),
+
+ Make_Assignment_Statement (Loc,
+ Name =>
+ Make_Selected_Component (Loc,
+ Prefix =>
+ New_Occurrence_Of (Pointer, Loc),
+ Selector_Name =>
+ New_Occurrence_Of (Tag_Component
+ (Designated_Type (Etype (Pointer))), Loc)),
+ Expression =>
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Stub_Type, Loc),
+ Attribute_Name =>
+ Name_Tag)));
+
+ -- Note: The assignment to Pointer._Tag is safe here because
+ -- we carefully ensured that Stub_Type has exactly the same layout
+ -- as System.Partition_Interface.RACW_Stub_Type.
+
+ end Build_Get_Unique_RP_Call;
+
+ ----------------------------------------
+ -- Build_Remote_Subprogram_Proxy_Type --
+ ----------------------------------------
+
+ function Build_Remote_Subprogram_Proxy_Type
+ (Loc : Source_Ptr;
+ ACR_Expression : Node_Id) return Node_Id
+ is
+ begin
+ return
+ Make_Record_Definition (Loc,
+ Tagged_Present => True,
+ Limited_Present => True,
+ Component_List =>
+ Make_Component_List (Loc,
+
+ Component_Items => New_List (
+ Make_Component_Declaration (Loc,
+ Make_Defining_Identifier (Loc,
+ Name_All_Calls_Remote),
+ Make_Component_Definition (Loc,
+ Subtype_Indication =>
+ New_Occurrence_Of (Standard_Boolean, Loc)),
+ ACR_Expression),
+
+ Make_Component_Declaration (Loc,
+ Make_Defining_Identifier (Loc,
+ Name_Receiver),
+ Make_Component_Definition (Loc,
+ Subtype_Indication =>
+ New_Occurrence_Of (RTE (RE_Address), Loc)),
+ New_Occurrence_Of (RTE (RE_Null_Address), Loc)),
+
+ Make_Component_Declaration (Loc,
+ Make_Defining_Identifier (Loc,
+ Name_Subp_Id),
+ Make_Component_Definition (Loc,
+ Subtype_Indication =>
+ New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc))))));
+ end Build_Remote_Subprogram_Proxy_Type;
+
-----------------------------------
-- Build_Ordered_Parameters_List --
-----------------------------------
Unconstrained_List : List_Id;
Current_Parameter : Node_Id;
+ First_Parameter : Node_Id;
+ For_RAS : Boolean := False;
+
begin
if not Present (Parameter_Specifications (Spec)) then
return New_List;
Constrained_List := New_List;
Unconstrained_List := New_List;
+ First_Parameter := First (Parameter_Specifications (Spec));
+
+ if Nkind (Parameter_Type (First_Parameter)) = N_Access_Definition
+ and then Chars (Defining_Identifier (First_Parameter)) = Name_uS
+ then
+ For_RAS := True;
+ end if;
-- Loop through the parameters and add them to the right list
- Current_Parameter := First (Parameter_Specifications (Spec));
+ Current_Parameter := First_Parameter;
while Current_Parameter /= Empty loop
-
- if Nkind (Parameter_Type (Current_Parameter)) = N_Access_Definition
+ if (Nkind (Parameter_Type (Current_Parameter)) = N_Access_Definition
or else
- Is_Constrained (Etype (Parameter_Type (Current_Parameter)))
+ Is_Constrained (Etype (Parameter_Type (Current_Parameter)))
or else
- Is_Elementary_Type (Etype (Parameter_Type (Current_Parameter)))
+ Is_Elementary_Type (Etype (Parameter_Type (Current_Parameter))))
+ and then not (For_RAS and then Current_Parameter = First_Parameter)
then
Append_To (Constrained_List, New_Copy (Current_Parameter));
else
Append_List_To (Unconstrained_List, Constrained_List);
return Unconstrained_List;
-
end Build_Ordered_Parameters_List;
----------------------------------
declare
Dist_OK : Entity_Id;
pragma Warnings (Off, Dist_OK);
-
begin
Dist_OK := RTE (RE_Params_Stream_Type);
end;
function Build_RPC_Receiver_Specification
(RPC_Receiver : Entity_Id;
Stream_Parameter : Entity_Id;
- Result_Parameter : Entity_Id)
- return Node_Id
+ Result_Parameter : Entity_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (RPC_Receiver);
Dynamically_Asynchronous : Boolean := False;
Stub_Type : Entity_Id := Empty;
Locator : Entity_Id := Empty;
- New_Name : Name_Id := No_Name)
- return Node_Id
+ New_Name : Name_Id := No_Name) return Node_Id
is
Loc : constant Source_Ptr := Sloc (Vis_Decl);
Spec_To_Use : Node_Id;
- procedure Insert_Partition_Check (Parameter : in Node_Id);
+ procedure Insert_Partition_Check (Parameter : Node_Id);
-- Check that the parameter has been elaborated on the same partition
-- than the controlling parameter (E.4(19)).
-- Insert_Partition_Check --
----------------------------
- procedure Insert_Partition_Check (Parameter : in Node_Id) is
+ procedure Insert_Partition_Check (Parameter : Node_Id) is
Parameter_Entity : constant Entity_Id :=
Defining_Identifier (Parameter);
Condition : Node_Id;
-- then
-- raise Constraint_Error;
-- end if;
- --
+
-- Condition contains the reversed condition. Also, Parameter is
-- dereferenced if it is an access type. We do not check that
-- Parameter is in Stub_Type since such a check has been inserted
Dynamically_Asynchronous : Boolean := False;
Stub_Type : Entity_Id := Empty;
RACW_Type : Entity_Id := Empty;
- Parent_Primitive : Entity_Id := Empty)
- return Node_Id
+ Parent_Primitive : Entity_Id := Empty) return Node_Id
is
Loc : constant Source_Ptr := Sloc (Vis_Decl);
declare
Etyp : Entity_Id;
+ RACW_Controlling : Boolean;
Constrained : Boolean;
Object : Entity_Id;
Expr : Node_Id := Empty;
Object := Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
Set_Ekind (Object, E_Variable);
- if
- Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type)
- then
+ RACW_Controlling :=
+ Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type);
+
+ if RACW_Controlling then
+
-- We have a controlling formal parameter. Read its address
-- rather than a real object. The address is in Unsigned_64
-- form.
Is_Constrained (Etyp) or else Is_Elementary_Type (Etyp);
if In_Present (Current_Parameter)
- or else not Out_Present (Current_Parameter)
- or else not Constrained
+ or else not Out_Present (Current_Parameter)
+ or else not Constrained
+ or else RACW_Controlling
then
-- If an input parameter is contrained, then its reading is
-- deferred until the beginning of the subprogram body. If
-- the object declaration and the variable is set using
-- 'Input instead of 'Read.
- if Constrained then
+ if Constrained and then not RACW_Controlling then
Append_To (Statements,
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Etyp, Loc),
if
Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type)
then
-
if Nkind (Parameter_Type (Current_Parameter)) /=
N_Access_Definition
then
Unchecked_Convert_To (RACW_Type,
OK_Convert_To (RTE (RE_Address),
New_Occurrence_Of (Object, Loc))))));
+
else
Append_To (Parameter_List,
Make_Parameter_Association (Loc,
OK_Convert_To (RTE (RE_Address),
New_Occurrence_Of (Object, Loc)))));
end if;
+
else
Append_To (Parameter_List,
Make_Parameter_Association (Loc,
Parameter_Associations => Parameter_List));
Append_List_To (Statements, After_Statements);
-
end if;
if Asynchronous and then not Dynamically_Asynchronous then
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Statements,
Exception_Handlers => New_List (Excep_Handler)));
-
end Build_Subprogram_Receiving_Stubs;
------------------------
Spec : Node_Id;
Object_Type : Entity_Id := Empty;
Stub_Type : Entity_Id := Empty;
- New_Name : Name_Id := No_Name)
- return Node_Id
+ New_Name : Name_Id := No_Name) return Node_Id
is
Parameters : List_Id := No_List;
- Current_Parameter : Node_Id;
- Current_Type : Node_Id;
- Current_Etype : Entity_Id;
+ Current_Parameter : Node_Id;
+ Current_Identifier : Entity_Id;
+ Current_Type : Node_Id;
+ Current_Etype : Entity_Id;
Name_For_New_Spec : Name_Id;
begin
if New_Name = No_Name then
+ pragma Assert (Nkind (Spec) = N_Function_Specification
+ or else Nkind (Spec) = N_Procedure_Specification);
+
Name_For_New_Spec := Chars (Defining_Unit_Name (Spec));
else
Name_For_New_Spec := New_Name;
end if;
if Present (Parameter_Specifications (Spec)) then
-
Parameters := New_List;
Current_Parameter := First (Parameter_Specifications (Spec));
-
while Current_Parameter /= Empty loop
-
- Current_Type := Parameter_Type (Current_Parameter);
+ Current_Identifier := Defining_Identifier (Current_Parameter);
+ Current_Type := Parameter_Type (Current_Parameter);
if Nkind (Current_Type) = N_Access_Definition then
Current_Etype := Entity (Subtype_Mark (Current_Type));
- if Object_Type = Empty then
+ if Present (Object_Type) then
+ pragma Assert (
+ Root_Type (Current_Etype) = Root_Type (Object_Type));
Current_Type :=
Make_Access_Definition (Loc,
- Subtype_Mark =>
- New_Occurrence_Of (Current_Etype, Loc));
+ Subtype_Mark => New_Occurrence_Of (Stub_Type, Loc));
else
- pragma Assert
- (Root_Type (Current_Etype) = Root_Type (Object_Type));
Current_Type :=
Make_Access_Definition (Loc,
- Subtype_Mark => New_Occurrence_Of (Stub_Type, Loc));
+ Subtype_Mark =>
+ New_Occurrence_Of (Current_Etype, Loc));
end if;
else
end if;
New_Identifier := Make_Defining_Identifier (Loc,
- Chars (Defining_Identifier (Current_Parameter)));
+ Chars (Current_Identifier));
Append_To (Parameters,
Make_Parameter_Specification (Loc,
end loop;
end if;
- if Nkind (Spec) = N_Function_Specification then
- return
- Make_Function_Specification (Loc,
- Defining_Unit_Name =>
- Make_Defining_Identifier (Loc,
- Chars => Name_For_New_Spec),
- Parameter_Specifications => Parameters,
- Subtype_Mark =>
- New_Occurrence_Of (Entity (Subtype_Mark (Spec)), Loc));
+ case Nkind (Spec) is
- else
- return
- Make_Procedure_Specification (Loc,
- Defining_Unit_Name =>
- Make_Defining_Identifier (Loc,
- Chars => Name_For_New_Spec),
- Parameter_Specifications => Parameters);
- end if;
+ when N_Function_Specification | N_Access_Function_Definition =>
+ return
+ Make_Function_Specification (Loc,
+ Defining_Unit_Name =>
+ Make_Defining_Identifier (Loc,
+ Chars => Name_For_New_Spec),
+ Parameter_Specifications => Parameters,
+ Subtype_Mark =>
+ New_Occurrence_Of (Entity (Subtype_Mark (Spec)), Loc));
+
+ when N_Procedure_Specification | N_Access_Procedure_Definition =>
+ return
+ Make_Procedure_Specification (Loc,
+ Defining_Unit_Name =>
+ Make_Defining_Identifier (Loc,
+ Chars => Name_For_New_Spec),
+ Parameter_Specifications => Parameters);
+ when others =>
+ raise Program_Error;
+ end case;
end Copy_Specification;
---------------------------
-- Expand_All_Calls_Remote_Subprogram_Call --
---------------------------------------------
- procedure Expand_All_Calls_Remote_Subprogram_Call (N : in Node_Id) is
+ procedure Expand_All_Calls_Remote_Subprogram_Call (N : Node_Id) is
Called_Subprogram : constant Entity_Id := Entity (Name (N));
RCI_Package : constant Entity_Id := Scope (Called_Subprogram);
Loc : constant Source_Ptr := Sloc (N);
-- Expand_Calling_Stubs_Bodies --
---------------------------------
- procedure Expand_Calling_Stubs_Bodies (Unit_Node : in Node_Id) is
+ procedure Expand_Calling_Stubs_Bodies (Unit_Node : Node_Id) is
Spec : constant Node_Id := Specification (Unit_Node);
Decls : constant List_Id := Visible_Declarations (Spec);
-- Expand_Receiving_Stubs_Bodies --
-----------------------------------
- procedure Expand_Receiving_Stubs_Bodies (Unit_Node : in Node_Id) is
+ procedure Expand_Receiving_Stubs_Bodies (Unit_Node : Node_Id) is
Spec : Node_Id;
Decls : List_Id;
Temp : List_Id;
function Get_Subprogram_Id (E : Entity_Id) return Int is
Current_Declaration : Node_Id;
- Result : Int := 0;
+ Result : Int := First_RCI_Subprogram_Id;
begin
pragma Assert
(Loc : Source_Ptr;
Stream : Node_Id;
Object : Entity_Id;
- Etyp : Entity_Id := Empty)
- return Node_Id
+ Etyp : Entity_Id := Empty) return Node_Id
is
Typ : Entity_Id;
(Loc : Source_Ptr;
Stream : Entity_Id;
Object : Node_Id;
- Etyp : Entity_Id)
- return Node_Id
+ Etyp : Entity_Id) return Node_Id
is
Write_Attribute : Name_Id := Name_Write;
(Loc : Source_Ptr;
Stream : Node_Id;
Object : Node_Id;
- Etyp : Entity_Id)
- return Node_Id
+ Etyp : Entity_Id) return Node_Id
is
Write_Attribute : Name_Id := Name_Write;
-- RACW_Type_Is_Asynchronous --
-------------------------------
- procedure RACW_Type_Is_Asynchronous (RACW_Type : in Entity_Id) is
+ procedure RACW_Type_Is_Asynchronous (RACW_Type : Entity_Id) is
N : constant Node_Id := Asynchronous_Flags_Table.Get (RACW_Type);
pragma Assert (N /= Empty);
-
begin
Replace (N, New_Occurrence_Of (Standard_True, Sloc (N)));
end RACW_Type_Is_Asynchronous;
function RCI_Package_Locator
(Loc : Source_Ptr;
- Package_Spec : Node_Id)
- return Node_Id
+ Package_Spec : Node_Id) return Node_Id
is
Inst : constant Node_Id :=
Make_Package_Instantiation (Loc,
-----------------------------------------------
procedure Remote_Types_Tagged_Full_View_Encountered
- (Full_View : in Entity_Id)
+ (Full_View : Entity_Id)
is
Stub_Elements : constant Stub_Structure :=
Stubs_Table.Get (Full_View);
return Unit_Name;
end Scope_Of_Spec;
+ --------------------------
+ -- Underlying_RACW_Type --
+ --------------------------
+
+ function Underlying_RACW_Type (RAS_Typ : Entity_Id) return Entity_Id is
+ Record_Type : Entity_Id;
+
+ begin
+ if Ekind (RAS_Typ) = E_Record_Type then
+ Record_Type := RAS_Typ;
+ else
+ pragma Assert (Present (Equivalent_Type (RAS_Typ)));
+ Record_Type := Equivalent_Type (RAS_Typ);
+ end if;
+
+ return
+ Etype (Subtype_Indication (
+ Component_Definition (
+ First (Component_Items (Component_List (
+ Type_Definition (Declaration_Node (Record_Type))))))));
+ end Underlying_RACW_Type;
+
end Exp_Dist;
E : Entity_Id) return Node_Id;
-- Build a literal representing the remote subprogram identifier of E
+ function Copy_Specification
+ (Loc : Source_Ptr;
+ Spec : Node_Id;
+ Object_Type : Entity_Id := Empty;
+ Stub_Type : Entity_Id := Empty;
+ New_Name : Name_Id := No_Name) return Node_Id;
+ -- Build a subprogram specification from another one, or from
+ -- an access-to-subprogram definition. If Object_Type is not Empty
+ -- and any access to Object_Type is found, then it is replaced by an
+ -- access to Stub_Type. If New_Name is given, then it will be used as
+ -- the name for the newly created spec.
+
+ function Underlying_RACW_Type
+ (RAS_Typ : Entity_Id) return Entity_Id;
+ -- Given a remote access-to-subprogram type or its equivalent
+ -- record type, return the RACW type generated to implement it.
+
end Exp_Dist;
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2001 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- --
-- a packed array. There are two reasonable rules for deciding this:
-- Store the first bit at right end (low order) word. This means
- -- that the scaled subscript can be used directly as a right shift
+ -- that the scaled subscript can be used directly as a left shift
-- count (if we put bit 0 at the left end, then we need an extra
- -- subtract to compute the shift count.
+ -- subtract to compute the shift count).
-- Layout the bits so that if the packed boolean array is overlaid on
-- a record, using unchecked conversion, then bit 0 of the array is
-- that a worthwhile price to pay for the consistency.
-- One more important point arises in the case where we have a constrained
- -- subtype of an unconstrained array. Take the case of 20-bits. For the
+ -- subtype of an unconstrained array. Take the case of 20 bits. For the
-- unconstrained representation, we would use an array of bytes:
-- Little-endian case
-- --
-- GNAT COMPILER COMPONENTS --
-- --
--- G N A T . P E R F E C T _ H A S H . G E N E R A T O R S --
+-- G N A T . P E R F E C T _ H A S H _ G E N E R A T O R S --
-- --
-- B o d y --
-- --
--- Copyright (C) 2002-2003 Ada Core Technologies, Inc. --
+-- Copyright (C) 2002-2004 Ada Core Technologies, 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 GNAT.OS_Lib; use GNAT.OS_Lib;
with GNAT.Table;
-package body GNAT.Perfect_Hash.Generators is
+package body GNAT.Perfect_Hash_Generators is
-- We are using the algorithm of J. Czech as described in Zbigniew
-- J. Czech, George Havas, and Bohdan S. Majewski ``An Optimal
end case;
end Value;
-end GNAT.Perfect_Hash.Generators;
+end GNAT.Perfect_Hash_Generators;
-- --
-- GNAT COMPILER COMPONENTS --
-- --
--- G N A T . P E R F E C T _ H A S H . G E N E R A T O R S --
+-- G N A T . P E R F E C T _ H A S H _ G E N E R A T O R S --
-- --
-- S p e c --
-- --
--- Copyright (C) 2002 Ada Core Technologies, Inc. --
+-- Copyright (C) 2002-2004 Ada Core Technologies, 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- --
-- --
------------------------------------------------------------------------------
--- This package provides a single generator of static minimal perfect
--- hash functions. No collisions occur and each item can be retrieved
--- from the table in one probe (perfect property). The hash table
--- size corresponds to the exact size of W and *no larger* (minimal
--- property). The key set has to be know in advance (static
--- property). The hash functions are also order preservering. If w2
--- is inserted after w1 in the generator, then f (w1) < f (w2). These
--- hashing functions are convenient for use with realtime applications.
-
-package GNAT.Perfect_Hash.Generators is
+-- This package provides a generator of static minimal perfect hash
+-- functions. To understand what a perfect hash function is, we
+-- define several notions. These definitions are inspired from the
+-- following paper:
+
+-- Zbigniew J. Czech, George Havas, and Bohdan S. Majewski ``An
+-- Optimal Algorithm for Generating Minimal Perfect Hash Functions'',
+-- Information Processing Letters, 43(1992) pp.257-264, Oct.1992
+
+-- Let W be a set of m words. A hash function h is a function that
+-- maps the set of words W into some given interval of integers
+-- [0, k-1], where k is an integer, usually k >= m. h (w) where w
+-- is a word computes an address or an integer from I for the
+-- storage or the retrieval of that item. The storage area used to
+-- store items is known as a hash table. Words for which the same
+-- address is computed are called synonyms. Due to the existence
+-- of synonyms a situation called collision may arise in which two
+-- items w1 and w2 have the same address. Several schemes for
+-- resolving known. A perfect hash function is an injection from
+-- the word set W to the integer interval I with k >= m. If k = m,
+-- then h is a minimal perfect hash function. A hash function is
+-- order preserving if it puts entries into the hash table in a
+-- prespecified order.
+
+-- A minimal perfect hash function is defined by two properties:
+
+-- Since no collisions occur each item can be retrieved from the
+-- table in *one* probe. This represents the "perfect" property.
+
+-- The hash table size corresponds to the exact size of W and
+-- *no larger*. This represents the "minimal" property.
+
+-- The functions generated by this package require the key set to
+-- be known in advance (they are "static" hash functions).
+-- The hash functions are also order preservering. If w2 is inserted
+-- after w1 in the generator, then f (w1) < f (w2). These hashing
+-- functions are convenient for use with realtime applications.
+
+package GNAT.Perfect_Hash_Generators is
Default_K_To_V : constant Float := 2.05;
-- Default ratio for the algorithm. When K is the number of keys,
Default_Optimization : constant Optimization := CPU_Time;
-- Optimize either the memory space or the execution time.
- Verbose : Boolean := False;
+ Verbose : Boolean := False;
+ -- Comment required ???
procedure Initialize
(Seed : Natural;
-- Return the value of the component (I, J) of the table
-- Name. When the table has only one dimension, J is ignored.
-end GNAT.Perfect_Hash.Generators;
+end GNAT.Perfect_Hash_Generators;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- G N A T . P E R F E C T _ H A S H --
--- --
--- S p e c --
--- --
--- Copyright (C) 2002-2003 Ada Core Technologies, 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- --
--- ware Foundation; either version 2, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING. If not, write --
--- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
--- --
--- As a special exception, if other files instantiate generics from this --
--- unit, or you link this unit with other files to produce an executable, --
--- this unit does not by itself cause the resulting executable to be --
--- covered by the GNU General Public License. This exception does not --
--- however invalidate any other reasons why the executable file might be --
--- covered by the GNU Public License. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-package GNAT.Perfect_Hash is
-pragma Pure (Perfect_Hash);
-
- -- The packages in this hierarchy implement perfect hash
- -- functions. To understand what a perfect hash function is, we
- -- define several notions. These definitions are inspired from the
- -- following paper:
- --
- -- Zbigniew J. Czech, George Havas, and Bohdan S. Majewski ``An
- -- Optimal Algorithm for Generating Minimal Perfect Hash Functions'',
- -- Information Processing Letters, 43(1992) pp.257-264, Oct.1992
- --
- -- Let W be a set of m words. A hash function h is a function that
- -- maps the set of words W into some given interval of integers
- -- [0, k-1], where k is an integer, usually k >= m. h (w) where w
- -- is a word computes an address or an integer from I for the
- -- storage or the retrieval of that item. The storage area used to
- -- store items is known as a hash table. Words for which the same
- -- address is computed are called synonyms. Due to the existence
- -- of synonyms a situation called collision may arise in which two
- -- items w1 and w2 have the same address. Several schemes for
- -- resolving known. A perfect hash function is an injection from
- -- the word set W to the integer interval I with k >= m. If k = m,
- -- then h is a minimal perfect hash function. A hash function is
- -- order preserving if it puts entries into the hash table in a
- -- prespecified order.
- --
- -- A minimal perfect hash function is defined by two properties:
- -- * Since no collisions occur each item can be retrieved from the
- -- table in *one* probe. This represents the "perfect" property.
- -- * The hash table size corresponds to the exact size of W and
- -- *no larger*. This represents the "minimal" property.
-
-end GNAT.Perfect_Hash;
-- On all platforms except VMS, this package is not intended to be used
-- within a shared library, symbolic tracebacks are only supported for the
--- main executable and not for shared libraries.
--- You should consider using gdb to obtain symbolic traceback in such cases.
+-- main executable and not for shared libraries. You should consider using
+-- gdb to obtain symbolic traceback in such cases.
-- On VMS, there is no restriction on using this facility with shared
-- libraries. However, the OS should be at least v7.3-1 and OS patch
position so that it is aligned to ALIGN bits and is SIZE bytes long. */
extern tree make_aligning_type (tree, int, tree);
+/* Ensure that TYPE has SIZE and ALIGN. Make and return a new padded type
+ if needed. We have already verified that SIZE and TYPE are large enough.
+
+ GNAT_ENTITY and NAME_TRAILER are used to name the resulting record and
+ to issue a warning.
+
+ IS_USER_TYPE is true if we must be sure we complete the original type.
+
+ DEFINITION is true if this type is being defined.
+
+ SAME_RM_SIZE is true if the RM_Size of the resulting type is to be
+ set to its TYPE_SIZE; otherwise, it's set to the RM_Size of the original
+ type. */
+extern tree maybe_pad_type (tree, tree, unsigned int, Entity_Id,
+ const char *, bool, bool, bool);
+
/* Given a GNU tree and a GNAT list of choices, generate an expression to test
the value passed against the list of choices. */
extern tree choices_to_gnu (tree, Node_Id);
RETURNS_UNCONSTRAINED is true if the function returns an unconstrained
object. RETURNS_BY_REF is true if the function returns by reference.
RETURNS_WITH_DSP is true if the function is to return with a
- depressed stack pointer. */
-extern tree create_subprog_type (tree, tree, tree, bool, bool, bool);
+ depressed stack pointer. RETURNS_BY_TARGET_PTR is true if the function
+ is to be passed (as its first parameter) the address of the place to copy
+ its result. */
+extern tree create_subprog_type (tree, tree, tree, bool, bool, bool, bool);
/* Return a copy of TYPE, but safe to modify in any way. */
extern tree copy_type (tree);
* Pragma CPP_Virtual::
* Pragma CPP_Vtable::
* Pragma Debug::
+* Pragma Detect_Blocking::
* Pragma Elaboration_Checks::
* Pragma Eliminate::
* Pragma Export_Exception::
* GNAT.Memory_Dump (g-memdum.ads)::
* GNAT.Most_Recent_Exception (g-moreex.ads)::
* GNAT.OS_Lib (g-os_lib.ads)::
-* GNAT.Perfect_Hash.Generators (g-pehage.ads)::
+* GNAT.Perfect_Hash_Generators (g-pehage.ads)::
* GNAT.Regexp (g-regexp.ads)::
* GNAT.Registry (g-regist.ads)::
* GNAT.Regpat (g-regpat.ads)::
* Pragma CPP_Virtual::
* Pragma CPP_Vtable::
* Pragma Debug::
+* Pragma Detect_Blocking::
* Pragma Elaboration_Checks::
* Pragma Eliminate::
* Pragma Export_Exception::
declarations, so you can use pragma @code{Debug} to intersperse calls to
debug procedures in the middle of declarations.
+@node Pragma Detect_Blocking
+@unnumberedsec Pragma Detect_Blocking
+@findex Detect_Blocking
+@noindent
+Syntax:
+
+@smallexample @c ada
+pragma Detect_Blocking;
+@end smallexample
+
+@noindent
+This is a configuration pragma that forces the detection of potentially
+blocking operations within a protected operation, and to raise Program_Error
+if that happens.
+
@node Pragma Elaboration_Checks
@unnumberedsec Pragma Elaboration_Checks
@cindex Elaboration control
* GNAT.Memory_Dump (g-memdum.ads)::
* GNAT.Most_Recent_Exception (g-moreex.ads)::
* GNAT.OS_Lib (g-os_lib.ads)::
-* GNAT.Perfect_Hash.Generators (g-pehage.ads)::
+* GNAT.Perfect_Hash_Generators (g-pehage.ads)::
* GNAT.Regexp (g-regexp.ads)::
* GNAT.Registry (g-regist.ads)::
* GNAT.Regpat (g-regpat.ads)::
including a portable spawn procedure, and access to environment variables
and error return codes.
-@node GNAT.Perfect_Hash.Generators (g-pehage.ads)
-@section @code{GNAT.Perfect_Hash.Generators} (@file{g-pehage.ads})
-@cindex @code{GNAT.Perfect_Hash.Generators} (@file{g-pehage.ads})
+@node GNAT.Perfect_Hash_Generators (g-pehage.ads)
+@section @code{GNAT.Perfect_Hash_Generators} (@file{g-pehage.ads})
+@cindex @code{GNAT.Perfect_Hash_Generators} (@file{g-pehage.ads})
@cindex Hash functions
@noindent
@set FILE gnat_ugn_vms
@end ifset
-
-
@settitle @value{EDITION} User's Guide for Native Platforms / @value{PLATFORM}
@dircategory GNU Ada tools
@direntry
@end titlepage
-
@ifnottex
@node Top, About This Guide, (dir), (dir)
@top @value{EDITION} User's Guide
* How gnatmake Works::
* Examples of gnatmake Usage::
-
Improving Performance
* Performance Considerations::
* Reducing the Size of Ada Executables with gnatelim::
* An Extended Example::
* Project File Complete Syntax::
-
The Cross-Referencing Tools gnatxref and gnatfind
* gnatxref Switches::
* Examples of gnatxref Usage::
* Examples of gnatfind Usage::
-
The GNAT Pretty-Printer gnatpp
* Switches for gnatpp::
* Formatting Rules::
-
File Name Krunching Using gnatkr
* About gnatkr::
* GNAT and COM/DCOM Objects::
@end ifset
-
* Index::
@end menu
@end ifnottex
``GNAT'' in the remainder of this document.
@end ifset
-
-
@menu
* What This Guide Contains::
* What You Should Know before Reading This Guide::
version of an Ada source file with control over casing, indentation,
comment placement, and other elements of program presentation style.
-
@item
@ref{File Name Krunching Using gnatkr}, describes the @code{gnatkr}
file name krunching utility, used to handle shortened
@end ifset
@end itemize
-
@c *************************************************
@node What You Should Know before Reading This Guide
@c *************************************************
the ``@code{\}'' character should be used instead.
@end ifset
-
-
@c ****************************
@node Getting Started with GNAT
@chapter Getting Started with GNAT
utility program that, given the name of the main program, automatically
performs the necessary compilation, binding and linking steps.
-
@node Running a Simple Ada Program
@section Running a Simple Ada Program
@noindent
appear in response to this command.
-
@c ****************************************
@node Running a Program with Multiple Units
@section Running a Program with Multiple Units
* Simple Debugging with GPS::
@end menu
-
@node Building a New Program with GPS
@subsection Building a New Program with GPS
@noindent
The file will be saved in the same directory you specified as the
location of the default project file.
-
@item @emph{Updating the project file}
You need to add the new source file to the project.
terminate this GPS session.
@end enumerate
-
-
@node Simple Debugging with GPS
@subsection Simple Debugging with GPS
@noindent
You will see information about @code{N} appear in the @code{Debugger Data}
pane, showing the value as 5.
-
@item @emph{Assigning a new value to a variable}
Right click on the @code{N} in the @code{Debugger Data} pane, and
@end enumerate
@end enumerate
-
@node Introduction to Glide and GVD
@section Introduction to Glide and GVD
@cindex Glide
GNAT uses the current directory for temporary files.
@end ifset
-
@c *************************
@node Compiling Using gcc
@chapter Compiling Using @code{gcc}
@end smallexample
@end ifclear
-
@c NEED TO CHECK THIS FOR VMS
@noindent
@end ifclear
@end itemize
-
@node Output and Error Message Control
@subsection Output and Error Message Control
@findex stderr
Additional details on incorrect parameters
@end itemize
-
@item -gnatq
@cindex @option{-gnatq} (@code{gcc})
@ifclear vms
@end table
-
@node Warning Message Control
@subsection Warning Message Control
@cindex Warning messages
@item
Attempt to return local value by reference
-
@item
Premature instantiation of a generic body
@item
Accidental hiding of name by child unit
-
@item
Access before elaboration detected at compile time
@end table
-
@node Debugging and Assertion Control
@subsection Debugging and Assertion Control
to the default checks described above.
@end ifset
-
@table @option
@c !sort!
@item -gnatVa
the validity checking mode at the program source level, and also allows for
temporary disabling of validity checks.
-
@node Style Checking
@subsection Style Checking
@findex Style checking
is an operating systems issue, and must be addressed with the
appropriate operating systems commands.
-
@node Using gcc for Syntax Checking
@subsection Using @code{gcc} for Syntax Checking
@table @option
(@pxref{Renaming Files Using gnatchop}).
@end table
-
@node Using gcc for Semantic Checking
@subsection Using @code{gcc} for Semantic Checking
@table @option
For the source file naming rules, @xref{File Naming Rules}.
@end table
-
@node Subprogram Inlining Control
@subsection Subprogram Inlining Control
@end table
-
@node Integrated Preprocessing
@subsection Integrated Preprocessing
@end ifset
-
@node Search Paths and the Run-Time Library (RTL)
@section Search Paths and the Run-Time Library (RTL)
in compiling sources from multiple directories. This can make
development environments much more flexible.
-
@node Order of Compilation Issues
@section Order of Compilation Issues
to be read by the @code{gnatlink} utility used to link the Ada application.
@end enumerate
-
@node Running gnatbind
@section Running @code{gnatbind}
for both @code{gnatbind} and @code{gnatlink} will cause the program to
be generated in C (and compiled using the gnu C compiler).
-
@node Switches for gnatbind
@section Switches for @command{gnatbind}
no arguments.
@end ifclear
-
@node Consistency-Checking Modes
@subsection Consistency-Checking Modes
consists of elaboration of these units in an appropriate order.
@end table
-
@node Command-Line Access
@section Command-Line Access
@code{gnat_argv} from the @code{argc} and @code{argv} values passed to
it.
-
@node Search Paths for gnatbind
@section Search Paths for @code{gnatbind}
after accessing the Ada units.
@end table
-
@c ------------------------------------
@node Linking Using gnatlink
@chapter Linking Using @code{gnatlink}
if you want to specify library paths
only.
-@item
-@code{gnatmake} examines both an ALI file and its corresponding object file
-for consistency. If an ALI is more recent than its corresponding object,
-or if the object file is missing, the corresponding source will be recompiled.
-Note that @code{gnatmake} expects an ALI and the corresponding object file
-to be in the same directory.
-
@item
@code{gnatmake} will ignore any files whose ALI file is write-protected.
This may conveniently be used to exclude standard libraries from
previous compilations without incorrectly depending on them.
First a definition: an object file is considered @dfn{up to date} if the
-corresponding ALI file exists and its time stamp predates that of the
-object file and if all the source files listed in the
+corresponding ALI file exists and if all the source files listed in the
dependency section of this ALI file have time stamps matching those in
the ALI file. This means that neither the source file itself nor any
files that it depends on have been modified, and hence there is no need
displaying commands it is executing.
@end table
-
@c *************************
@node Improving Performance
@chapter Improving Performance
@end menu
@end ifnottex
-
@c *****************************
@node Performance Considerations
@section Performance Considerations
executables which run more slowly. See further discussion of this point
in @pxref{Inlining of Subprograms}.
-
@node Debugging Optimized Code
@subsection Debugging Optimized Code
@cindex Debugging optimized code
which removes both debugging information and global symbols.
@end ifclear
-
@node Inlining of Subprograms
@subsection Inlining of Subprograms
from scratch after that, because you need a consistent @file{gnat.adc} file
during the entire compilation.
-
@node Making Your Executables Smaller
@subsection Making Your Executables Smaller
@end enumerate
-
-
-
@c ********************************
@node Renaming Files Using gnatchop
@chapter Renaming Files Using @code{gnatchop}
time you compile, regarding the source files that it writes as temporary
files that you throw away.
-
@node Operating gnatchop in Compilation Mode
@section Operating gnatchop in Compilation Mode
Ada_95
C_Pass_By_Copy
Component_Alignment
+ Detect_Blocking
Discard_Names
Elaboration_Checks
Eliminate
@option{^-D^/DIRS_FILE^}. Several Naming Patterns and one excluded pattern
are used in this example.
-
@c *****************************************
@c * G N A T P r o j e c t M a n a g e r *
@c *****************************************
@noindent
By default, the executable file name corresponding to a main source is
-deducted from the main source file name. Through the attributes
+deduced from the main source file name. Through the attributes
@code{Executable} and @code{Executable_Suffix} of package @code{Builder},
it is possible to change this default.
In project @code{Debug} above, the executable file name
library directory. To build executables, @command{gnatmake} will use the
library rather than the individual object files.
-
@c **********************************************
@c * Using Third-Party Libraries through Projects
@c **********************************************
@end smallexample
-
@node The Cross-Referencing Tools gnatxref and gnatfind
@chapter The Cross-Referencing Tools @code{gnatxref} and @code{gnatfind}
@findex gnatxref
@end table
-
@c *********************************
@node The GNAT Pretty-Printer gnatpp
@chapter The GNAT Pretty-Printer @command{gnatpp}
follow the GNAT file naming rules
@end itemize
-
@menu
* Switches for gnatpp::
* Formatting Rules::
* Other gnatpp Switches::
@end menu
-
@node Alignment Control
@subsection Alignment Control
@cindex Alignment control in @command{gnatpp}
The @option{^-A^/ALIGN^} switches are mutually compatible; any combination
is allowed.
-
@node Casing Control
@subsection Casing Control
@cindex Casing control in @command{gnatpp}
@option{^-D@var{file}^/DICTIONARY=@var{file}^} switches are mutually
compatible.
-
@node Construct Layout Control
@subsection Construct Layout Control
@cindex Layout control in @command{gnatpp}
line indentation is also 1)
@end table
-
@node Other Formatting Options
@subsection Other Formatting Options
@end table
-
@node Output File Control
@subsection Output File Control
a required layout in the result source.
@end table
-
@node Formatting Rules
@section Formatting Rules
* Name Casing::
@end menu
-
@node White Space and Empty Lines
@subsection White Space and Empty Lines
Likewise, if for some reason you wish to have a sequence of empty lines,
use a sequence of empty comments instead.
-
@node Formatting Comments
@subsection Formatting Comments
word processor style (that is, moving words between lines and putting as
many words in a line as possible).
-
@node Construct Layout
@subsection Construct Layout
end record; b : integer;
end record;
-
Block : declare Block :
A : Integer := 3; declare
begin A : Integer := 3;
GNAT style layout inserts empty lines as separation for
compound statements, return statements and bodies.
-
@node Name Casing
@subsection Name Casing
@end cartouche
@end smallexample
-
-
@c ***********************************
@node File Name Krunching Using gnatkr
@chapter File Name Krunching Using @code{gnatkr}
library must be installed before the GNAT library if it redefines
any part of it.
-
@node Using the library
@subsection Using the library
@end smallexample
@end itemize
-
@node Stand-alone Ada Libraries
@section Stand-alone Ada Libraries
@cindex Stand-alone library, building, using
particular the set of instructions needed to rebuild a new library and
to use it.
-
@node Using the GNU make Utility
@chapter Using the GNU @code{make} Utility
@findex make
@end smallexample
@end ifclear
-
@node Finding Memory Problems
@chapter Finding Memory Problems
* The GNAT Debug Pool Facility::
@end menu
-
@ifclear vms
@node The gnatmem Tool
@section The @command{gnatmem} Tool
@end ifclear
-
@node The GNAT Debug Pool Facility
@section The GNAT Debug Pool Facility
@findex Debug Pool
High Water Mark: 8
@end smallexample
-
@node Creating Sample Bodies Using gnatstub
@chapter Creating Sample Bodies Using @command{gnatstub}
@findex gnatstub
@end table
-
@node Other Utility Programs
@chapter Other Utility Programs
available in the @code{Glide} @result{} @code{Help} menu.
@end ifclear
-
@node Converting Ada Files to html with gnathtml
@section Converting Ada Files to HTML with @code{gnathtml}
exactly as if the debugger were not present. The following section
describes some of the additional commands that can be given to @code{GDB}.
-
@c *******************************
@node Introduction to GDB Commands
@section Introduction to GDB Commands
tool as described earlier (note that the hexadecimal addresses
need to be specified in C format, with a leading ``0x'').
-
@node Symbolic Traceback
@subsection Symbolic Traceback
@cindex traceback, symbolic
@end ifset
-
@c **************************************
@node Platform-Specific Information for the Run-Time Libraries
@appendix Platform-Specific Information for the Run-Time Libraries
* AIX-Specific Considerations::
@end menu
-
@node Summary of Run-Time Configurations
@section Summary of Run-Time Configurations
-
@multitable @columnfractions .30 .70
@item @b{alpha-openvms}
@item @code{@ @ }@i{rts-native (default)}
@*
@end multitable
-
-
@node Specifying a Run-Time Library
@section Specifying a Run-Time Library
Note also that to take full advantage of Florist and Glade, it is highly
recommended that you use native threads.
-
@node Choosing the Scheduling Policy
@section Choosing the Scheduling Policy
value greater than @code{0.0}, or else use the corresponding @option{-T}
binder option.
-
-
@node Solaris-Specific Considerations
@section Solaris-Specific Considerations
@cindex Solaris Sparc threads libraries
* Building and Debugging 64-bit Applications::
@end menu
-
@node Solaris Threads Issues
@subsection Solaris Threads Issues
(where @code{_SC_NPROCESSORS_CONF} is a system variable).
@end table
-
@node Building and Debugging 64-bit Applications
@subsection Building and Debugging 64-bit Applications
$ gdb64 hello
@end smallexample
-
-
@node IRIX-Specific Considerations
@section IRIX-Specific Considerations
@cindex IRIX thread library
The @emph{n32 ABI} compiler comes with a run-time library based on the
kernel POSIX threads and thus does not have the limitations mentioned above.
-
@node Linux-Specific Considerations
@section Linux-Specific Considerations
@cindex Linux threads libraries
file generated for a simple ``Hello World'' program.
Comments have been added for clarification purposes.
-
@smallexample @c adanocomment
@iftex
@leftskip=0cm
the problem might be (more usually of course you would be debugging
elaboration code in your own application).
-
@node Elaboration Order Handling in GNAT
@appendix Elaboration Order Handling in GNAT
@cindex Order of elaboration
and figuring out which is correct, and then adding the necessary
@code{Elaborate_All} pragmas to ensure the desired order.
-
@node Inline Assembler
@appendix Inline Assembler
@c END OF INLINE ASSEMBLER CHAPTER
@c ===============================
-
-
@c ***********************************
@c * Compatibility and Porting Guide *
@c ***********************************
(@code{Emax}, @code{Mantissa}, etc.), among other items.
@end table
-
@node Implementation-dependent characteristics
@section Implementation-dependent characteristics
@noindent
* Target-specific aspects::
@end menu
-
@node Implementation-defined pragmas
@subsection Implementation-defined pragmas
packing, the meaning of the Size attribute, and the size of access values.
GNAT's approach to these issues is described in @ref{Representation Clauses}.
-
@node Compatibility with Other Ada 95 Systems
@section Compatibility with Other Ada 95 Systems
be implemented. The description of pragmas in this reference manual
indicates whether or not they are applicable to non-VMS systems.
-
-
@ifset unw
@node Microsoft Windows Topics
@appendix Microsoft Windows Topics
@end ifset
-
@c **********************************
@c * GNU Free Documentation License *
@c **********************************
Error_Msg
("?may result in missing run-time elaboration checks");
Error_Msg
- ("?use -gnatE, pragma Suppress (Elaboration_Checks) instead");
+ ("?use -gnatE, pragma Suppress (Elaboration_Check) instead");
end if;
-- Quit if some file needs compiling
-- --
-- GNAT COMPILER COMPONENTS --
-- --
--- G N A T D L L --
+-- G N A T D L L --
-- --
-- B o d y --
-- --
--- Copyright (C) 1997-2002, Free Software Foundation, Inc. --
+-- Copyright (C) 1997-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- --
-- GNATDLL is a Windows specific tool for building a DLL.
-- Both relocatable and non-relocatable DLL's are supported
-with Ada.Text_IO;
-with Ada.Strings.Unbounded;
-with Ada.Exceptions;
-with Ada.Command_Line;
-with GNAT.OS_Lib;
-with GNAT.Command_Line;
+with Ada.Text_IO; use Ada.Text_IO;
+with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
+with Ada.Exceptions; use Ada.Exceptions;
+with Ada.Command_Line; use Ada.Command_Line;
+with GNAT.OS_Lib; use GNAT.OS_Lib;
+with GNAT.Command_Line; use GNAT.Command_Line;
with Gnatvsn;
-with MDLL.Fil;
-with MDLL.Utl;
+with MDLL.Fil; use MDLL.Fil;
+with MDLL.Utl; use MDLL.Utl;
procedure Gnatdll is
- use GNAT;
- use Ada;
- use MDLL;
- use Ada.Strings.Unbounded;
-
- use type OS_Lib.Argument_List;
+ use type GNAT.OS_Lib.Argument_List;
procedure Syntax;
-- Print out usage
procedure Check_Context;
-- Check the context before runing any commands to build the library
- Syntax_Error : exception;
+ Syntax_Error : exception;
-- Raised when a syntax error is detected, in this case a usage info will
-- be displayed.
Default_DLL_Address : constant String := "0x11000000";
-- Default address for non relocatable DLL (Win32)
- Lib_Filename : Unbounded_String := Null_Unbounded_String;
+ Lib_Filename : Unbounded_String := Null_Unbounded_String;
-- The DLL filename that will be created (.dll)
- Def_Filename : Unbounded_String := Null_Unbounded_String;
+ Def_Filename : Unbounded_String := Null_Unbounded_String;
-- The definition filename (.def)
- List_Filename : Unbounded_String := Null_Unbounded_String;
+ List_Filename : Unbounded_String := Null_Unbounded_String;
-- The name of the file containing the objects file to put into the DLL
- DLL_Address : Unbounded_String :=
- To_Unbounded_String (Default_DLL_Address);
+ DLL_Address : Unbounded_String := To_Unbounded_String (Default_DLL_Address);
-- The DLL's base address
- Objects_Files : Argument_List_Access := Null_Argument_List_Access;
+ Gen_Map_File : Boolean := False;
+ -- Set to True if a map file is to be generated
+
+ Objects_Files : Argument_List_Access := MDLL.Null_Argument_List_Access;
-- List of objects to put inside the library
- Ali_Files : Argument_List_Access := Null_Argument_List_Access;
+ Ali_Files : Argument_List_Access := MDLL.Null_Argument_List_Access;
-- For each Ada file specified, we keep arecord of the corresponding
-- ALI file. This list of SLI files is used to build the binder program.
- Options : Argument_List_Access := Null_Argument_List_Access;
- -- A list of options set in the command line.
+ Options : Argument_List_Access := MDLL.Null_Argument_List_Access;
+ -- A list of options set in the command line
- Largs_Options : Argument_List_Access := Null_Argument_List_Access;
- Bargs_Options : Argument_List_Access := Null_Argument_List_Access;
+ Largs_Options : Argument_List_Access := MDLL.Null_Argument_List_Access;
+ Bargs_Options : Argument_List_Access := MDLL.Null_Argument_List_Access;
-- GNAT linker and binder args options
type Build_Mode_State is (Import_Lib, Dynamic_Lib, Dynamic_Lib_Only, Nil);
-- Dynamic_Lib_Only means that only the DLL will be created (no import
-- library).
- Build_Mode : Build_Mode_State := Nil;
- -- Will be set when parsing the command line.
+ Build_Mode : Build_Mode_State := Nil;
+ -- Will be set when parsing the command line
Must_Build_Relocatable : Boolean := True;
-- True means build a relocatable DLL, will be set to False if a
------------
procedure Syntax is
- use Text_IO;
-
- procedure P (Str : in String) renames Text_IO.Put_Line;
-
+ procedure P (Str : String) renames Put_Line;
begin
P ("Usage : gnatdll [options] [list-of-files]");
New_Line;
P (" -a[addr] Build non-relocatable DLL at address <addr>");
P (" if <addr> is not specified use "
& Default_DLL_Address);
+ P (" -m Generate map file");
P (" -n No-import - do not create the import library");
P (" -bargs opts opts are passed to the binder");
P (" -largs opts opts are passed to the linker");
procedure Check (Filename : in String) is
begin
- if not OS_Lib.Is_Regular_File (Filename) then
- Exceptions.Raise_Exception (Context_Error'Identity,
- "Error: " & Filename & " not found.");
+ if not Is_Regular_File (Filename) then
+ Raise_Exception
+ (Context_Error'Identity, "Error: " & Filename & " not found.");
end if;
end Check;
-- No, a better choice would be to use tables ???
-- Limits on what???
- Ofiles : OS_Lib.Argument_List (1 .. Max_Files);
+ Ofiles : Argument_List (1 .. Max_Files);
O : Positive := Ofiles'First;
-- List of object files to put in the library. O is the next entry
-- to be used.
- Afiles : OS_Lib.Argument_List (1 .. Max_Files);
+ Afiles : Argument_List (1 .. Max_Files);
A : Positive := Afiles'First;
- -- List of ALI files. A is the next entry to be used.
+ -- List of ALI files. A is the next entry to be used
- Gopts : OS_Lib.Argument_List (1 .. Max_Options);
+ Gopts : Argument_List (1 .. Max_Options);
G : Positive := Gopts'First;
- -- List of gcc options. G is the next entry to be used.
+ -- List of gcc options. G is the next entry to be used
- Lopts : OS_Lib.Argument_List (1 .. Max_Options);
+ Lopts : Argument_List (1 .. Max_Options);
L : Positive := Lopts'First;
-- A list of -largs options (L is next entry to be used)
- Bopts : OS_Lib.Argument_List (1 .. Max_Options);
+ Bopts : Argument_List (1 .. Max_Options);
B : Positive := Bopts'First;
-- A list of -bargs options (B is next entry to be used)
Build_Import : Boolean := True;
- -- Set to Fals if option -n if specified (no-import).
+ -- Set to Fals if option -n if specified (no-import)
--------------
-- Add_File --
procedure Add_File (Filename : in String) is
begin
- if Fil.Is_Ali (Filename) then
+ if Is_Ali (Filename) then
Check (Filename);
Afiles (A) := new String'(Filename);
A := A + 1;
- elsif Fil.Is_Obj (Filename) then
+ elsif Is_Obj (Filename) then
Check (Filename);
else
-- Unknown file type
- Exceptions.Raise_Exception
+ Raise_Exception
(Syntax_Error'Identity,
"don't know what to do with " & Filename & " !");
end if;
-------------------------
procedure Add_Files_From_List (List_Filename : in String) is
- File : Text_IO.File_Type;
+ File : File_Type;
Buffer : String (1 .. 500);
Last : Natural;
begin
- Text_IO.Open (File, Text_IO.In_File, List_Filename);
+ Open (File, In_File, List_Filename);
- while not Text_IO.End_Of_File (File) loop
- Text_IO.Get_Line (File, Buffer, Last);
+ while not End_Of_File (File) loop
+ Get_Line (File, Buffer, Last);
Add_File (Buffer (1 .. Last));
end loop;
- Text_IO.Close (File);
+ Close (File);
end Add_Files_From_List;
-- Start of processing for Parse_Command_Line
-- scan gnatdll switches
loop
- case Getopt ("g h v q k a? b: d: e: l: n I:") is
+ case Getopt ("g h v q k a? b: d: e: l: n m I:") is
when ASCII.Nul =>
exit;
MDLL.Verbose := True;
if MDLL.Quiet then
- Exceptions.Raise_Exception
+ Raise_Exception
(Syntax_Error'Identity,
"impossible to use -q and -v together.");
end if;
MDLL.Quiet := True;
if MDLL.Verbose then
- Exceptions.Raise_Exception
+ Raise_Exception
(Syntax_Error'Identity,
"impossible to use -v and -q together.");
end if;
if Def_Filename = Null_Unbounded_String then
Def_Filename := To_Unbounded_String
- (Fil.Ext_To (Parameter, "def"));
+ (Ext_To (Parameter, "def"));
end if;
Build_Mode := Dynamic_Lib;
+ when 'm' =>
+
+ Gen_Map_File := True;
+
when 'n' =>
Build_Import := False;
when others =>
raise Invalid_Switch;
-
end case;
end loop;
loop
case Getopt ("*") is
-
when ASCII.Nul =>
exit;
when others =>
Lopts (L) := new String'(Full_Switch);
L := L + 1;
-
end case;
end loop;
Add_Files_From_List (To_String (List_Filename));
end if;
- -- Check if the set of parameters are compatible.
+ -- Check if the set of parameters are compatible
- if Build_Mode = Nil and then not Help and then not Verbose then
- Exceptions.Raise_Exception
- (Syntax_Error'Identity,
- "nothing to do.");
+ if Build_Mode = Nil and then not Help and then not MDLL.Verbose then
+ Raise_Exception (Syntax_Error'Identity, "nothing to do.");
end if;
-- -n option but no file specified
and then A = Afiles'First
and then O = Ofiles'First
then
- Exceptions.Raise_Exception
+ Raise_Exception
(Syntax_Error'Identity,
"-n specified but there are no objects to build the library.");
end if;
Build_Mode := Import_Lib;
end if;
- -- Check if only a dynamic library must be built.
+ -- If map file is to be generated, add linker option here
+
+ if Gen_Map_File and then Build_Mode = Import_Lib then
+ Raise_Exception
+ (Syntax_Error'Identity,
+ "Can't generate a map file for an import library.");
+ end if;
+
+ -- Check if only a dynamic library must be built
if Build_Mode = Dynamic_Lib and then not Build_Import then
Build_Mode := Dynamic_Lib_Only;
end if;
if O /= Ofiles'First then
- Objects_Files := new OS_Lib.Argument_List'(Ofiles (1 .. O - 1));
+ Objects_Files := new Argument_List'(Ofiles (1 .. O - 1));
end if;
if A /= Afiles'First then
- Ali_Files := new OS_Lib.Argument_List'(Afiles (1 .. A - 1));
+ Ali_Files := new Argument_List'(Afiles (1 .. A - 1));
end if;
if G /= Gopts'First then
- Options := new OS_Lib.Argument_List'(Gopts (1 .. G - 1));
+ Options := new Argument_List'(Gopts (1 .. G - 1));
end if;
if L /= Lopts'First then
- Largs_Options := new OS_Lib.Argument_List'(Lopts (1 .. L - 1));
+ Largs_Options := new Argument_List'(Lopts (1 .. L - 1));
end if;
if B /= Bopts'First then
- Bargs_Options := new OS_Lib.Argument_List'(Bopts (1 .. B - 1));
+ Bargs_Options := new Argument_List'(Bopts (1 .. B - 1));
end if;
exception
when Invalid_Switch =>
- Exceptions.Raise_Exception
+ Raise_Exception
(Syntax_Error'Identity,
Message => "Invalid Switch " & Full_Switch);
when Invalid_Parameter =>
- Exceptions.Raise_Exception
+ Raise_Exception
(Syntax_Error'Identity,
Message => "No parameter for " & Full_Switch);
end if;
if MDLL.Verbose or else Help then
- Text_IO.New_Line;
- Text_IO.Put_Line ("GNATDLL " & Version & " - Dynamic Libraries Builder");
- Text_IO.New_Line;
+ New_Line;
+ Put_Line ("GNATDLL " & Version & " - Dynamic Libraries Builder");
+ New_Line;
end if;
MDLL.Utl.Locate;
To_String (Def_Filename),
To_String (DLL_Address),
Build_Import => True,
- Relocatable => Must_Build_Relocatable);
+ Relocatable => Must_Build_Relocatable,
+ Map_File => Gen_Map_File);
when Dynamic_Lib_Only =>
MDLL.Build_Dynamic_Library
To_String (Def_Filename),
To_String (DLL_Address),
Build_Import => False,
- Relocatable => Must_Build_Relocatable);
+ Relocatable => Must_Build_Relocatable,
+ Map_File => Gen_Map_File);
when Nil =>
null;
-
end case;
-
end if;
- Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Success);
+ Set_Exit_Status (Success);
exception
when SE : Syntax_Error =>
- Text_IO.Put_Line ("Syntax error : " & Exceptions.Exception_Message (SE));
- Text_IO.New_Line;
+ Put_Line ("Syntax error : " & Exception_Message (SE));
+ New_Line;
Syntax;
- Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Failure);
+ Set_Exit_Status (Failure);
- when E : Tools_Error | Context_Error =>
- Text_IO.Put_Line (Exceptions.Exception_Message (E));
- Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Failure);
+ when E : MDLL.Tools_Error | Context_Error =>
+ Put_Line (Exception_Message (E));
+ Set_Exit_Status (Failure);
when others =>
- Text_IO.Put_Line ("gnatdll: INTERNAL ERROR. Please report");
- Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Failure);
+ Put_Line ("gnatdll: INTERNAL ERROR. Please report");
+ Set_Exit_Status (Failure);
end Gnatdll;
Dependable : Boolean := False; -- flag -d
Also_Predef : Boolean := False;
+ Very_Verbose_Mode : Boolean := False; -- flag -V
+
Unit_Start : Integer;
Unit_End : Integer;
Source_Start : Integer;
function Image (Restriction : Restriction_Id) return String;
-- Returns the capitalized image of Restriction
+ ---------------------------------------
+ -- GLADE specific output subprograms --
+ ---------------------------------------
+
+ package GLADE is
+
+ -- Any modification to this subunit requires a synchronization
+ -- with the GLADE implementation.
+
+ procedure Output_ALI (A : ALI_Id);
+ procedure Output_No_ALI (Afile : File_Name_Type);
+
+ end GLADE;
+
-----------------
-- Add_Lib_Dir --
-----------------
end if;
end Find_Status;
+ -----------
+ -- GLADE --
+ -----------
+
+ package body GLADE is
+
+ N_Flags : Natural;
+ N_Indents : Natural := 0;
+
+ type Token_Type is
+ (T_No_ALI,
+ T_ALI,
+ T_Unit,
+ T_With,
+ T_Source,
+ T_Afile,
+ T_Ofile,
+ T_Sfile,
+ T_Name,
+ T_Main,
+ T_Kind,
+ T_Flags,
+ T_Preelaborated,
+ T_Pure,
+ T_Has_RACW,
+ T_Remote_Types,
+ T_Shared_Passive,
+ T_RCI,
+ T_Predefined,
+ T_Internal,
+ T_Is_Generic,
+ T_Procedure,
+ T_Function,
+ T_Package,
+ T_Subprogram,
+ T_Spec,
+ T_Body);
+
+ Image : constant array (Token_Type) of String_Access :=
+ (T_No_ALI => new String'("No_ALI"),
+ T_ALI => new String'("ALI"),
+ T_Unit => new String'("Unit"),
+ T_With => new String'("With"),
+ T_Source => new String'("Source"),
+ T_Afile => new String'("Afile"),
+ T_Ofile => new String'("Ofile"),
+ T_Sfile => new String'("Sfile"),
+ T_Name => new String'("Name"),
+ T_Main => new String'("Main"),
+ T_Kind => new String'("Kind"),
+ T_Flags => new String'("Flags"),
+ T_Preelaborated => new String'("Preelaborated"),
+ T_Pure => new String'("Pure"),
+ T_Has_RACW => new String'("Has_RACW"),
+ T_Remote_Types => new String'("Remote_Types"),
+ T_Shared_Passive => new String'("Shared_Passive"),
+ T_RCI => new String'("RCI"),
+ T_Predefined => new String'("Predefined"),
+ T_Internal => new String'("Internal"),
+ T_Is_Generic => new String'("Is_Generic"),
+ T_Procedure => new String'("procedure"),
+ T_Function => new String'("function"),
+ T_Package => new String'("package"),
+ T_Subprogram => new String'("subprogram"),
+ T_Spec => new String'("spec"),
+ T_Body => new String'("body"));
+
+ procedure Output_Name (N : Name_Id);
+ -- Remove any encoding info (%b and %s) and output N
+
+ procedure Output_Afile (A : File_Name_Type);
+ procedure Output_Ofile (O : File_Name_Type);
+ procedure Output_Sfile (S : File_Name_Type);
+ -- Output various names. Check that the name is different from
+ -- no name. Otherwise, skip the output.
+
+ procedure Output_Token (T : Token_Type);
+ -- Output token using a specific format. That is several
+ -- indentations and:
+ --
+ -- T_No_ALI .. T_With : <token> & " =>" & NL
+ -- T_Source .. T_Kind : <token> & " => "
+ -- T_Flags : <token> & " =>"
+ -- T_Preelab .. T_Body : " " & <token>
+
+ procedure Output_Sdep (S : Sdep_Id);
+ procedure Output_Unit (U : Unit_Id);
+ procedure Output_With (W : With_Id);
+ -- Output this entry as a global section (like ALIs)
+
+ ------------------
+ -- Output_Afile --
+ ------------------
+
+ procedure Output_Afile (A : File_Name_Type) is
+ begin
+ if A /= No_File then
+ Output_Token (T_Afile);
+ Write_Name (A);
+ Write_Eol;
+ end if;
+ end Output_Afile;
+
+ ----------------
+ -- Output_ALI --
+ ----------------
+
+ procedure Output_ALI (A : ALI_Id) is
+ begin
+ Output_Token (T_ALI);
+ N_Indents := N_Indents + 1;
+
+ Output_Afile (ALIs.Table (A).Afile);
+ Output_Ofile (ALIs.Table (A).Ofile_Full_Name);
+ Output_Sfile (ALIs.Table (A).Sfile);
+
+ -- Output Main
+
+ if ALIs.Table (A).Main_Program /= None then
+ Output_Token (T_Main);
+
+ if ALIs.Table (A).Main_Program = Proc then
+ Output_Token (T_Procedure);
+ else
+ Output_Token (T_Function);
+ end if;
+
+ Write_Eol;
+ end if;
+
+ -- Output Units
+
+ for U in ALIs.Table (A).First_Unit .. ALIs.Table (A).Last_Unit loop
+ Output_Unit (U);
+ end loop;
+
+ -- Output Sdeps
+
+ for S in ALIs.Table (A).First_Sdep .. ALIs.Table (A).Last_Sdep loop
+ Output_Sdep (S);
+ end loop;
+
+ N_Indents := N_Indents - 1;
+ end Output_ALI;
+
+ -------------------
+ -- Output_No_ALI --
+ -------------------
+
+ procedure Output_No_ALI (Afile : File_Name_Type) is
+ begin
+ Output_Token (T_No_ALI);
+ N_Indents := N_Indents + 1;
+ Output_Afile (Afile);
+ N_Indents := N_Indents - 1;
+ end Output_No_ALI;
+
+ -----------------
+ -- Output_Name --
+ -----------------
+
+ procedure Output_Name (N : Name_Id) is
+ begin
+ -- Remove any encoding info (%s or %b)
+
+ Get_Name_String (N);
+ if Name_Len > 2
+ and then Name_Buffer (Name_Len - 1) = '%'
+ then
+ Name_Len := Name_Len - 2;
+ end if;
+
+ Output_Token (T_Name);
+ Write_Str (Name_Buffer (1 .. Name_Len));
+ Write_Eol;
+ end Output_Name;
+
+ ------------------
+ -- Output_Ofile --
+ ------------------
+
+ procedure Output_Ofile (O : File_Name_Type) is
+ begin
+ if O /= No_File then
+ Output_Token (T_Ofile);
+ Write_Name (O);
+ Write_Eol;
+ end if;
+ end Output_Ofile;
+
+ -----------------
+ -- Output_Sdep --
+ -----------------
+
+ procedure Output_Sdep (S : Sdep_Id) is
+ begin
+ Output_Token (T_Source);
+ Write_Name (Sdep.Table (S).Sfile);
+ Write_Eol;
+ end Output_Sdep;
+
+ ------------------
+ -- Output_Sfile --
+ ------------------
+
+ procedure Output_Sfile (S : File_Name_Type) is
+ FS : File_Name_Type := S;
+
+ begin
+ if FS /= No_File then
+
+ -- We want to output the full source name
+
+ FS := Full_Source_Name (FS);
+
+ -- There is no full source name. This occurs for instance when a
+ -- withed unit has a spec file but no body file. This situation
+ -- is not a problem for GLADE since the unit may be located on
+ -- a partition we do not want to build. However, we need to
+ -- locate the spec file and to find its full source name.
+ -- Replace the body file name with the spec file name used to
+ -- compile the current unit when possible.
+
+ if FS = No_File then
+ Get_Name_String (S);
+
+ if Name_Len > 4
+ and then Name_Buffer (Name_Len - 3 .. Name_Len) = ".adb"
+ then
+ Name_Buffer (Name_Len) := 's';
+ FS := Full_Source_Name (Name_Find);
+ end if;
+ end if;
+ end if;
+
+ if FS /= No_File then
+ Output_Token (T_Sfile);
+ Write_Name (FS);
+ Write_Eol;
+ end if;
+ end Output_Sfile;
+
+ ------------------
+ -- Output_Token --
+ ------------------
+
+ procedure Output_Token (T : Token_Type) is
+ begin
+ if T in T_No_ALI .. T_Flags then
+ for J in 1 .. N_Indents loop
+ Write_Str (" ");
+ end loop;
+
+ Write_Str (Image (T).all);
+
+ for J in Image (T)'Length .. 12 loop
+ Write_Char (' ');
+ end loop;
+
+ Write_Str ("=>");
+
+ if T in T_No_ALI .. T_With then
+ Write_Eol;
+ elsif T in T_Source .. T_Name then
+ Write_Char (' ');
+ end if;
+
+ elsif T in T_Preelaborated .. T_Body then
+ if T in T_Preelaborated .. T_Is_Generic then
+ if N_Flags = 0 then
+ Output_Token (T_Flags);
+ end if;
+
+ N_Flags := N_Flags + 1;
+ end if;
+
+ Write_Char (' ');
+ Write_Str (Image (T).all);
+
+ else
+ Write_Str (Image (T).all);
+ end if;
+ end Output_Token;
+
+ -----------------
+ -- Output_Unit --
+ -----------------
+
+ procedure Output_Unit (U : Unit_Id) is
+ begin
+ Output_Token (T_Unit);
+ N_Indents := N_Indents + 1;
+
+ -- Output Name
+
+ Output_Name (Units.Table (U).Uname);
+
+ -- Output Kind
+
+ Output_Token (T_Kind);
+
+ if Units.Table (U).Unit_Kind = 'p' then
+ Output_Token (T_Package);
+ else
+ Output_Token (T_Subprogram);
+ end if;
+
+ if Name_Buffer (Name_Len) = 's' then
+ Output_Token (T_Spec);
+ else
+ Output_Token (T_Body);
+ end if;
+
+ Write_Eol;
+
+ -- Output source file name
+
+ Output_Sfile (Units.Table (U).Sfile);
+
+ -- Output Flags
+
+ N_Flags := 0;
+
+ if Units.Table (U).Preelab then
+ Output_Token (T_Preelaborated);
+ end if;
+
+ if Units.Table (U).Pure then
+ Output_Token (T_Pure);
+ end if;
+
+ if Units.Table (U).Has_RACW then
+ Output_Token (T_Has_RACW);
+ end if;
+
+ if Units.Table (U).Remote_Types then
+ Output_Token (T_Remote_Types);
+ end if;
+
+ if Units.Table (U).Shared_Passive then
+ Output_Token (T_Shared_Passive);
+ end if;
+
+ if Units.Table (U).RCI then
+ Output_Token (T_RCI);
+ end if;
+
+ if Units.Table (U).Predefined then
+ Output_Token (T_Predefined);
+ end if;
+
+ if Units.Table (U).Internal then
+ Output_Token (T_Internal);
+ end if;
+
+ if Units.Table (U).Is_Generic then
+ Output_Token (T_Is_Generic);
+ end if;
+
+ if N_Flags > 0 then
+ Write_Eol;
+ end if;
+
+ -- Output Withs
+
+ for W in Units.Table (U).First_With .. Units.Table (U).Last_With loop
+ Output_With (W);
+ end loop;
+
+ N_Indents := N_Indents - 1;
+ end Output_Unit;
+
+ -----------------
+ -- Output_With --
+ -----------------
+
+ procedure Output_With (W : With_Id) is
+ begin
+ Output_Token (T_With);
+ N_Indents := N_Indents + 1;
+
+ Output_Name (Withs.Table (W).Uname);
+
+ -- Output Kind
+
+ Output_Token (T_Kind);
+
+ if Name_Buffer (Name_Len) = 's' then
+ Output_Token (T_Spec);
+ else
+ Output_Token (T_Body);
+ end if;
+
+ Write_Eol;
+
+ Output_Afile (Withs.Table (W).Afile);
+ Output_Sfile (Withs.Table (W).Sfile);
+
+ N_Indents := N_Indents - 1;
+ end Output_With;
+
+ end GLADE;
+
-----------
-- Image --
-----------
declare
Restrictions : constant Restrictions_Info :=
ALIs.Table (ALI).Restrictions;
+
begin
-- If the source was compiled with pragmas Restrictions,
-- Display these restrictions.
procedure Scan_Ls_Arg (Argv : String) is
FD : File_Descriptor;
Len : Integer;
+
begin
pragma Assert (Argv'First = 1);
end if;
if Argv (1) = '-' then
-
if Argv'Length = 1 then
Fail ("switch character cannot be followed by a blank");
when 'o' => Reset_Print; Print_Object := True;
when 'v' => Verbose_Mode := True;
when 'd' => Dependable := True;
+ when 'V' => Very_Verbose_Mode := True;
when others => null;
end case;
-----------
procedure Usage is
-
- -- Start of processing for Usage
-
begin
-- Usage line
end Usage;
- -- Start of processing for Gnatls
+-- Start of processing for Gnatls
begin
-- Initialize standard packages
if Verbose_Mode then
Targparm.Get_Target_Parameters;
- -- WARNING: the output of gnatls -v is used during the compilation
- -- and installation of GLADE to recreate sdefault.adb and locate
- -- the libgnat.a to use. Any change in the output of gnatls -v must
- -- be synchronized with the GLADE Dist/config.sdefault shell script.
-
Write_Eol;
Write_Str ("GNATLS ");
Write_Str (Gnat_Version_String);
while More_Lib_Files loop
Main_File := Next_Main_Lib_File;
- Ali_File := Full_Lib_File_Name (Lib_File_Name (Main_File));
+ Ali_File := Full_Lib_File_Name (Lib_File_Name (Main_File));
if Ali_File = No_File then
- Write_Str ("Can't find library info for ");
- Get_Name_String (Main_File);
- Write_Char ('"');
- Write_Str (Name_Buffer (1 .. Name_Len));
- Write_Char ('"');
- Write_Eol;
+ if Very_Verbose_Mode then
+ GLADE.Output_No_ALI (Lib_File_Name (Main_File));
+
+ else
+ Write_Str ("Can't find library info for ");
+ Get_Name_String (Main_File);
+ Write_Char ('"'); -- "
+ Write_Str (Name_Buffer (1 .. Name_Len));
+ Write_Char ('"'); -- "
+ Write_Eol;
+ end if;
else
Ali_File := Strip_Directory (Ali_File);
end if;
end loop;
+ if Very_Verbose_Mode then
+ for A in ALIs.First .. ALIs.Last loop
+ GLADE.Output_ALI (A);
+ end loop;
+
+ return;
+ end if;
+
Find_General_Layout;
for Id in ALIs.First .. ALIs.Last loop
"g-memdum", -- GNAT.Memory_Dump
"g-moreex", -- GNAT.Most_Recent_Exception
"g-os_lib", -- GNAT.Os_Lib
- "g-pehage", -- GNAT.Perfect_Hash.Generators
- "g-perhas", -- GNAT.Perfect_Hash
+ "g-pehage", -- GNAT.Perfect_Hash_Generators
"g-regexp", -- GNAT.Regexp
"g-regist", -- GNAT.Registry
"g-regpat", -- GNAT.Regpat
int __gl_unreserve_all_interrupts = 0;
int __gl_exception_tracebacks = 0;
int __gl_zero_cost_exceptions = 0;
+int __gl_detect_blocking = 0;
/* Indication of whether synchronous signal handler has already been
installed by a previous call to adainit */
int num_interrupt_states,
int unreserve_all_interrupts,
int exception_tracebacks,
- int zero_cost_exceptions)
+ int zero_cost_exceptions,
+ int detect_blocking)
{
static int already_called = 0;
__gl_task_dispatching_policy = task_dispatching_policy;
__gl_unreserve_all_interrupts = unreserve_all_interrupts;
__gl_exception_tracebacks = exception_tracebacks;
+ __gl_detect_blocking = detect_blocking;
/* ??? __gl_zero_cost_exceptions is new in 3.15 and is referenced from
a-except.adb, which is also part of the compiler sources. Since the
Write_Info_Str (" CE");
end if;
+ if Opt.Detect_Blocking then
+ Write_Info_Str (" DB");
+ end if;
+
if Opt.Float_Format /= ' ' then
Write_Info_Str (" F");
-- format will be correct and complete. Note that NO is
-- always present if CE is present.
--
+ -- DB Detect_Blocking pragma is in effect for all units in
+ -- this file.
+ --
-- FD Configuration pragmas apply to all the units in this
-- file specifying a possibly non-standard floating point
-- format (VAX float with Long_Float using D_Float)
char *__gnat_object_file_option = "";
char *__gnat_run_path_option = "-Wl,-rpath,";
char __gnat_shared_libgnat_default = STATIC;
-int __gnat_link_max = 2147483647;
-unsigned char __gnat_objlist_file_supported = 0;
-unsigned char __gnat_using_gnu_linker = 0;
+int __gnat_link_max = 8192;
+unsigned char __gnat_objlist_file_supported = 1;
+unsigned char __gnat_using_gnu_linker = 1;
char *__gnat_object_library_extension = ".a";
#elif defined (linux)
-- --
-- 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- --
Def_Filename : String;
Lib_Address : String := "";
Build_Import : Boolean := False;
- Relocatable : Boolean := False)
+ Relocatable : Boolean := False;
+ Map_File : Boolean := False)
is
use type OS_Lib.Argument_List;
Lib_Opt : aliased String := "-mdll";
Out_Opt : aliased String := "-o";
Adr_Opt : aliased String := "-Wl,--image-base=" & Lib_Address;
+ Map_Opt : aliased String := "-Wl,-Map," & Lib_Filename & ".map";
L_Afiles : Argument_List := Afiles;
-- Local afiles list. This list can be reordered to ensure that the
procedure Build_Reloc_DLL is
-- Objects plus the export table (.exp) file
-
Objects_Exp_File : constant OS_Lib.Argument_List
:= Exp_File'Unchecked_Access & Ofiles;
Success : Boolean;
-
begin
if not Quiet then
Text_IO.Put_Line ("building relocatable DLL...");
-- 5) Build the dynamic library
- Utl.Gcc (Output_File => Dll_File,
- Files => Objects_Exp_File,
- Options => Adr_Opt'Unchecked_Access & All_Options,
- Build_Lib => True);
+ declare
+ Params : OS_Lib.Argument_List :=
+ Adr_Opt'Unchecked_Access & All_Options;
+ begin
+ if Map_File then
+ Params := Map_Opt'Unchecked_Access & Params;
+ end if;
+
+ Utl.Gcc
+ (Output_File => Dll_File,
+ Files => Objects_Exp_File,
+ Options => Params,
+ Build_Lib => True);
+ end;
OS_Lib.Delete_File (Exp_File, Success);
OS_Lib.Delete_File (Bas_File, Success);
Utl.Gnatbind (L_Afiles, Options & Bargs_Options);
declare
- Params : constant OS_Lib.Argument_List :=
+ Params : OS_Lib.Argument_List :=
Out_Opt'Unchecked_Access &
Dll_File'Unchecked_Access &
Lib_Opt'Unchecked_Access &
Ofiles &
All_Options;
begin
+ if Map_File then
+ Params := Map_Opt'Unchecked_Access & Params;
+ end if;
+
Utl.Gnatlink (L_Afiles (L_Afiles'Last).all, Params);
end;
-- Build the DLL
- Utl.Gcc (Output_File => Dll_File,
- Files => Exp_File'Unchecked_Access & Ofiles,
- Options => Adr_Opt'Unchecked_Access & All_Options,
- Build_Lib => True);
+ declare
+ Params : OS_Lib.Argument_List :=
+ Adr_Opt'Unchecked_Access & All_Options;
+ begin
+ if Map_File then
+ Params := Map_Opt'Unchecked_Access & Params;
+ end if;
+
+ Utl.Gcc (Output_File => Dll_File,
+ Files => Exp_File'Unchecked_Access & Ofiles,
+ Options => Params,
+ Build_Lib => True);
+ end;
OS_Lib.Delete_File (Exp_File, Success);
Utl.Gnatbind (L_Afiles, Options & Bargs_Options);
declare
- Params : constant OS_Lib.Argument_List :=
+ Params : OS_Lib.Argument_List :=
Out_Opt'Unchecked_Access &
Dll_File'Unchecked_Access &
Lib_Opt'Unchecked_Access &
Ofiles &
All_Options;
begin
+ if Map_File then
+ Params := Map_Opt'Unchecked_Access & Params;
+ end if;
+
Utl.Gnatlink (L_Afiles (L_Afiles'Last).all, Params);
end;
end if;
case Relocatable is
-
when True =>
if L_Afiles'Length = 0 then
Build_Reloc_DLL;
else
Ada_Build_Non_Reloc_DLL;
end if;
-
end case;
end Build_Dynamic_Library;
--------------------------
procedure Build_Import_Library (Def_Base_Filename : String) is
-
Def_File : String renames Def_Filename;
Dll_File : constant String := Def_Base_Filename & ".dll";
Lib_File : constant String := "lib" & Base_Filename & ".a";
begin
-
if not Quiet then
Text_IO.Put_Line ("Building import library...");
Text_IO.Put_Line ("make " & Lib_File &
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2001 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- --
-- to build Windows DLL
with GNAT.OS_Lib;
+-- Should have USE here ???
package MDLL is
Null_Argument_List : constant Argument_List := (1 .. 0 => new String'(""));
- Null_Argument_List_Access : Argument_List_Access
- := new Argument_List (1 .. 0);
+ Null_Argument_List_Access : Argument_List_Access :=
+ new Argument_List (1 .. 0);
- Tools_Error : exception;
+ Tools_Error : exception;
+ -- Commment required
- Verbose : Boolean := False;
- Quiet : Boolean := False;
+ Verbose : Boolean := False;
+ Quiet : Boolean := False;
+ -- Comment required ???
+ Kill_Suffix : Boolean := False;
-- Kill_Suffix is used by dlltool to know whether or not the @nn suffix
-- should be removed from the exported names. When Kill_Suffix is set to
-- True then dlltool -k option is used.
- Kill_Suffix : Boolean := False;
-
procedure Build_Dynamic_Library
(Ofiles : Argument_List;
Afiles : Argument_List;
Def_Filename : String;
Lib_Address : String := "";
Build_Import : Boolean := False;
- Relocatable : Boolean := False);
+ Relocatable : Boolean := False;
+ Map_File : Boolean := False);
-- Build a DLL and the import library to link against the DLL.
-- this function handles relocatable and non relocatable DLL.
-- If the Afiles argument list contains some Ada units then it will
-- generate the right adainit and adafinal and integrate it in the DLL.
-- If the Afiles argument list is empty (there is only some object files
-- provided) then it will not try to build a binder file. This is ok to
- -- build DLL containing no Ada code.
+ -- build DLL containing no Ada code. If Map_File is set to True, a map
+ -- file named Lib_Filename & ".map" will be created.
procedure Build_Import_Library
(Lib_Filename : String;
procedure Set_Opt_Config_Switches (Internal_Unit : Boolean) is
begin
if Internal_Unit then
- Ada_Version := Ada_Version_Default;
+ Ada_Version := Ada_Version_Runtime;
Dynamic_Elaboration_Checks := False;
Extensions_Allowed := True;
External_Name_Exp_Casing := As_Is;
-- GNAT
-- Current Ada version for compiler
+ Ada_Version_Runtime : Ada_Version_Type := Ada_05;
+ -- GNAT
+ -- Ada version used to compile the runtime
+
Ada_Final_Suffix : constant String := "final";
Ada_Final_Name : String_Ptr := new String'("ada" & Ada_Final_Suffix);
-- GNATBIND
-- --
------------------------------------------------------------------------------
-with Namet; use Namet;
-with Osint; use Osint;
+with Namet; use Namet;
+with Osint;
+with Prj.Com; use Prj.Com;
with Table;
with System.Case_Util; use System.Case_Util;
-- Package names are preceded by 'P'
-- Attribute names are preceded by two letters:
+
-- The first letter is one of
-- 'S' for Single
-- 's' for Single with optional index
-- 'L' for List
-- 'l' for List of strings with optional indexes
+
-- The second letter is one of
-- 'V' for single variable
-- 'A' for associative array
Initialized : Boolean := False;
-- A flag to avoid multiple initialization
- ----------------
- -- Attributes --
- ----------------
-
- type Attribute_Record is record
- Name : Name_Id;
- Var_Kind : Variable_Kind;
- Optional_Index : Boolean;
- Attr_Kind : Attribute_Kind;
- Next : Attr_Node_Id;
- end record;
- -- Data for an attribute
-
- package Attrs is
- new Table.Table (Table_Component_Type => Attribute_Record,
- Table_Index_Type => Attr_Node_Id,
- Table_Low_Bound => First_Attribute,
- Table_Initial => Attributes_Initial,
- Table_Increment => Attributes_Increment,
- Table_Name => "Prj.Attr.Attrs");
- -- The table of the attributes
-
- --------------
- -- Packages --
- --------------
-
- type Package_Record is record
- Name : Name_Id;
- Known : Boolean := True;
- First_Attribute : Attr_Node_Id;
- end record;
- -- Data for a package
-
- package Package_Attributes is
- new Table.Table (Table_Component_Type => Package_Record,
- Table_Index_Type => Pkg_Node_Id,
- Table_Low_Bound => First_Package,
- Table_Initial => Packages_Initial,
- Table_Increment => Packages_Increment,
- Table_Name => "Prj.Attr.Packages");
- -- The table of the packages
-
function Name_Id_Of (Name : String) return Name_Id;
-- Returns the Name_Id for Name in lower case
- -------------------
- -- Add_Attribute --
- -------------------
-
- procedure Add_Attribute
- (To_Package : Package_Node_Id;
- Attribute_Name : Name_Id;
- Attribute_Node : out Attribute_Node_Id)
- is
- begin
- -- Only add the attribute if the package is already defined
-
- if To_Package /= Empty_Package then
- Attrs.Increment_Last;
- Attrs.Table (Attrs.Last) :=
- (Name => Attribute_Name,
- Var_Kind => Undefined,
- Optional_Index => False,
- Attr_Kind => Unknown,
- Next =>
- Package_Attributes.Table (To_Package.Value).First_Attribute);
- Package_Attributes.Table (To_Package.Value).First_Attribute :=
- Attrs.Last;
- Attribute_Node := (Value => Attrs.Last);
- end if;
- end Add_Attribute;
-
- -------------------------
- -- Add_Unknown_Package --
- -------------------------
-
- procedure Add_Unknown_Package (Name : Name_Id; Id : out Package_Node_Id) is
- begin
- Package_Attributes.Increment_Last;
- Id := (Value => Package_Attributes.Last);
- Package_Attributes.Table (Id.Value) :=
- (Name => Name, Known => False, First_Attribute => Empty_Attr);
- end Add_Unknown_Package;
-
-----------------------
-- Attribute_Kind_Of --
-----------------------
Starting_At : Attribute_Node_Id) return Attribute_Node_Id
is
Id : Attr_Node_Id := Starting_At.Value;
+
begin
while Id /= Empty_Attr
and then Attrs.Table (Id).Name /= Name
for Index in First_Package .. Package_Attributes.Last loop
if Package_Name = Package_Attributes.Table (Index).Name then
- Fail ("duplicate name """,
+ Osint.Fail ("duplicate name """,
Initialization_Data (Start .. Finish - 1),
""" in predefined packages.");
end if;
Attr_Kind := Case_Insensitive_Associative_Array;
when 'b' =>
- if File_Names_Case_Sensitive then
+ if Osint.File_Names_Case_Sensitive then
Attr_Kind := Associative_Array;
else
Attr_Kind := Case_Insensitive_Associative_Array;
end if;
when 'c' =>
- if File_Names_Case_Sensitive then
+ if Osint.File_Names_Case_Sensitive then
Attr_Kind := Optional_Index_Associative_Array;
else
Attr_Kind :=
for Index in First_Attribute .. Attrs.Last - 1 loop
if Attribute_Name = Attrs.Table (Index).Name then
- Fail ("duplicate attribute """,
+ Osint.Fail ("duplicate attribute """,
Initialization_Data (Start .. Finish - 1),
""" in " & Attribute_Location);
end if;
begin
if Name'Length = 0 then
Fail ("cannot register an attribute with no name");
+ raise Project_Error;
end if;
if In_Package = Empty_Package then
Fail ("attempt to add attribute """, Name,
""" to an undefined package");
+ raise Project_Error;
end if;
Attr_Name := Name_Id_Of (Name);
Get_Name_String
(Package_Attributes.Table (In_Package.Value).Name) &
"""");
- exit;
+ raise Project_Error;
end if;
Curr_Attr := Attrs.Table (Curr_Attr).Next;
-- If Index_Is_File_Name, change the attribute kind if necessary
- if Index_Is_File_Name and then not File_Names_Case_Sensitive then
+ if Index_Is_File_Name and then not Osint.File_Names_Case_Sensitive then
case Attr_Kind is
when Associative_Array =>
Real_Attr_Kind := Case_Insensitive_Associative_Array;
--------------------------
procedure Register_New_Package (Name : String; Id : out Package_Node_Id) is
- Pkg_Name : Name_Id;
+ Pkg_Name : Name_Id;
begin
if Name'Length = 0 then
Fail ("cannot register a package with no name");
+ Id := Empty_Package;
+ return;
end if;
Pkg_Name := Name_Id_Of (Name);
+
+ for Index in Package_Attributes.First .. Package_Attributes.Last loop
+ if Package_Attributes.Table (Index).Name = Pkg_Name then
+ Fail ("cannot register a package with a non unique name""",
+ Name, """");
+ Id := Empty_Package;
+ return;
+ end if;
+ end loop;
+
Package_Attributes.Increment_Last;
Id := (Value => Package_Attributes.Last);
Package_Attributes.Table (Package_Attributes.Last) :=
begin
if Name'Length = 0 then
Fail ("cannot register a package with no name");
+ raise Project_Error;
end if;
Pkg_Name := Name_Id_Of (Name);
if Package_Attributes.Table (Index).Name = Pkg_Name then
Fail ("cannot register a package with a non unique name""",
Name, """");
- exit;
+ raise Project_Error;
end if;
end loop;
if Attrs.Table (Curr_Attr).Name = Attr_Name then
Fail ("duplicate attribute name """, Attributes (Index).Name,
""" in new package """ & Name & """");
- exit;
+ raise Project_Error;
end if;
Curr_Attr := Attrs.Table (Curr_Attr).Next;
Attr_Kind := Attributes (Index).Attr_Kind;
if Attributes (Index).Index_Is_File_Name
- and then not File_Names_Case_Sensitive
+ and then not Osint.File_Names_Case_Sensitive
then
case Attr_Kind is
when Associative_Array =>
-- explicitly with Register_New_Package (see below).
type Attribute_Data_Array is array (Positive range <>) of Attribute_Data;
+ -- A list of attribute name/characteristics to be used as parameter of
+ -- procedure Register_New_Package below.
+
+ -- In the subprograms below, when it is specified that the subprogram
+ -- "fails", procedure Prj.Com.Fail is called. Unless it is specified
+ -- otherwise, if Prj.Com.Fail returns, exception Prj.Prj_Error is raised.
procedure Register_New_Package
(Name : String;
-- Add a new package with its attributes.
-- This procedure can only be called after Initialize, but before any
-- other call to a service of the Project Managers.
- -- The name of the package must be unique. The names of the attributes
- -- must be different.
-
- -- The following declarations are only for the Project Manager, that is
- -- the packages of the Prj or MLib hierarchies.
+ -- Fail if the name of the package is empty or not unique, or if the names
+ -- of the attributes are not different.
----------------
-- Attributes --
-- Default value of Package_Node_Id objects
procedure Register_New_Package (Name : String; Id : out Package_Node_Id);
- -- Add a new package. Fails if the package has a duplicate name.
- -- Initially, the new package has no attributes. Id may be used to add
- -- attributes using procedure Register_New_Attribute below.
+ -- Add a new package. Fails if Name (the package name) is empty or is
+ -- already the name of a package, and set Id to Empty_Package,
+ -- if Prj.Com.Fail returns. Initially, the new package has no attributes.
+ -- Id may be used to add attributes using procedure Register_New_Attribute
+ -- below.
procedure Register_New_Attribute
(Name : String;
Var_Kind : Defined_Variable_Kind;
Index_Is_File_Name : Boolean := False;
Opt_Index : Boolean := False);
- -- Add a new attribute to registered package In_Package. Fails if the
- -- attribute has a duplicate name. See definition of type Attribute_Data
- -- above for the meaning of parameters Attr_Kind, Var_Kind,
+ -- Add a new attribute to registered package In_Package. Fails if Name
+ -- (the attribute name) is empty, if In_Package is Empty_Package or if
+ -- the attribute name has a duplicate name. See definition of type
+ -- Attribute_Data above for the meaning of parameters Attr_Kind, Var_Kind,
-- Index_Is_File_Name and Opt_Index.
function Package_Node_Id_Of (Name : Name_Id) return Package_Node_Id;
-- Returns the package node id of the package with name Name. Returns
-- Empty_Package if there is no package with this name.
- procedure Add_Unknown_Package (Name : Name_Id; Id : out Package_Node_Id);
- -- Add a new package. The Name cannot be the name of a predefined or
- -- already registered package.
-
function First_Attribute_Of
(Pkg : Package_Node_Id) return Attribute_Node_Id;
-- Returns the first attribute in the list of attributes of package Pkg.
-- Returns Empty_Attribute if Pkg is Empty_Package.
- procedure Add_Attribute
- (To_Package : Package_Node_Id;
- Attribute_Name : Name_Id;
- Attribute_Node : out Attribute_Node_Id);
- -- Add an attribute to the list for package To_Package. Attribute_Name
- -- cannot be the name of an existing attribute of the package.
- -- Does nothing if To_Package is Empty_Package.
-
private
----------------
-- Attributes --
Package_First : constant Package_Node_Id := First_Package_Node_Id;
+ ----------------
+ -- Attributes --
+ ----------------
+
+ type Attribute_Record is record
+ Name : Name_Id;
+ Var_Kind : Variable_Kind;
+ Optional_Index : Boolean;
+ Attr_Kind : Attribute_Kind;
+ Next : Attr_Node_Id;
+ end record;
+ -- Data for an attribute
+
+ package Attrs is
+ new Table.Table (Table_Component_Type => Attribute_Record,
+ Table_Index_Type => Attr_Node_Id,
+ Table_Low_Bound => First_Attribute,
+ Table_Initial => Attributes_Initial,
+ Table_Increment => Attributes_Increment,
+ Table_Name => "Prj.Attr.Attrs");
+ -- The table of the attributes
+
+ --------------
+ -- Packages --
+ --------------
+
+ type Package_Record is record
+ Name : Name_Id;
+ Known : Boolean := True;
+ First_Attribute : Attr_Node_Id;
+ end record;
+ -- Data for a package
+
+ package Package_Attributes is
+ new Table.Table (Table_Component_Type => Package_Record,
+ Table_Index_Type => Pkg_Node_Id,
+ Table_Low_Bound => First_Package,
+ Table_Initial => Packages_Initial,
+ Table_Increment => Packages_Increment,
+ Table_Name => "Prj.Attr.Packages");
+ -- The table of the packages
+
end Prj.Attr;
-- --
------------------------------------------------------------------------------
-with Err_Vars; use Err_Vars;
-with Namet; use Namet;
-with Opt; use Opt;
-with Prj.Err; use Prj.Err;
-with Prj.Strt; use Prj.Strt;
-with Prj.Tree; use Prj.Tree;
-with Scans; use Scans;
+with Err_Vars; use Err_Vars;
+with Namet; use Namet;
+with Opt; use Opt;
+with Prj.Err; use Prj.Err;
+with Prj.Strt; use Prj.Strt;
+with Prj.Tree; use Prj.Tree;
+with Scans; use Scans;
with Snames;
-with Types; use Types;
-with Prj.Attr; use Prj.Attr;
-with Uintp; use Uintp;
+with Types; use Types;
+with Prj.Attr; use Prj.Attr;
+with Prj.Attr.PM; use Prj.Attr.PM;
+with Uintp; use Uintp;
package body Prj.Dect is
-- Scan past "package"
Scan;
-
Expect (Tok_Identifier, "identifier");
if Token = Tok_Identifier then
end record;
+ Project_Error : exception;
+ -- Raised by some subprograms in Prj.Attr.
+
function Empty_Project return Project_Data;
-- Return the representation of an empty project
extern void __gnat_set_globals (int, int,
char, char, char, char,
char *, char *,
- int, int, int, int);
+ int, int, int, int, int);
extern void __gnat_initialize (void);
extern void __gnat_init_float (void);
extern void __gnat_install_handler (void);
type Pkg_Node;
type Pkg_List is access Pkg_Node;
type Pkg_Node is record
- Name : String_Access;
- Next : Pkg_List;
+ Name : String_Access;
+ Subp_Info : System.Address;
+ Subp_Info_Len : Integer;
+ Next : Pkg_List;
end record;
Pkg_Head : Pkg_List;
-- String prepended in top of shared passive packages
procedure Check
- (Name : in Unit_Name;
- Version : in String;
- RCI : in Boolean := True)
+ (Name : Unit_Name;
+ Version : String;
+ RCI : Boolean := True)
is
begin
null;
-----------------------------
function Get_Active_Partition_ID
- (Name : Unit_Name)
- return System.RPC.Partition_ID
+ (Name : Unit_Name) return System.RPC.Partition_ID
is
P : Pkg_List := Pkg_Head;
N : String := Lower (Name);
-- Get_Active_Version --
------------------------
- function Get_Active_Version
- (Name : Unit_Name)
- return String
- is
+ function Get_Active_Version (Name : Unit_Name) return String is
begin
return "";
end Get_Active_Version;
------------------------------
function Get_Passive_Partition_ID
- (Name : Unit_Name)
- return System.RPC.Partition_ID
+ (Name : Unit_Name) return System.RPC.Partition_ID
is
begin
return Get_Local_Partition_ID;
-- Get_Passive_Version --
-------------------------
- function Get_Passive_Version
- (Name : Unit_Name)
- return String
- is
+ function Get_Passive_Version (Name : Unit_Name) return String is
begin
return "";
end Get_Passive_Version;
+ ------------------
+ -- Get_RAS_Info --
+ ------------------
+
+ procedure Get_RAS_Info
+ (Name : Unit_Name;
+ Subp_Id : Subprogram_Id;
+ Proxy_Address : out Interfaces.Unsigned_64)
+ is
+ LName : constant String := Lower (Name);
+ N : Pkg_List;
+ begin
+ N := Pkg_Head;
+ while N /= null loop
+ if N.Name.all = LName then
+ declare
+ subtype Subprogram_Array is RCI_Subp_Info_Array
+ (First_RCI_Subprogram_Id ..
+ First_RCI_Subprogram_Id + N.Subp_Info_Len - 1);
+ Subprograms : Subprogram_Array;
+ for Subprograms'Address use N.Subp_Info;
+ pragma Import (Ada, Subprograms);
+ begin
+ Proxy_Address :=
+ Interfaces.Unsigned_64 (Subprograms (Integer (Subp_Id)).Addr);
+ return;
+ end;
+ end if;
+ N := N.Next;
+ end loop;
+ Proxy_Address := 0;
+ end Get_RAS_Info;
+
------------------------------
-- Get_RCI_Package_Receiver --
------------------------------
function Get_RCI_Package_Receiver
- (Name : Unit_Name)
- return Interfaces.Unsigned_64
+ (Name : Unit_Name) return Interfaces.Unsigned_64
is
begin
return 0;
-------------------------------------
procedure Raise_Program_Error_Unknown_Tag
- (E : in Ada.Exceptions.Exception_Occurrence)
+ (E : Ada.Exceptions.Exception_Occurrence)
is
begin
Ada.Exceptions.Raise_Exception
------------------------------
procedure Register_Passive_Package
- (Name : in Unit_Name;
- Version : in String := "")
+ (Name : Unit_Name;
+ Version : String := "")
is
begin
- Register_Receiving_Stub (Passive_Prefix & Name, null, Version);
+ Register_Receiving_Stub
+ (Passive_Prefix & Name, null, Version, System.Null_Address, 0);
end Register_Passive_Package;
-----------------------------
-----------------------------
procedure Register_Receiving_Stub
- (Name : in Unit_Name;
- Receiver : in RPC.RPC_Receiver;
- Version : in String := "")
+ (Name : Unit_Name;
+ Receiver : RPC.RPC_Receiver;
+ Version : String := "";
+ Subp_Info : System.Address;
+ Subp_Info_Len : Integer)
is
+ N : constant Pkg_List :=
+ new Pkg_Node'(new String'(Lower (Name)),
+ Subp_Info, Subp_Info_Len,
+ Next => null);
begin
if Pkg_Tail = null then
- Pkg_Head := new Pkg_Node'(new String'(Lower (Name)), null);
- Pkg_Tail := Pkg_Head;
-
+ Pkg_Head := N;
else
- Pkg_Tail.Next := new Pkg_Node'(new String'(Lower (Name)), null);
- Pkg_Tail := Pkg_Tail.Next;
+ Pkg_Tail.Next := N;
end if;
+ Pkg_Tail := N;
end Register_Receiving_Stub;
---------
---------
procedure Run
- (Main : in Main_Subprogram_Type := null)
+ (Main : Main_Subprogram_Type := null)
is
begin
if Main /= null then
type DSA_Implementation_Name is (No_DSA, GLADE_DSA, PolyORB_DSA);
DSA_Implementation : constant DSA_Implementation_Name := No_DSA;
+ -- RCI receiving stubs contain a table of descriptors for
+ -- all user subprograms exported by the unit.
+
type Subprogram_Id is new Natural;
- -- This type is used exclusively by stubs
+ First_RCI_Subprogram_Id : constant := 2;
+
+ type RCI_Subp_Info is record
+ Addr : System.Address;
+ -- Local address of the proxy object
+ end record;
+
+ type RCI_Subp_Info_Access is access all RCI_Subp_Info;
+ type RCI_Subp_Info_Array is array (Integer range <>) of
+ aliased RCI_Subp_Info;
subtype Unit_Name is String;
-- Name of Ada units
Addr : Interfaces.Unsigned_64;
Asynchronous : Boolean;
end record;
+
type RACW_Stub_Type_Access is access RACW_Stub_Type;
-- This type is used by the expansion to implement distributed objects.
-- Do not change its definition or its layout without updating
-- exp_dist.adb.
+ type RAS_Proxy_Type is tagged limited record
+ All_Calls_Remote : Boolean;
+ Receiver : System.Address;
+ Subp_Id : Subprogram_Id;
+ end record;
+
+ type RAS_Proxy_Type_Access is access RAS_Proxy_Type;
+ pragma No_Strict_Aliasing (RAS_Proxy_Type_Access);
+ -- This type is used by the expansion to implement distributed objects.
+ -- Do not change its definition or its layout without updating
+ -- Exp_Dist.Build_Remote_Supbrogram_Proxy_Type.
+
procedure Check
- (Name : in Unit_Name;
- Version : in String;
- RCI : in Boolean := True);
+ (Name : Unit_Name;
+ Version : String;
+ RCI : Boolean := True);
-- Use by the main subprogram to check that a remote receiver
-- unit has has the same version than the caller's one.
- function Get_Active_Partition_ID
- (Name : Unit_Name)
- return RPC.Partition_ID;
+ function Get_Active_Partition_ID (Name : Unit_Name) return RPC.Partition_ID;
-- Similar in some respects to RCI_Info.Get_Active_Partition_ID
- function Get_Active_Version
- (Name : Unit_Name)
- return String;
+ function Get_Active_Version (Name : Unit_Name) return String;
-- Similar in some respects to Get_Active_Partition_ID
function Get_Local_Partition_ID return RPC.Partition_ID;
-- Return the Partition_ID of the current partition
function Get_Passive_Partition_ID
- (Name : Unit_Name)
- return RPC.Partition_ID;
+ (Name : Unit_Name) return RPC.Partition_ID;
-- Return the Partition_ID of the given shared passive partition
function Get_Passive_Version (Name : Unit_Name) return String;
-- Return the version corresponding to a shared passive unit
function Get_RCI_Package_Receiver
- (Name : Unit_Name)
- return Interfaces.Unsigned_64;
+ (Name : Unit_Name) return Interfaces.Unsigned_64;
-- Similar in some respects to RCI_Info.Get_RCI_Package_Receiver
procedure Get_Unique_Remote_Pointer
-- Get a unique pointer on a remote object
procedure Raise_Program_Error_Unknown_Tag
- (E : in Ada.Exceptions.Exception_Occurrence);
+ (E : Ada.Exceptions.Exception_Occurrence);
pragma No_Return (Raise_Program_Error_Unknown_Tag);
-- Raise Program_Error with the same message as E one
procedure Register_Receiving_Stub
- (Name : in Unit_Name;
- Receiver : in RPC.RPC_Receiver;
- Version : in String := "");
+ (Name : Unit_Name;
+ Receiver : RPC.RPC_Receiver;
+ Version : String := "";
+ Subp_Info : System.Address;
+ Subp_Info_Len : Integer);
-- Register the fact that the Name receiving stub is now elaborated.
-- Register the access value to the package RPC_Receiver procedure.
+ procedure Get_RAS_Info
+ (Name : Unit_Name;
+ Subp_Id : Subprogram_Id;
+ Proxy_Address : out Interfaces.Unsigned_64);
+ -- Look up the address of the proxy object for the given subprogram
+ -- in the named unit, or Null_Address if not present on the local
+ -- partition.
+
procedure Register_Passive_Package
- (Name : in Unit_Name;
- Version : in String := "");
+ (Name : Unit_Name;
+ Version : String := "");
-- Register a passive package
generic
end RCI_Info;
-- RCI package information caching
- procedure Run (Main : in Main_Subprogram_Type := null);
+ procedure Run (Main : Main_Subprogram_Type := null);
-- Run the main subprogram
end System.Partition_Interface;
-- Used for Self
-- Timed_Delay
+with System.Tasking;
+-- Used for Task_Id
+
+with Ada.Exceptions;
+-- Used for Raise_Exception
+
package body System.Soft_Links.Tasking is
package STPO renames System.Task_Primitives.Operations;
procedure Timed_Delay_T (Time : Duration; Mode : Integer);
-- Task-safe version of SSL.Timed_Delay
- ----------------------
- -- Soft-Link Bodies --
- ----------------------
+ --------------------------
+ -- Soft-Link Get Bodies --
+ --------------------------
function Get_Current_Excep return SSL.EOA is
begin
return STPO.Self.Common.Compiler_Data.Sec_Stack_Addr;
end Get_Sec_Stack_Addr;
+ --------------------------
+ -- Soft-Link Set Bodies --
+ --------------------------
+
procedure Set_Jmpbuf_Address (Addr : Address) is
begin
STPO.Self.Common.Compiler_Data.Jmpbuf_Address := Addr;
STPO.Self.Common.Compiler_Data.Sec_Stack_Addr := Addr;
end Set_Sec_Stack_Addr;
+ -------------------
+ -- Timed_Delay_T --
+ -------------------
+
procedure Timed_Delay_T (Time : Duration; Mode : Integer) is
+ Self_Id : constant System.Tasking.Task_Id := STPO.Self;
+
begin
- STPO.Timed_Delay (STPO.Self, Time, Mode);
+ -- In case pragma Detect_Blocking is active then Program_Error
+ -- must be raised if this potentially blocking operation
+ -- is called from a protected operation.
+
+ if System.Tasking.Detect_Blocking
+ and then Self_Id.Common.Protected_Action_Nesting > 0
+ then
+ Ada.Exceptions.Raise_Exception
+ (Program_Error'Identity, "potentially blocking operation");
+ else
+ STPO.Timed_Delay (Self_Id, Time, Mode);
+ end if;
+
end Timed_Delay_T;
-----------------------------
with System.Task_Primitives.Operations;
-- used for Write_Lock
-- Unlock
+-- Self
with System.Parameters;
-- used for Runtime_Traces
procedure Lock (Object : Protection_Access) is
Ceiling_Violation : Boolean;
+
begin
-- The lock is made without defering abortion.
if Ceiling_Violation then
raise Program_Error;
end if;
+
+ -- We are entering in a protected action, so that we increase the
+ -- protected object nesting level (if pragma Detect_Blocking is
+ -- active).
+
+ if Detect_Blocking then
+ declare
+ Self_Id : constant Task_Id := Self;
+ begin
+ Self_Id.Common.Protected_Action_Nesting :=
+ Self_Id.Common.Protected_Action_Nesting + 1;
+ end;
+ end if;
end Lock;
--------------------
procedure Lock_Read_Only (Object : Protection_Access) is
Ceiling_Violation : Boolean;
+
begin
Read_Lock (Object.L'Access, Ceiling_Violation);
if Ceiling_Violation then
raise Program_Error;
end if;
+
+ -- We are entering in a protected action, so that we increase the
+ -- protected object nesting level (if pragma Detect_Blocking is
+ -- active).
+
+ if Detect_Blocking then
+ declare
+ Self_Id : constant Task_Id := Self;
+ begin
+ Self_Id.Common.Protected_Action_Nesting :=
+ Self_Id.Common.Protected_Action_Nesting + 1;
+ end;
+ end if;
end Lock_Read_Only;
------------
procedure Unlock (Object : Protection_Access) is
begin
+ -- We are exiting from a protected action, so that we decrease the
+ -- protected object nesting level (if pragma Detect_Blocking is
+ -- active).
+
+ if Detect_Blocking then
+ declare
+ Self_Id : constant Task_Id := Self;
+
+ begin
+ -- Cannot call this procedure without being within a protected
+ -- action.
+
+ pragma Assert (Self_Id.Common.Protected_Action_Nesting > 0);
+
+ Self_Id.Common.Protected_Action_Nesting :=
+ Self_Id.Common.Protected_Action_Nesting - 1;
+ end;
+ end if;
+
Unlock (Object.L'Access);
if Parameters.Runtime_Traces then
T.Common.Parent := Parent;
T.Common.Base_Priority := Base_Priority;
T.Common.Current_Priority := 0;
+ T.Common.Protected_Action_Nesting := 0;
T.Common.Call := null;
T.Common.Task_Arg := Task_Arg;
T.Common.Task_Entry_Point := Task_Entry_Point;
------------------------------------
type Activation_Chain is limited private;
+ -- Comment required ???
type Activation_Chain_Access is access all Activation_Chain;
+ -- Comment required ???
type Task_Procedure_Access is access procedure (Arg : System.Address);
type Access_Boolean is access all Boolean;
+ Detect_Blocking : constant Boolean;
+ -- Boolean constant set True iff Detect_Blocking is active
+
----------------------------------------------
-- Ada_Task_Control_Block (ATCB) definition --
----------------------------------------------
-- accepts an entry or when Created activates, at which points Self is
-- suspended.
+ Protected_Action_Nesting : Natural;
+ pragma Atomic (Protected_Action_Nesting);
+ -- The dynamic level of protected action nesting for this task.
+ -- This field is needed for checking whether potentially
+ -- blocking operations are invoked from protected actions.
+ -- pragma Atomic is used because it can be read/written from
+ -- protected interrupt handlers.
+
Task_Image : String (1 .. 32);
-- Hold a string that provides a readable id for task,
-- built from the variable of which it is a value or component.
private
Null_Task : constant Task_Id := null;
+ GL_Detect_Blocking : Integer;
+ pragma Import (C, GL_Detect_Blocking, "__gl_detect_blocking");
+ -- Global variable exported by the binder generated file. A value
+ -- equal to 1 indicates that pragma Detect_Blocking is active,
+ -- while 0 is used for the pragma not being present.
+
+ Detect_Blocking : constant Boolean := GL_Detect_Blocking = 1;
+
type Activation_Chain is record
T_ID : Task_Id;
end record;
Accept_Alternative_Open,
No_Alternative_Open);
+ ----------------
+ -- Local Data --
+ ----------------
+
Default_Treatment : constant array (Select_Modes) of Select_Treatment :=
(Simple_Mode => No_Alternative_Open,
Else_Mode => Else_Selected,
Uninterpreted_Data : System.Address)
is
Rendezvous_Successful : Boolean;
+
begin
+ -- If pragma Detect_Blocking is active then Program_Error must be
+ -- raised if this potentially blocking operation is called from a
+ -- protected action.
+
+ if System.Tasking.Detect_Blocking
+ and then STPO.Self.Common.Protected_Action_Nesting > 0
+ then
+ Ada.Exceptions.Raise_Exception
+ (Program_Error'Identity, "potentially blocking operation");
+ end if;
+
Call_Synchronous
(Acceptor, E, Uninterpreted_Data, Simple_Call, Rendezvous_Successful);
end Call_Simple;
Entry_Call : Entry_Call_Link;
begin
+ -- If pragma Detect_Blocking is active then Program_Error must be
+ -- raised if this potentially blocking operation is called from a
+ -- protected action.
+
+ if System.Tasking.Detect_Blocking
+ and then Self_Id.Common.Protected_Action_Nesting > 0
+ then
+ Ada.Exceptions.Raise_Exception
+ (Program_Error'Identity, "potentially blocking operation");
+ end if;
+
if Parameters.Runtime_Traces then
Send_Trace_Info (W_Call, Acceptor, Entry_Index (E));
end if;
Yielded : Boolean;
begin
+ -- If pragma Detect_Blocking is active then Program_Error must be
+ -- raised if this potentially blocking operation is called from a
+ -- protected action.
+
+ if System.Tasking.Detect_Blocking
+ and then Self_Id.Common.Protected_Action_Nesting > 0
+ then
+ Ada.Exceptions.Raise_Exception
+ (Program_Error'Identity, "potentially blocking operation");
+ end if;
+
Initialization.Defer_Abort (Self_Id);
Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1;
procedure Abort_Tasks (Tasks : Task_List) is
begin
+ -- If pragma Detect_Blocking is active then Program_Error must be
+ -- raised if this potentially blocking operation is called from a
+ -- protected action.
+
+ if System.Tasking.Detect_Blocking
+ and then STPO.Self.Common.Protected_Action_Nesting > 0
+ then
+ Ada.Exceptions.Raise_Exception
+ (Program_Error'Identity, "potentially blocking operation");
+ end if;
+
Utilities.Abort_Tasks (Tasks);
end Abort_Tasks;
All_Elaborated : Boolean := True;
begin
+ -- If pragma Detect_Blocking is active must be checked whether
+ -- this potentially blocking operation is called from a
+ -- protected action.
+
+ if System.Tasking.Detect_Blocking
+ and then Self_ID.Common.Protected_Action_Nesting > 0
+ then
+ Ada.Exceptions.Raise_Exception
+ (Program_Error'Identity, "potentially blocking operation");
+ end if;
+
pragma Debug
(Debug.Trace (Self_ID, "Activate_Tasks", 'C'));
Len : Natural;
begin
+ -- If pragma Detect_Blocking is active must be checked whether
+ -- this potentially blocking operation is called from a
+ -- protected action.
+
+ if System.Tasking.Detect_Blocking
+ and then Self_ID.Common.Protected_Action_Nesting > 0
+ then
+ Ada.Exceptions.Raise_Exception
+ (Program_Error'Identity, "potentially blocking operation");
+ end if;
+
pragma Debug
(Debug.Trace (Self_ID, "Create_Task", 'C'));
with Ada.Exceptions;
-- used for Exception_Occurrence_Access
+-- Raise_Exception
with System.Task_Primitives.Operations;
-- used for Initialize_Lock
use Task_Primitives.Operations;
use Ada.Exceptions;
+ ----------------
+ -- Local Data --
+ ----------------
+
Locking_Policy : Character;
pragma Import (C, Locking_Policy, "__gl_locking_policy");
------------------
procedure Lock_Entries
- (Object : Protection_Entries_Access; Ceiling_Violation : out Boolean) is
+ (Object : Protection_Entries_Access; Ceiling_Violation : out Boolean)
+ is
begin
if Object.Finalized then
Raise_Exception
(Program_Error'Identity, "Protected Object is finalized");
end if;
+ -- If pragma Detect_Blocking is active then Program_Error must
+ -- be raised if this potentially blocking operation is called from
+ -- a protected action, and the protected object nesting level
+ -- must be increased.
+
+ if Detect_Blocking then
+ declare
+ Self_Id : constant Task_Id := STPO.Self;
+ begin
+ if Self_Id.Common.Protected_Action_Nesting > 0 then
+ Ada.Exceptions.Raise_Exception
+ (Program_Error'Identity, "potentially blocking operation");
+ else
+ -- We are entering in a protected action, so that we
+ -- increase the protected object nesting level.
+
+ Self_Id.Common.Protected_Action_Nesting :=
+ Self_Id.Common.Protected_Action_Nesting + 1;
+ end if;
+ end;
+ end if;
+
-- The lock is made without defering abortion.
-- Therefore the abortion has to be deferred before calling this
procedure Lock_Entries (Object : Protection_Entries_Access) is
Ceiling_Violation : Boolean;
- begin
- if Object.Finalized then
- Raise_Exception
- (Program_Error'Identity, "Protected Object is finalized");
- end if;
- pragma Assert (STPO.Self.Deferral_Level > 0);
- Write_Lock (Object.L'Access, Ceiling_Violation);
+ begin
+ Lock_Entries (Object, Ceiling_Violation);
if Ceiling_Violation then
Raise_Exception (Program_Error'Identity, "Ceiling Violation");
procedure Lock_Read_Only_Entries (Object : Protection_Entries_Access) is
Ceiling_Violation : Boolean;
+
begin
if Object.Finalized then
Raise_Exception
(Program_Error'Identity, "Protected Object is finalized");
end if;
+ -- If pragma Detect_Blocking is active then Program_Error must be
+ -- raised if this potentially blocking operation is called from a
+ -- protected action, and the protected object nesting level must
+ -- be increased.
+
+ if Detect_Blocking then
+ declare
+ Self_Id : constant Task_Id := STPO.Self;
+ begin
+ if Self_Id.Common.Protected_Action_Nesting > 0 then
+ Ada.Exceptions.Raise_Exception
+ (Program_Error'Identity, "potentially blocking operation");
+ else
+ -- We are entering in a protected action, so that we
+ -- increase the protected object nesting level.
+
+ Self_Id.Common.Protected_Action_Nesting :=
+ Self_Id.Common.Protected_Action_Nesting + 1;
+ end if;
+ end;
+ end if;
+
Read_Lock (Object.L'Access, Ceiling_Violation);
if Ceiling_Violation then
procedure Unlock_Entries (Object : Protection_Entries_Access) is
begin
+ -- We are exiting from a protected action, so that we decrease the
+ -- protected object nesting level (if pragma Detect_Blocking is
+ -- active).
+
+ if Detect_Blocking then
+ declare
+ Self_Id : constant Task_Id := Self;
+ begin
+ -- Cannot call this procedure without being within a protected
+ -- action.
+
+ pragma Assert (Self_Id.Common.Protected_Action_Nesting > 0);
+
+ Self_Id.Common.Protected_Action_Nesting :=
+ Self_Id.Common.Protected_Action_Nesting - 1;
+ end;
+ end if;
+
Unlock (Object.L'Access);
end Unlock_Entries;
-- Unlock
with Ada.Exceptions;
--- used for Exception_Id;
+-- used for Exception_Id
+-- Raise_Exception
with System.Parameters;
-- used for Single_Lock
procedure Lock_Entry (Object : Protection_Entry_Access) is
Ceiling_Violation : Boolean;
+
begin
+ -- If pragma Detect_Blocking is active then Program_Error must
+ -- be raised if this potentially blocking operation is called from
+ -- a protected action, and the protected object nesting level
+ -- must be increased.
+
+ if Detect_Blocking then
+ declare
+ Self_Id : constant Task_Id := STPO.Self;
+ begin
+ if Self_Id.Common.Protected_Action_Nesting > 0 then
+ Ada.Exceptions.Raise_Exception
+ (Program_Error'Identity, "potentially blocking operation");
+ else
+ -- We are entering in a protected action, so that we
+ -- increase the protected object nesting level.
+
+ Self_Id.Common.Protected_Action_Nesting :=
+ Self_Id.Common.Protected_Action_Nesting + 1;
+ end if;
+ end;
+ end if;
+
STPO.Write_Lock (Object.L'Access, Ceiling_Violation);
if Ceiling_Violation then
procedure Lock_Read_Only_Entry (Object : Protection_Entry_Access) is
Ceiling_Violation : Boolean;
+
begin
+ -- If pragma Detect_Blocking is active then Program_Error must be
+ -- raised if this potentially blocking operation is called from a
+ -- protected action, and the protected object nesting level must
+ -- be increased.
+
+ if Detect_Blocking then
+ declare
+ Self_Id : constant Task_Id := STPO.Self;
+ begin
+ if Self_Id.Common.Protected_Action_Nesting > 0 then
+ Ada.Exceptions.Raise_Exception
+ (Program_Error'Identity, "potentially blocking operation");
+ else
+ -- We are entering in a protected action, so that we
+ -- increase the protected object nesting level.
+
+ Self_Id.Common.Protected_Action_Nesting :=
+ Self_Id.Common.Protected_Action_Nesting + 1;
+ end if;
+ end;
+ end if;
+
STPO.Read_Lock (Object.L'Access, Ceiling_Violation);
if Ceiling_Violation then
Ceiling_Violation : Boolean;
begin
+ -- If pragma Detect_Blocking is active then Program_Error must be
+ -- raised if this potentially blocking operation is called from a
+ -- protected action.
+
+ if Detect_Blocking
+ and then Self_Id.Common.Protected_Action_Nesting > 0
+ then
+ Ada.Exceptions.Raise_Exception
+ (Program_Error'Identity, "potentially blocking operation");
+ end if;
+
STPO.Write_Lock (Object.L'Access, Ceiling_Violation);
if Ceiling_Violation then
Ceiling_Violation : Boolean;
begin
+ -- If pragma Detect_Blocking is active then Program_Error must be
+ -- raised if this potentially blocking operation is called from a
+ -- protected action.
+
+ if Detect_Blocking
+ and then Self_Id.Common.Protected_Action_Nesting > 0
+ then
+ Ada.Exceptions.Raise_Exception
+ (Program_Error'Identity, "potentially blocking operation");
+ end if;
+
STPO.Write_Lock (Object.L'Access, Ceiling_Violation);
if Ceiling_Violation then
procedure Unlock_Entry (Object : Protection_Entry_Access) is
begin
+ -- We are exiting from a protected action, so that we decrease the
+ -- protected object nesting level (if pragma Detect_Blocking is active).
+
+ if Detect_Blocking then
+ declare
+ Self_Id : constant Task_Id := Self;
+
+ begin
+ -- Cannot call Unlock_Entry without being within protected action
+
+ pragma Assert (Self_Id.Common.Protected_Action_Nesting > 0);
+
+ Self_Id.Common.Protected_Action_Nesting :=
+ Self_Id.Common.Protected_Action_Nesting - 1;
+ end;
+ end if;
+
STPO.Unlock (Object.L'Access);
end Unlock_Entry;
elsif Private_Extension and then Is_Generic_Type (Derived_Type) then
Record_Type_Definition (Empty, Derived_Type);
- -- STEP 5c: Process the record extension for non private tagged types.
+ -- STEP 5c: Process the record extension for non private tagged types
elsif not Private_Extension then
- -- Add the _parent field in the derived type.
- Expand_Derived_Record (Derived_Type, Type_Def);
+ -- Add the _parent field in the derived type
+
+ Expand_Record_Extension (Derived_Type, Type_Def);
-- Analyze the record extension
and then Ekind (Etype (Formal)) = E_Anonymous_Access_Type
then
Error_Msg_N
- ("Access parameter of a remote subprogram must be controlling",
+ ("access parameter of remote object primitive"
+ & " must be controlling",
Formal);
end if;
end if;
end Add_Stub_Constructs;
+ ---------------------------------------
+ -- Build_RAS_Primitive_Specification --
+ ---------------------------------------
+
+ function Build_RAS_Primitive_Specification
+ (Subp_Spec : Node_Id;
+ Remote_Object_Type : Node_Id) return Node_Id
+ is
+ Loc : constant Source_Ptr := Sloc (Subp_Spec);
+
+ Primitive_Spec : constant Node_Id :=
+ Copy_Specification (Loc,
+ Spec => Subp_Spec,
+ New_Name => Name_Call);
+
+ Subtype_Mark_For_Self : Node_Id;
+
+ begin
+ if No (Parameter_Specifications (Primitive_Spec)) then
+ Set_Parameter_Specifications (Primitive_Spec, New_List);
+ end if;
+
+ if Nkind (Remote_Object_Type) in N_Entity then
+ Subtype_Mark_For_Self :=
+ New_Occurrence_Of (Remote_Object_Type, Loc);
+ else
+ Subtype_Mark_For_Self := Remote_Object_Type;
+ end if;
+
+ Prepend_To (
+ Parameter_Specifications (Primitive_Spec),
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_uS),
+ Parameter_Type =>
+ Make_Access_Definition (Loc,
+ Subtype_Mark =>
+ Subtype_Mark_For_Self)));
+
+ -- Trick later semantic analysis into considering this
+ -- operation as a primitive (dispatching) operation of
+ -- tagged type Obj_Type.
+
+ Set_Comes_From_Source (
+ Defining_Unit_Name (Primitive_Spec), True);
+
+ return Primitive_Spec;
+ end Build_RAS_Primitive_Specification;
+
-------------------------
-- Full_Qualified_Name --
-------------------------
Async_E : Entity_Id;
All_Calls_Remote_E : Entity_Id;
Attribute_Subp : Entity_Id;
- Local_Addr : Node_Id;
begin
-- Check if we have to expand the access attribute
All_Calls_Remote_E :=
Boolean_Literals (Has_All_Calls_Remote (RS_Pkg_E));
- Local_Addr :=
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Remote_Subp, Loc),
- Attribute_Name => Name_Address);
-
Tick_Access_Conv_Call :=
Make_Function_Call (Loc,
Name => New_Occurrence_Of (Attribute_Subp, Loc),
Parameter_Associations =>
New_List (
- Local_Addr,
Make_String_Literal (Loc, Full_Qualified_Name (RS_Pkg_E)),
Build_Subprogram_Id (Loc, Remote_Subp),
New_Occurrence_Of (Async_E, Loc),
------------------------------------
procedure Process_Remote_AST_Declaration (N : Node_Id) is
- Loc : constant Source_Ptr := Sloc (N);
- User_Type : constant Node_Id := Defining_Identifier (N);
- Fat_Type : constant Entity_Id :=
+ Loc : constant Source_Ptr := Sloc (N);
+ User_Type : constant Node_Id := Defining_Identifier (N);
+ Scop : constant Entity_Id := Scope (User_Type);
+ Is_RCI : constant Boolean :=
+ Is_Remote_Call_Interface (Scop);
+ Is_RT : constant Boolean :=
+ Is_Remote_Types (Scop);
+ Type_Def : constant Node_Id := Type_Definition (N);
+
+ Parameter : Node_Id;
+ Is_Degenerate : Boolean;
+ -- True iff this RAS has an access formal parameter (see
+ -- Exp_Dist.Add_RAS_Dereference_TSS for details).
+
+ Subpkg : constant Entity_Id :=
+ Make_Defining_Identifier
+ (Loc, New_Internal_Name ('S'));
+ Subpkg_Decl : Node_Id;
+ Vis_Decls : constant List_Id := New_List;
+ Priv_Decls : constant List_Id := New_List;
+
+ Obj_Type : constant Entity_Id :=
+ Make_Defining_Identifier
+ (Loc, New_External_Name (
+ Chars (User_Type), 'R'));
+
+
+ Full_Obj_Type : constant Entity_Id :=
+ Make_Defining_Identifier
+ (Loc, Chars (Obj_Type));
+
+ RACW_Type : constant Entity_Id :=
+ Make_Defining_Identifier
+ (Loc, New_External_Name (
+ Chars (User_Type), 'P'));
+
+ Fat_Type : constant Entity_Id :=
Make_Defining_Identifier
(Loc, Chars (User_Type));
- New_Type_Decl : Node_Id;
+ Fat_Type_Decl : Node_Id;
begin
- -- We add a record type declaration for the equivalent fat pointer type
- New_Type_Decl :=
+ -- The tagged private type, primitive operation and RACW
+ -- type associated with a RAS need to all be declared in
+ -- a subpackage of the one that contains the RAS declaration,
+ -- because the primitive of the object type, and the associated
+ -- primitive of the stub type, need to be dispatching operations
+ -- of these types, and the profile of the RAS might contain
+ -- tagged types declared in the same scope.
+
+ Append_To (Vis_Decls,
+ Make_Private_Type_Declaration (Loc,
+ Defining_Identifier => Obj_Type,
+ Abstract_Present => True,
+ Tagged_Present => True,
+ Limited_Present => True));
+
+ Append_To (Priv_Decls,
Make_Full_Type_Declaration (Loc,
- Defining_Identifier => Fat_Type,
- Type_Definition =>
+ Defining_Identifier =>
+ Full_Obj_Type,
+ Type_Definition =>
Make_Record_Definition (Loc,
- Component_List =>
- Make_Component_List (Loc,
- Component_Items => New_List (
-
- Make_Component_Declaration (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc,
- Chars => Name_Ras),
- Component_Definition =>
- Make_Component_Definition (Loc,
- Aliased_Present => False,
- Subtype_Indication =>
- New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))),
-
- Make_Component_Declaration (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc,
- Chars => Name_Origin),
- Component_Definition =>
- Make_Component_Definition (Loc,
- Aliased_Present => False,
- Subtype_Indication =>
- New_Reference_To (Standard_Integer, Loc))),
-
- Make_Component_Declaration (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc,
- Chars => Name_Receiver),
- Component_Definition =>
- Make_Component_Definition (Loc,
- Aliased_Present => False,
- Subtype_Indication =>
- New_Reference_To (RTE (RE_Unsigned_64), Loc))),
-
- Make_Component_Declaration (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc,
- Chars => Name_Subp_Id),
- Component_Definition =>
- Make_Component_Definition (Loc,
- Aliased_Present => False,
- Subtype_Indication =>
- New_Reference_To (Standard_Natural, Loc))),
-
- Make_Component_Declaration (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc,
- Chars => Name_Async),
- Component_Definition =>
- Make_Component_Definition (Loc,
- Aliased_Present => False,
- Subtype_Indication =>
- New_Reference_To (Standard_Boolean, Loc)))))));
-
- Insert_After (N, New_Type_Decl);
+ Abstract_Present => True,
+ Tagged_Present => True,
+ Limited_Present => True,
+ Null_Present => True,
+ Component_List => Empty)));
+
+ Is_Degenerate := False;
+ Parameter := First (Parameter_Specifications (Type_Def));
+ Parameters : while Present (Parameter) loop
+ if Nkind (Parameter_Type (Parameter)) = N_Access_Definition then
+ Error_Msg_N ("formal parameter& has anonymous access type?",
+ Defining_Identifier (Parameter));
+ Is_Degenerate := True;
+ exit Parameters;
+ end if;
+ Next (Parameter);
+ end loop Parameters;
+
+ if Is_Degenerate then
+ Error_Msg_NE (
+ "remote access-to-subprogram type& can only be null?",
+ Defining_Identifier (Parameter), User_Type);
+ -- The only legal value for a RAS with a formal parameter of an
+ -- anonymous access type is null, because it cannot be
+ -- subtype-Conformant with any legal remote subprogram declaration.
+ -- In this case, we cannot generate a corresponding primitive
+ -- operation.
+
+ else
+ Append_To (Vis_Decls,
+ Make_Abstract_Subprogram_Declaration (Loc,
+ Specification => Build_RAS_Primitive_Specification (
+ Subp_Spec => Type_Def,
+ Remote_Object_Type => Obj_Type)));
+ end if;
+
+ Append_To (Vis_Decls,
+ Make_Full_Type_Declaration (Loc,
+ Defining_Identifier => RACW_Type,
+ Type_Definition =>
+ Make_Access_To_Object_Definition (Loc,
+ All_Present => True,
+ Subtype_Indication =>
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Obj_Type, Loc),
+ Attribute_Name =>
+ Name_Class))));
+ Set_Is_Remote_Call_Interface (RACW_Type, Is_RCI);
+ Set_Is_Remote_Types (RACW_Type, Is_RT);
+ -- ??? Object RPC receiver generation should be bypassed for this
+ -- RACW type, since actually calls will be received by the package
+ -- RPC receiver for the designated RCI subprogram.
+
+ Subpkg_Decl :=
+ Make_Package_Declaration (Loc,
+ Make_Package_Specification (Loc,
+ Defining_Unit_Name =>
+ Subpkg,
+ Visible_Declarations =>
+ Vis_Decls,
+ Private_Declarations =>
+ Priv_Decls,
+ End_Label =>
+ New_Occurrence_Of (Subpkg, Loc)));
+ Set_Is_Remote_Call_Interface (Subpkg, Is_RCI);
+ Set_Is_Remote_Types (Subpkg, Is_RT);
+ Insert_After_And_Analyze (N, Subpkg_Decl);
+
+ -- Many parts of the analyzer and expander expect
+ -- that the fat pointer type used to implement remote
+ -- access to subprogram types be a record.
+ -- Note: The structure of this type must be kept consistent
+ -- with the code generated by Remote_AST_Null_Value for the
+ -- corresponding 'null' expression.
+
+ Fat_Type_Decl := Make_Full_Type_Declaration (Loc,
+ Defining_Identifier => Fat_Type,
+ Type_Definition =>
+ Make_Record_Definition (Loc,
+ Component_List =>
+ Make_Component_List (Loc,
+ Component_Items => New_List (
+ Make_Component_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_Ras),
+ Component_Definition =>
+ Make_Component_Definition (Loc,
+ Aliased_Present =>
+ False,
+ Subtype_Indication =>
+ New_Occurrence_Of (RACW_Type, Loc)))))));
Set_Equivalent_Type (User_Type, Fat_Type);
Set_Corresponding_Remote_Type (Fat_Type, User_Type);
+ Insert_After_And_Analyze (Subpkg_Decl, Fat_Type_Decl);
-- The reason we suppress the initialization procedure is that we know
-- that no initialization is required (even if Initialize_Scalars mode
-- Remote_AST_E_Dereference --
------------------------------
- function Remote_AST_E_Dereference (P : Node_Id) return Boolean
- is
+ function Remote_AST_E_Dereference (P : Node_Id) return Boolean is
ET : constant Entity_Id := Etype (P);
begin
-- Remote_AST_I_Dereference --
------------------------------
- function Remote_AST_I_Dereference (P : Node_Id) return Boolean
- is
+ function Remote_AST_I_Dereference (P : Node_Id) return Boolean is
ET : constant Entity_Id := Etype (P);
Deref : Node_Id;
- begin
+ begin
if Comes_From_Source (P)
and then (Is_Remote_Call_Interface (ET)
or else Is_Remote_Types (ET))
---------------------------
function Remote_AST_Null_Value
- (N : Node_Id;
- Typ : Entity_Id)
- return Boolean
+ (N : Node_Id;
+ Typ : Entity_Id) return Boolean
is
Loc : constant Source_Ptr := Sloc (N);
Target_Type : Entity_Id;
Rewrite (N,
Make_Aggregate (Loc,
- Expressions => New_List (
- Make_Integer_Literal (Loc, 0), -- Ras
- Make_Integer_Literal (Loc, 0), -- Origin
- Make_Integer_Literal (Loc, 0), -- Receiver
- Make_Integer_Literal (Loc, 0), -- Subp_Id
- New_Occurrence_Of (Standard_False, Loc)))); -- Asyn
+ Component_Associations => New_List (
+ Make_Component_Association (Loc,
+ Choices => New_List (
+ Make_Identifier (Loc, Name_Ras)),
+ Expression =>
+ Make_Null (Loc)))));
Analyze_And_Resolve (N, Target_Type);
return True;
end Remote_AST_Null_Value;
-- caller stubs, expansion takes place directly in the specification and
-- no additional compilation unit is created.
+ function Build_RAS_Primitive_Specification
+ (Subp_Spec : Node_Id;
+ Remote_Object_Type : Node_Id) return Node_Id;
+ -- Build a subprogram specification for the primitive operation of the
+ -- Remote_Object_Type used to implement a remote access-to-subprogram
+ -- type whose parameter profile is given by specification Subp_Spec.
+
function Is_All_Remote_Call (N : Node_Id) return Boolean;
-- Check whether a function or procedure call should be expanded into
-- a remote call, because the entity is declared in a package decl that
-- the previous function.
function Remote_AST_Null_Value
- (N : Node_Id;
- Typ : Entity_Id)
- return Boolean;
+ (N : Node_Id;
+ Typ : Entity_Id) return Boolean;
-- If N is a null value and Typ a remote access to subprogram type,
-- this function will check if null needs to be replaced with an
-- aggregate and will return True in this case. Otherwise, it will
-- denoted entities in the same declarative part.
Hom_Id := Def_Id;
-
while Present (Hom_Id) loop
Def_Id := Get_Base_Subprogram (Hom_Id);
elsif Ekind (Nm) = E_Record_Type
and then Present (Corresponding_Remote_Type (Nm))
then
+ -- A record type that is the Equivalent_Type for
+ -- a remote access-to-subprogram type.
+
N := Declaration_Node (Corresponding_Remote_Type (Nm));
if Nkind (N) = N_Full_Type_Declaration
L := Parameter_Specifications (Type_Definition (N));
Process_Async_Pragma;
+ if Is_Asynchronous (Nm)
+ and then Expander_Active
+ then
+ RACW_Type_Is_Asynchronous (
+ Underlying_RACW_Type (Nm));
+ end if;
+
else
Error_Pragma_Arg
("pragma% cannot reference access-to-function type",
-- visibility of these user-defined operations must be special-cased
-- to determine whether they hide or are hidden by predefined operators.
-- The form P."+" (x, y) requires additional handling.
- --
+
-- Concatenation is treated more conventionally: for every one-dimensional
-- array type we introduce a explicit concatenation operator. This is
-- necessary to handle the case of (element & element => array) which
procedure All_Overloads;
pragma Warnings (Off, All_Overloads);
- -- Debugging procedure: list full contents of Overloads table.
+ -- Debugging procedure: list full contents of Overloads table
procedure New_Interps (N : Node_Id);
-- Initialize collection of interpretations for the given node, which is
begin
Get_First_Interp (N, Index, It);
-
while Present (It.Nam) loop
-- A user-defined subprogram hides another declared at an outer
exit;
elsif not In_Open_Scopes (Scope (Name))
- or else Scope_Depth (Scope (Name))
- <= Scope_Depth (Scope (It.Nam))
+ or else Scope_Depth (Scope (Name)) <=
+ Scope_Depth (Scope (It.Nam))
then
-- If ambiguity within instance, and entity is not an
-- implicit operation, save for later disambiguation.
elsif Nkind (N) = N_Function_Call then
Arg := First_Actual (N);
-
while Present (Arg) loop
-
if No (Universal_Interpretation (Arg)) then
return False;
end if;
or else Is_Potentially_Use_Visible (Vis_Type)
or else In_Use (Vis_Type)
or else (In_Use (Scope (Vis_Type))
- and then not Is_Hidden (Vis_Type))
+ and then not Is_Hidden (Vis_Type))
or else Nkind (N) = N_Expanded_Name
or else (Nkind (N) in N_Op and then E = Entity (N))
or else In_Instance
elsif Nkind (N) = N_Function_Call
and then Nkind (Name (N)) = N_Expanded_Name
and then (Entity (Prefix (Name (N))) = Scope (Base_Type (T))
- or else Entity (Prefix (Name (N))) = Scope (Vis_Type)
- or else Scope (Vis_Type) = System_Aux_Id)
+ or else Entity (Prefix (Name (N))) = Scope (Vis_Type)
+ or else Scope (Vis_Type) = System_Aux_Id)
then
null;
Set_Etype (N, T);
else
- -- Record both the operator or subprogram name, and its type.
+ -- Record both the operator or subprogram name, and its type
if Nkind (N) in N_Op or else Is_Entity_Name (N) then
Set_Entity (N, E);
for J in First_Interp .. All_Interp.Last - 1 loop
- -- Current homograph is not hidden. Add to overloads.
+ -- Current homograph is not hidden. Add to overloads
if not Is_Immediately_Visible (All_Interp.Table (J).Nam) then
exit;
- -- Homograph is hidden, unless it is a predefined operator.
+ -- Homograph is hidden, unless it is a predefined operator
elsif Type_Conformant (H, All_Interp.Table (J).Nam) then
H := Homonym (H);
end loop;
- -- Scan list of homographs for use-visible entities only.
+ -- Scan list of homographs for use-visible entities only
H := Current_Entity (Ent);
if All_Interp.Last = First_Interp + 1 then
- -- The original interpretation is in fact not overloaded.
+ -- The original interpretation is in fact not overloaded
Set_Is_Overloaded (N, False);
end if;
then
return True;
- -- The context may be class wide.
+ -- The context may be class wide
elsif Is_Class_Wide_Type (T1)
and then Is_Ancestor (Root_Type (T1), T2)
Predef_Subp : Entity_Id;
User_Subp : Entity_Id;
+ function Inherited_From_Actual (S : Entity_Id) return Boolean;
+ -- Determine whether one of the candidates is an operation inherited
+ -- by a type that is derived from an actual in an instantiation.
+
function Is_Actual_Subprogram (S : Entity_Id) return Boolean;
-- Determine whether a subprogram is an actual in an enclosing
-- instance. An overloading between such a subprogram and one
-- ambiguities when two formal types have the same actual.
function Standard_Operator return Boolean;
+ -- Comment required ???
function Remove_Conversions return Interp;
-- Last chance for pathological cases involving comparisons on
-- pathology in the other direction with calls whose multiple overloaded
-- actuals make them truly unresolvable.
+ ---------------------------
+ -- Inherited_From_Actual --
+ ---------------------------
+
+ function Inherited_From_Actual (S : Entity_Id) return Boolean is
+ Par : constant Node_Id := Parent (S);
+ begin
+ if Nkind (Par) /= N_Full_Type_Declaration
+ or else Nkind (Type_Definition (Par)) /= N_Derived_Type_Definition
+ then
+ return False;
+ else
+ return Is_Entity_Name (Subtype_Indication (Type_Definition (Par)))
+ and then
+ Is_Generic_Actual_Type (
+ Entity (Subtype_Indication (Type_Definition (Par))));
+ end if;
+ end Inherited_From_Actual;
+
+ --------------------------
+ -- Is_Actual_Subprogram --
+ --------------------------
+
function Is_Actual_Subprogram (S : Entity_Id) return Boolean is
begin
return In_Open_Scopes (Scope (S))
function Matches (Actual, Formal : Node_Id) return Boolean is
T1 : constant Entity_Id := Etype (Actual);
T2 : constant Entity_Id := Etype (Formal);
-
begin
return T1 = T2
or else
Act2 : Node_Id;
begin
- It1 := No_Interp;
- Get_First_Interp (N, I, It);
+ It1 := No_Interp;
+ Get_First_Interp (N, I, It);
while Present (It.Typ) loop
if not Is_Overloadable (It.Nam) then
Get_Next_Interp (I, It);
end loop;
- if Serious_Errors_Detected > 0 then
-
- -- After some error, a formal may have Any_Type and yield
- -- a spurious match. To avoid cascaded errors if possible,
- -- check for such a formal in either candidate.
+ -- After some error, a formal may have Any_Type and yield
+ -- a spurious match. To avoid cascaded errors if possible,
+ -- check for such a formal in either candidate.
+ if Serious_Errors_Detected > 0 then
declare
Formal : Entity_Id;
-- Start of processing for Disambiguate
begin
- -- Recover the two legal interpretations.
+ -- Recover the two legal interpretations
Get_First_Interp (N, I, It);
-
while I /= I1 loop
Get_Next_Interp (I, It);
end loop;
It1 := It;
Nam1 := It.Nam;
-
while I /= I2 loop
Get_Next_Interp (I, It);
end loop;
declare
Candidate : Interp := No_Interp;
+
begin
Get_First_Interp (N, I, It);
-
while Present (It.Typ) loop
if (Covers (Typ, It.Typ)
- or else Typ = Any_Type)
+ or else Typ = Any_Type)
and then
(It.Typ = Universal_Integer
or else It.Typ = Universal_Real)
end;
elsif Chars (Nam1) /= Name_Op_Not
- and then (Typ = Standard_Boolean
- or else Typ = Any_Boolean)
+ and then (Typ = Standard_Boolean or else Typ = Any_Boolean)
then
-- Equality or comparison operation. Choose predefined operator
-- if arguments are universal. The node may be an operator, a
Universal_Interpretation (Arg1)
then
Get_First_Interp (N, I, It);
-
while Scope (It.Nam) /= Standard_Standard loop
Get_Next_Interp (I, It);
end loop;
-- node is overloaded, it did not resolve to the global entity in
-- the generic, and we choose the formal subprogram.
+ -- Finally, the ambiguity can be between an explicit subprogram and
+ -- one inherited (with different defaults) from an actual. In this
+ -- case the resolution was to the explicit declaration in the
+ -- generic, and remains so in the instance.
+
elsif In_Instance then
if Nkind (N) = N_Function_Call
or else Nkind (N) = N_Procedure_Call_Statement
elsif Is_Act2 and then not Is_Act1 then
return It2;
+
+ elsif Inherited_From_Actual (Nam1)
+ and then Comes_From_Source (Nam2)
+ then
+ return It2;
+
+ elsif Inherited_From_Actual (Nam2)
+ and then Comes_From_Source (Nam1)
+ then
+ return It1;
end if;
Actual := First_Actual (N);
end;
elsif Nkind (N) in N_Binary_Op then
-
if Matches (Left_Opnd (N), First_Formal (Nam1))
and then
Matches (Right_Opnd (N), Next_Formal (First_Formal (Nam1)))
end if;
elsif Nkind (N) in N_Unary_Op then
-
if Etype (Right_Opnd (N)) = Etype (First_Formal (Nam1)) then
return It1;
else
then
if Is_Fixed_Point_Type (Typ)
and then (Chars (Nam1) = Name_Op_Multiply
- or else Chars (Nam1) = Name_Op_Divide)
+ or else Chars (Nam1) = Name_Op_Divide)
and then Ada_Version = Ada_83
then
if It2.Nam = Predef_Subp then
return It2;
end if;
end if;
-
end Disambiguate;
---------------------
begin
if Is_Overloaded (R) then
Get_First_Interp (R, I, It);
-
while Present (It.Typ) loop
if Covers (T, It.Typ) or else Covers (It.Typ, T) then
Set_Etype (R, TR);
- -- In the non-overloaded case, the Etype of R is already set
- -- correctly.
+ -- In the non-overloaded case, the Etype of R is already set correctly
else
null;
end if;
Map_Ptr := Headers (Hash (O_N));
-
while Present (Interp_Map.Table (Map_Ptr).Node) loop
if Interp_Map.Table (Map_Ptr).Node = O_N then
Int_Ind := Interp_Map.Table (Map_Ptr).Index;
else
Get_First_Interp (N, I, It);
-
while Present (It.Typ) loop
if (Covers (Typ, It.Typ)
- and then
- (Scope (It.Nam) /= Standard_Standard
- or else not Is_Invisible_Operator (N, Base_Type (Typ))))
-
+ and then
+ (Scope (It.Nam) /= Standard_Standard
+ or else not Is_Invisible_Operator (N, Base_Type (Typ))))
or else (not Is_Tagged_Type (Typ)
- and then Ekind (Typ) /= E_Anonymous_Access_Type
- and then Covers (It.Typ, Typ))
+ and then Ekind (Typ) /= E_Anonymous_Access_Type
+ and then Covers (It.Typ, Typ))
then
return True;
end if;
else
Get_First_Interp (R, Index, It);
-
loop
T2 := Specific_Type (T, It.Typ);
else
Typ := Any_Type;
Get_First_Interp (L, Index, It);
-
while Present (It.Typ) loop
Typ := Check_Right_Argument (It.Typ);
exit when Typ /= Any_Type;
-- If Typ is Any_Type, it means no compatible pair of types was found
if Typ = Any_Type then
-
if Nkind (Parent (L)) in N_Op then
Error_Msg_N ("incompatible types for operator", Parent (L));
New_F := First_Formal (New_S);
Old_F := First_Formal (Op);
Num := 0;
-
while Present (New_F) and then Present (Old_F) loop
Num := Num + 1;
Next_Formal (New_F);
-- Find end of Interp list and copy downward to erase the discarded one
II := I + 1;
-
while Present (All_Interp.Table (II).Typ) loop
II := II + 1;
end loop;
with Nmake; use Nmake;
with Output; use Output;
with Opt; use Opt;
-with Restrict; use Restrict;
with Rtsfind; use Rtsfind;
with Scans; use Scans;
with Scn; use Scn;
procedure Check_Potentially_Blocking_Operation (N : Node_Id) is
S : Entity_Id;
- Loc : constant Source_Ptr := Sloc (N);
begin
- -- N is one of the potentially blocking operations listed in
- -- 9.5.1 (8). When using the Ravenscar profile, raise Program_Error
- -- before N if the context is a protected action. Otherwise, only issue
- -- a warning, since some users are relying on blocking operations
- -- inside protected objects.
- -- Indirect blocking through a subprogram call
- -- cannot be diagnosed statically without interprocedural analysis,
- -- so we do not attempt to do it here.
+ -- N is one of the potentially blocking operations listed in 9.5.1(8).
+ -- When pragma Detect_Blocking is active, the run time will raise
+ -- Program_Error. Here we only issue a warning, since we generally
+ -- support the use of potentially blocking operations in the absence
+ -- of the pragma.
- S := Scope (Current_Scope);
+ -- Indirect blocking through a subprogram call cannot be diagnosed
+ -- statically without interprocedural analysis, so we do not attempt
+ -- to do it here.
+ S := Scope (Current_Scope);
while Present (S) and then S /= Standard_Standard loop
if Is_Protected_Type (S) then
- if Restricted_Profile then
- Insert_Before_And_Analyze (N,
- Make_Raise_Program_Error (Loc,
- Reason => PE_Potentially_Blocking_Operation));
- Error_Msg_N ("potentially blocking operation, " &
- " Program Error will be raised at run time?", N);
-
- else
- Error_Msg_N
- ("potentially blocking operation in protected operation?", N);
- end if;
+ Error_Msg_N
+ ("potentially blocking operation in protected operation?", N);
return;
end if;
-- scope because the back end otherwise tries to allocate a
-- variable length temporary for the particular variant.
- -- ??? With tree-ssa, the back-end does not (yet) support these
- -- types either, so disable this optimization for now.
-
- if Has_Discriminants (Typ) then
+ if Opt.GCC_Version = 2
+ and then Has_Discriminants (Typ)
+ then
return True;
-- For GCC 3, or for a non-discriminated record in GCC 2, we are
procedure Check_Potentially_Blocking_Operation (N : Node_Id);
-- N is one of the statement forms that is a potentially blocking
- -- operation. If it appears within a protected action, emit warning
- -- and raise Program_Error.
+ -- operation. If it appears within a protected action, emit warning.
procedure Check_VMS (Construct : Node_Id);
-- Check that this the target is OpenVMS, and if so, return with
if (attribute == Attr_Max_Size_In_Storage_Elements)
gnu_result = convert (sizetype,
- fold (build (CEIL_DIV_EXPR, bitsizetype,
- gnu_result, bitsize_unit_node)));
+ fold (build2 (CEIL_DIV_EXPR, bitsizetype,
+ gnu_result, bitsize_unit_node)));
break;
case Attr_Alignment:
example in AARM 11.6(5.e). */
if (prefix_unused && TREE_SIDE_EFFECTS (gnu_prefix)
&& !Is_Entity_Name (Prefix (gnat_node)))
- gnu_result = fold (build (COMPOUND_EXPR, TREE_TYPE (gnu_result),
- gnu_prefix, gnu_result));
+ gnu_result = fold (build2 (COMPOUND_EXPR, TREE_TYPE (gnu_result),
+ gnu_prefix, gnu_result));
*gnu_result_type_p = gnu_result_type;
return gnu_result;
abort ();
}
- add_stmt_with_node (build (CASE_LABEL_EXPR, void_type_node,
- gnu_low, gnu_high,
- create_artificial_label ()),
+ add_stmt_with_node (build3 (CASE_LABEL_EXPR, void_type_node,
+ gnu_low, gnu_high,
+ create_artificial_label ()),
gnat_choice);
}
/* Now emit a definition of the label all the cases branched to. */
add_stmt (build1 (LABEL_EXPR, void_type_node,
TREE_VALUE (gnu_switch_label_stack)));
- gnu_result = build (SWITCH_EXPR, TREE_TYPE (gnu_expr), gnu_expr,
- end_stmt_group (), NULL_TREE);
+ gnu_result = build3 (SWITCH_EXPR, TREE_TYPE (gnu_expr), gnu_expr,
+ end_stmt_group (), NULL_TREE);
pop_stack (&gnu_switch_label_stack);
return gnu_result;
|| tree_int_cst_equal (gnu_last, gnu_limit))
{
gnu_cond_expr
- = build (COND_EXPR, void_type_node,
- build_binary_op (LE_EXPR, integer_type_node,
- gnu_low, gnu_high),
- NULL_TREE, alloc_stmt_list ());
+ = build3 (COND_EXPR, void_type_node,
+ build_binary_op (LE_EXPR, integer_type_node,
+ gnu_low, gnu_high),
+ NULL_TREE, alloc_stmt_list ());
annotate_with_node (gnu_cond_expr, gnat_loop_spec);
}
add_stmt_with_node
(build1 (RETURN_EXPR, void_type_node,
- build (MODIFY_EXPR, TREE_TYPE (gnu_retval),
- DECL_RESULT (current_function_decl), gnu_retval)),
+ build2 (MODIFY_EXPR, TREE_TYPE (gnu_retval),
+ DECL_RESULT (current_function_decl), gnu_retval)),
gnat_node);
gnat_poplevel ();
gnu_result = end_stmt_group ();
\f
/* Subroutine of gnat_to_gnu to translate gnat_node, either an N_Function_Call
or an N_Procedure_Call_Statement, to a GCC tree, which is returned.
- GNU_RESULT_TYPE_P is a pointer to where we should place the result type. */
+ GNU_RESULT_TYPE_P is a pointer to where we should place the result type.
+ If GNU_TARGET is non-null, this must be a function call and the result
+ of the call is to be placed into that object. */
static tree
-call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p)
+call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target)
{
tree gnu_result;
/* The GCC node corresponding to the GNAT subprogram name. This can either
gnat_actual = Next_Actual (gnat_actual))
add_stmt (gnat_to_gnu (gnat_actual));
- if (Nkind (gnat_node) == N_Function_Call)
+ if (Nkind (gnat_node) == N_Function_Call && !gnu_target)
{
*gnu_result_type_p = TREE_TYPE (gnu_subprog_type);
return build1 (NULL_EXPR, *gnu_result_type_p,
return build_call_raise (PE_Stubbed_Subprogram_Called);
}
+ /* If we are calling by supplying a pointer to a target, set up that
+ pointer as the first argument. Use GNU_TARGET if one was passed;
+ otherwise, make a target by building a variable of the maximum size
+ of the type. */
+ if (TYPE_RETURNS_BY_TARGET_PTR_P (gnu_subprog_type))
+ {
+ tree gnu_real_ret_type
+ = TREE_TYPE (TREE_VALUE (TYPE_ARG_TYPES (gnu_subprog_type)));
+
+ if (!gnu_target)
+ {
+ tree gnu_obj_type
+ = maybe_pad_type (gnu_real_ret_type,
+ max_size (TYPE_SIZE (gnu_real_ret_type), true),
+ 0, Etype (Name (gnat_node)), "PAD", false,
+ false, false);
+
+ gnu_target = create_tmp_var_raw (gnu_obj_type, "LR");
+ gnat_pushdecl (gnu_target, gnat_node);
+ }
+
+ gnu_actual_list
+ = tree_cons (NULL_TREE,
+ build_unary_op (ADDR_EXPR, NULL_TREE,
+ unchecked_convert (gnu_real_ret_type,
+ gnu_target,
+ false)),
+ NULL_TREE);
+
+ }
+
/* The only way we can be making a call via an access type is if Name is an
explicit dereference. In that case, get the list of formal args from the
type the access type is pointing to. Otherwise, get the formals from
}
/* Set up to move the copy back to the original. */
- gnu_temp = build (MODIFY_EXPR, TREE_TYPE (gnu_copy),
- gnu_copy, gnu_actual);
+ gnu_temp = build2 (MODIFY_EXPR, TREE_TYPE (gnu_copy),
+ gnu_copy, gnu_actual);
annotate_with_node (gnu_temp, gnat_actual);
append_to_statement_list (gnu_temp, &gnu_after_list);
}
gnu_actual_list = tree_cons (NULL_TREE, gnu_actual, gnu_actual_list);
}
- gnu_subprog_call = build (CALL_EXPR, TREE_TYPE (gnu_subprog_type),
- gnu_subprog_addr, nreverse (gnu_actual_list),
- NULL_TREE);
+ gnu_subprog_call = build3 (CALL_EXPR, TREE_TYPE (gnu_subprog_type),
+ gnu_subprog_addr, nreverse (gnu_actual_list),
+ NULL_TREE);
- /* If it is a function call, the result is the call expression. */
- if (Nkind (gnat_node) == N_Function_Call)
+ /* If we return by passing a target, we emit the call and return the target
+ as our result. */
+ if (TYPE_RETURNS_BY_TARGET_PTR_P (gnu_subprog_type))
+ {
+ add_stmt_with_node (gnu_subprog_call, gnat_node);
+ *gnu_result_type_p
+ = TREE_TYPE (TREE_VALUE (TYPE_ARG_TYPES (gnu_subprog_type)));
+ return unchecked_convert (*gnu_result_type_p, gnu_target, false);
+ }
+
+ /* If it is a function call, the result is the call expression unless
+ a target is specified, in which case we copy the result into the target
+ and return the assignment statement. */
+ else if (Nkind (gnat_node) == N_Function_Call)
{
gnu_result = gnu_subprog_call;
|| TYPE_RETURNS_BY_REF_P (gnu_subprog_type))
gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result);
- *gnu_result_type_p = get_unpadded_type (Etype (gnat_node));
+ if (gnu_target)
+ gnu_result = build_binary_op (MODIFY_EXPR, NULL_TREE,
+ gnu_target, gnu_result);
+ else
+ *gnu_result_type_p = get_unpadded_type (Etype (gnat_node));
+
return gnu_result;
}
gnu_handler = end_stmt_group ();
/* This block is now "if (setjmp) ... <handlers> else <block>". */
- gnu_result = build (COND_EXPR, void_type_node,
- (build_call_1_expr
- (setjmp_decl,
- build_unary_op (ADDR_EXPR, NULL_TREE,
- gnu_jmpbuf_decl))),
- gnu_handler, gnu_inner_block);
+ gnu_result = build3 (COND_EXPR, void_type_node,
+ (build_call_1_expr
+ (setjmp_decl,
+ build_unary_op (ADDR_EXPR, NULL_TREE,
+ gnu_jmpbuf_decl))),
+ gnu_handler, gnu_inner_block);
}
else if (gcc_zcx)
{
gnu_handlers = end_stmt_group ();
/* Now make the TRY_CATCH_EXPR for the block. */
- gnu_result = build (TRY_CATCH_EXPR, void_type_node,
- gnu_inner_block, gnu_handlers);
+ gnu_result = build2 (TRY_CATCH_EXPR, void_type_node,
+ gnu_inner_block, gnu_handlers);
}
else
gnu_result = gnu_inner_block;
gnu_choice, this_choice);
}
- return build (COND_EXPR, void_type_node, gnu_choice, gnu_body, NULL_TREE);
+ return build3 (COND_EXPR, void_type_node, gnu_choice, gnu_body, NULL_TREE);
}
\f
/* Subroutine of gnat_to_gnu to translate gnat_node, an N_Exception_Handler,
We use a local variable to retrieve the incoming value at handler entry
time, and reuse it to feed the end_handler hook's argument at exit. */
- gnu_current_exc_ptr = build (EXC_PTR_EXPR, ptr_type_node);
+ gnu_current_exc_ptr = build0 (EXC_PTR_EXPR, ptr_type_node);
gnu_incoming_exc_ptr = create_var_decl (get_identifier ("EXPTR"), NULL_TREE,
ptr_type_node, gnu_current_exc_ptr,
false, false, false, false, NULL,
add_stmt_list (Statements (gnat_node));
gnat_poplevel ();
- return build (CATCH_EXPR, void_type_node, gnu_etypes_list,
- end_stmt_group ());
+ return build2 (CATCH_EXPR, void_type_node, gnu_etypes_list,
+ end_stmt_group ());
}
\f
/* Subroutine of gnat_to_gnu to generate code for an N_Compilation unit. */
expression if the slice range is not null (max >= min) or
returns the min if the slice range is null */
gnu_expr
- = fold (build (COND_EXPR, gnu_expr_type,
- build_binary_op (GE_EXPR, gnu_expr_type,
- convert (gnu_expr_type,
- gnu_max_expr),
- convert (gnu_expr_type,
- gnu_min_expr)),
- gnu_expr, gnu_min_expr));
+ = fold (build3 (COND_EXPR, gnu_expr_type,
+ build_binary_op (GE_EXPR, gnu_expr_type,
+ convert (gnu_expr_type,
+ gnu_max_expr),
+ convert (gnu_expr_type,
+ gnu_min_expr)),
+ gnu_expr, gnu_min_expr));
}
else
gnu_expr = TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_result_type));
case N_Assignment_Statement:
/* Get the LHS and RHS of the statement and convert any reference to an
- unconstrained array into a reference to the underlying array. */
+ unconstrained array into a reference to the underlying array.
+ If we are not to do range checking and the RHS is an N_Function_Call,
+ pass the LHS to the call function. */
gnu_lhs = maybe_unconstrained_array (gnat_to_gnu (Name (gnat_node)));
- gnu_rhs
- = maybe_unconstrained_array (gnat_to_gnu (Expression (gnat_node)));
-
- /* If range check is needed, emit code to generate it */
- if (Do_Range_Check (Expression (gnat_node)))
- gnu_rhs = emit_range_check (gnu_rhs, Etype (Name (gnat_node)));
- /* If either side's type has a size that overflows, convert this
- into raise of Storage_Error: execution shouldn't have gotten
- here anyway. */
- if ((TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_lhs))) == INTEGER_CST
+ /* If the type has a size that overflows, convert this into raise of
+ Storage_Error: execution shouldn't have gotten here anyway. */
+ if (TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_lhs))) == INTEGER_CST
&& TREE_OVERFLOW (TYPE_SIZE (TREE_TYPE (gnu_lhs))))
- || (TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_rhs))) == INTEGER_CST
- && TREE_OVERFLOW (TYPE_SIZE (TREE_TYPE (gnu_rhs)))))
gnu_result = build_call_raise (SE_Object_Too_Large);
+ else if (Nkind (Expression (gnat_node)) == N_Function_Call
+ && !Do_Range_Check (Expression (gnat_node)))
+ gnu_result = call_to_gnu (Expression (gnat_node),
+ &gnu_result_type, gnu_lhs);
else
- gnu_result
- = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_lhs, gnu_rhs);
+ {
+ gnu_rhs
+ = maybe_unconstrained_array (gnat_to_gnu (Expression (gnat_node)));
+
+ /* If range check is needed, emit code to generate it */
+ if (Do_Range_Check (Expression (gnat_node)))
+ gnu_rhs = emit_range_check (gnu_rhs, Etype (Name (gnat_node)));
+
+ gnu_result
+ = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_lhs, gnu_rhs);
+ }
break;
case N_If_Statement:
tree *gnu_else_ptr; /* Point to put next "else if" or "else". */
/* Make the outer COND_EXPR. Avoid non-determinism. */
- gnu_result = build (COND_EXPR, void_type_node,
- gnat_to_gnu (Condition (gnat_node)),
- NULL_TREE, NULL_TREE);
+ gnu_result = build3 (COND_EXPR, void_type_node,
+ gnat_to_gnu (Condition (gnat_node)),
+ NULL_TREE, NULL_TREE);
COND_EXPR_THEN (gnu_result)
= build_stmt_group (Then_Statements (gnat_node), false);
TREE_SIDE_EFFECTS (gnu_result) = 1;
for (gnat_temp = First (Elsif_Parts (gnat_node));
Present (gnat_temp); gnat_temp = Next (gnat_temp))
{
- gnu_expr = build (COND_EXPR, void_type_node,
- gnat_to_gnu (Condition (gnat_temp)),
- NULL_TREE, NULL_TREE);
+ gnu_expr = build3 (COND_EXPR, void_type_node,
+ gnat_to_gnu (Condition (gnat_temp)),
+ NULL_TREE, NULL_TREE);
COND_EXPR_THEN (gnu_expr)
= build_stmt_group (Then_Statements (gnat_temp), false);
TREE_SIDE_EFFECTS (gnu_expr) = 1;
case N_Exit_Statement:
gnu_result
- = build (EXIT_STMT, void_type_node,
- (Present (Condition (gnat_node))
- ? gnat_to_gnu (Condition (gnat_node)) : NULL_TREE),
- (Present (Name (gnat_node))
- ? get_gnu_tree (Entity (Name (gnat_node)))
- : TREE_VALUE (gnu_loop_label_stack)));
+ = build2 (EXIT_STMT, void_type_node,
+ (Present (Condition (gnat_node))
+ ? gnat_to_gnu (Condition (gnat_node)) : NULL_TREE),
+ (Present (Name (gnat_node))
+ ? get_gnu_tree (Entity (Name (gnat_node)))
+ : TREE_VALUE (gnu_loop_label_stack)));
break;
case N_Return_Statement:
/* The gnu function type of the subprogram currently processed. */
tree gnu_subprog_type = TREE_TYPE (current_function_decl);
/* The return value from the subprogram. */
- tree gnu_ret_val = 0;
+ tree gnu_ret_val = NULL_TREE;
+ /* The place to put the return value. */
+ tree gnu_lhs
+ = (TYPE_RETURNS_BY_TARGET_PTR_P (gnu_subprog_type)
+ ? build_unary_op (INDIRECT_REF, NULL_TREE,
+ DECL_ARGUMENTS (current_function_decl))
+ : DECL_RESULT (current_function_decl));
/* If we are dealing with a "return;" from an Ada procedure with
parameters passed by copy in copy out, we need to return a record
else if (Present (Expression (gnat_node)))
{
- gnu_ret_val = gnat_to_gnu (Expression (gnat_node));
-
- /* Do not remove the padding from GNU_RET_VAL if the inner
- type is self-referential since we want to allocate the fixed
- size in that case. */
- if (TREE_CODE (gnu_ret_val) == COMPONENT_REF
- && (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_ret_val, 0)))
- == RECORD_TYPE)
- && (TYPE_IS_PADDING_P
- (TREE_TYPE (TREE_OPERAND (gnu_ret_val, 0))))
- && (CONTAINS_PLACEHOLDER_P
- (TYPE_SIZE (TREE_TYPE (gnu_ret_val)))))
- gnu_ret_val = TREE_OPERAND (gnu_ret_val, 0);
-
- if (TYPE_RETURNS_BY_REF_P (gnu_subprog_type)
- || By_Ref (gnat_node))
- gnu_ret_val = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_ret_val);
-
- else if (TYPE_RETURNS_UNCONSTRAINED_P (gnu_subprog_type))
+ /* If the current function returns by target pointer and we
+ are doing a call, pass that target to the call. */
+ if (TYPE_RETURNS_BY_TARGET_PTR_P (gnu_subprog_type)
+ && Nkind (Expression (gnat_node)) == N_Function_Call)
+ gnu_result = call_to_gnu (Expression (gnat_node),
+ &gnu_result_type, gnu_lhs);
+
+ else
{
- gnu_ret_val = maybe_unconstrained_array (gnu_ret_val);
-
- /* We have two cases: either the function returns with
- depressed stack or not. If not, we allocate on the
- secondary stack. If so, we allocate in the stack frame.
- if no copy is needed, the front end will set By_Ref,
- which we handle in the case above. */
- if (TYPE_RETURNS_STACK_DEPRESSED (gnu_subprog_type))
- gnu_ret_val
- = build_allocator (TREE_TYPE (gnu_ret_val), gnu_ret_val,
- TREE_TYPE (gnu_subprog_type), 0, -1,
- gnat_node);
- else
+ gnu_ret_val = gnat_to_gnu (Expression (gnat_node));
+
+ /* Do not remove the padding from GNU_RET_VAL if the inner
+ type is self-referential since we want to allocate the fixed
+ size in that case. */
+ if (TREE_CODE (gnu_ret_val) == COMPONENT_REF
+ && (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_ret_val, 0)))
+ == RECORD_TYPE)
+ && (TYPE_IS_PADDING_P
+ (TREE_TYPE (TREE_OPERAND (gnu_ret_val, 0))))
+ && (CONTAINS_PLACEHOLDER_P
+ (TYPE_SIZE (TREE_TYPE (gnu_ret_val)))))
+ gnu_ret_val = TREE_OPERAND (gnu_ret_val, 0);
+
+ if (TYPE_RETURNS_BY_REF_P (gnu_subprog_type)
+ || By_Ref (gnat_node))
gnu_ret_val
- = build_allocator (TREE_TYPE (gnu_ret_val), gnu_ret_val,
- TREE_TYPE (gnu_subprog_type),
- Procedure_To_Call (gnat_node),
- Storage_Pool (gnat_node), gnat_node);
+ = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_ret_val);
+
+ else if (TYPE_RETURNS_UNCONSTRAINED_P (gnu_subprog_type))
+ {
+ gnu_ret_val = maybe_unconstrained_array (gnu_ret_val);
+
+ /* We have two cases: either the function returns with
+ depressed stack or not. If not, we allocate on the
+ secondary stack. If so, we allocate in the stack frame.
+ if no copy is needed, the front end will set By_Ref,
+ which we handle in the case above. */
+ if (TYPE_RETURNS_STACK_DEPRESSED (gnu_subprog_type))
+ gnu_ret_val
+ = build_allocator (TREE_TYPE (gnu_ret_val),
+ gnu_ret_val,
+ TREE_TYPE (gnu_subprog_type),
+ 0, -1, gnat_node);
+ else
+ gnu_ret_val
+ = build_allocator (TREE_TYPE (gnu_ret_val),
+ gnu_ret_val,
+ TREE_TYPE (gnu_subprog_type),
+ Procedure_To_Call (gnat_node),
+ Storage_Pool (gnat_node),
+ gnat_node);
+ }
+ }
+
+ gnu_result = build2 (MODIFY_EXPR, TREE_TYPE (gnu_ret_val),
+ gnu_lhs, gnu_ret_val);
+ if (TYPE_RETURNS_BY_TARGET_PTR_P (gnu_subprog_type))
+ {
+ add_stmt_with_node (gnu_result, gnat_node);
+ gnu_ret_val = NULL_TREE;
}
}
gnu_result = build1 (RETURN_EXPR, void_type_node,
- (gnu_ret_val
- ? build (MODIFY_EXPR, TREE_TYPE (gnu_ret_val),
- DECL_RESULT (current_function_decl),
- gnu_ret_val)
- : NULL_TREE));
+ gnu_ret_val ? gnu_result : gnu_ret_val);
}
break;
case N_Function_Call:
case N_Procedure_Call_Statement:
- gnu_result = call_to_gnu (gnat_node, &gnu_result_type);
+ gnu_result = call_to_gnu (gnat_node, &gnu_result_type, NULL_TREE);
break;
/*************************/
gnu_input_list = nreverse (gnu_input_list);
gnu_output_list = nreverse (gnu_output_list);
- gnu_result = build (ASM_EXPR, void_type_node,
- gnu_template, gnu_output_list,
- gnu_input_list, gnu_clobber_list);
+ gnu_result = build4 (ASM_EXPR, void_type_node,
+ gnu_template, gnu_output_list,
+ gnu_input_list, gnu_clobber_list);
ASM_VOLATILE_P (gnu_result) = Is_Asm_Volatile (gnat_node);
}
else
annotate_with_node (gnu_result, gnat_node);
if (Present (Condition (gnat_node)))
- gnu_result = build (COND_EXPR, void_type_node,
- gnat_to_gnu (Condition (gnat_node)),
- gnu_result, alloc_stmt_list ());
+ gnu_result = build3 (COND_EXPR, void_type_node,
+ gnat_to_gnu (Condition (gnat_node)),
+ gnu_result, alloc_stmt_list ());
}
else
gnu_result = build1 (NULL_EXPR, gnu_result_type, gnu_result);
static void
record_code_position (Node_Id gnat_node)
{
- tree stmt_stmt = build (STMT_STMT, void_type_node, NULL_TREE);
+ tree stmt_stmt = build1 (STMT_STMT, void_type_node, NULL_TREE);
add_stmt_with_node (stmt_stmt, gnat_node);
save_gnu_tree (gnat_node, stmt_stmt, true);
this decl since we already have evaluated the expressions in the
sizes and positions as globals and doing it again would be wrong.
But we do have to mark everything as used. */
- gnu_stmt = build (DECL_EXPR, void_type_node, gnu_decl);
+ gnu_stmt = build1 (DECL_EXPR, void_type_node, gnu_decl);
if (!global_bindings_p ())
add_stmt_with_node (gnu_stmt, gnat_entity);
else
gnu_retval = alloc_stmt_list ();
if (group->cleanups)
- gnu_retval = build (TRY_FINALLY_EXPR, void_type_node, gnu_retval,
- group->cleanups);
+ gnu_retval = build2 (TRY_FINALLY_EXPR, void_type_node, gnu_retval,
+ group->cleanups);
if (current_stmt_group->block)
- gnu_retval = build (BIND_EXPR, void_type_node, BLOCK_VARS (group->block),
- gnu_retval, group->block);
+ gnu_retval = build3 (BIND_EXPR, void_type_node, BLOCK_VARS (group->block),
+ gnu_retval, group->block);
/* Remove this group from the stack and add it to the free list. */
current_stmt_group = group->previous;
*expr_p = TREE_OPERAND (*expr_p, 0);
return GS_OK;
+ case ADDR_EXPR:
+ /* If we're taking the address of a constant CONSTRUCTOR, force it to
+ be put into static memory. We know it's going to be readonly given
+ the semantics we have and it's required to be static memory in
+ the case when the reference is in an elaboration procedure. */
+ if (TREE_CODE (TREE_OPERAND (expr, 0)) == CONSTRUCTOR
+ && TREE_CONSTANT (TREE_OPERAND (expr, 0)))
+ {
+ tree new_var
+ = create_tmp_var (TREE_TYPE (TREE_OPERAND (expr, 0)), "C");
+
+ TREE_READONLY (new_var) = 1;
+ TREE_STATIC (new_var) = 1;
+ TREE_ADDRESSABLE (new_var) = 1;
+
+ gimplify_and_add (build2 (MODIFY_EXPR, TREE_TYPE (new_var),
+ new_var, TREE_OPERAND (expr, 0)),
+ pre_p);
+
+ TREE_OPERAND (expr, 0) = new_var;
+ return GS_ALL_DONE;
+ }
+ return GS_UNHANDLED;
+
case COMPONENT_REF:
- /* We have a kludge here. If the FIELD_DECL is from a fat pointer
- and is from an early dummy type, replace it with the proper
- FIELD_DECL. */
+ /* We have a kludge here. If the FIELD_DECL is from a fat pointer and is
+ from an early dummy type, replace it with the proper FIELD_DECL. */
if (TYPE_FAT_POINTER_P (TREE_TYPE (TREE_OPERAND (*expr_p, 0)))
&& DECL_ORIGINAL_FIELD (TREE_OPERAND (*expr_p, 1)))
{
stmt_p);
if (LOOP_STMT_TOP_COND (stmt))
- append_to_statement_list (build (COND_EXPR, void_type_node,
- LOOP_STMT_TOP_COND (stmt),
- alloc_stmt_list (),
- build1 (GOTO_EXPR,
- void_type_node,
- gnu_end_label)),
+ append_to_statement_list (build3 (COND_EXPR, void_type_node,
+ LOOP_STMT_TOP_COND (stmt),
+ alloc_stmt_list (),
+ build1 (GOTO_EXPR,
+ void_type_node,
+ gnu_end_label)),
stmt_p);
append_to_statement_list (LOOP_STMT_BODY (stmt), stmt_p);
if (LOOP_STMT_BOT_COND (stmt))
- append_to_statement_list (build (COND_EXPR, void_type_node,
- LOOP_STMT_BOT_COND (stmt),
- alloc_stmt_list (),
- build1 (GOTO_EXPR,
- void_type_node,
- gnu_end_label)),
+ append_to_statement_list (build3 (COND_EXPR, void_type_node,
+ LOOP_STMT_BOT_COND (stmt),
+ alloc_stmt_list (),
+ build1 (GOTO_EXPR,
+ void_type_node,
+ gnu_end_label)),
stmt_p);
if (LOOP_STMT_UPDATE (stmt))
see if it needs to be conditional. */
*stmt_p = build1 (GOTO_EXPR, void_type_node, EXIT_STMT_LABEL (stmt));
if (EXIT_STMT_COND (stmt))
- *stmt_p = build (COND_EXPR, void_type_node,
- EXIT_STMT_COND (stmt), *stmt_p, alloc_stmt_list ());
+ *stmt_p = build3 (COND_EXPR, void_type_node,
+ EXIT_STMT_COND (stmt), *stmt_p, alloc_stmt_list ());
return GS_OK;
default:
in front of the comparison in case it ends up being a SAVE_EXPR. Put the
whole thing inside its own SAVE_EXPR so the inner SAVE_EXPR doesn't leak
out. */
- gnu_result = fold (build (COND_EXPR, TREE_TYPE (gnu_expr), gnu_cond,
- build (COMPOUND_EXPR, TREE_TYPE (gnu_expr),
- gnu_call, gnu_expr),
- gnu_expr));
+ gnu_result = fold (build3 (COND_EXPR, TREE_TYPE (gnu_expr), gnu_cond,
+ build2 (COMPOUND_EXPR, TREE_TYPE (gnu_expr),
+ gnu_call, gnu_expr),
+ gnu_expr));
/* If GNU_EXPR has side effects, make the outer COMPOUND_EXPR and
protect it. Otherwise, show GNU_RESULT has no side effects: we
don't need to evaluate it just for the check. */
if (TREE_SIDE_EFFECTS (gnu_expr))
gnu_result
- = build (COMPOUND_EXPR, TREE_TYPE (gnu_expr), gnu_expr, gnu_result);
+ = build2 (COMPOUND_EXPR, TREE_TYPE (gnu_expr), gnu_expr, gnu_result);
else
TREE_SIDE_EFFECTS (gnu_result) = 0;
tree gnu_minus_point_5 = build_real (gnu_in_basetype, dconstmp5);
tree gnu_zero = convert (gnu_in_basetype, integer_zero_node);
tree gnu_saved_result = save_expr (gnu_result);
- tree gnu_comp = build (GE_EXPR, integer_type_node,
- gnu_saved_result, gnu_zero);
- tree gnu_adjust = build (COND_EXPR, gnu_in_basetype, gnu_comp,
- gnu_point_5, gnu_minus_point_5);
+ tree gnu_comp = build2 (GE_EXPR, integer_type_node,
+ gnu_saved_result, gnu_zero);
+ tree gnu_adjust = build3 (COND_EXPR, gnu_in_basetype, gnu_comp,
+ gnu_point_5, gnu_minus_point_5);
gnu_result
- = build (PLUS_EXPR, gnu_in_basetype, gnu_saved_result, gnu_adjust);
+ = build2 (PLUS_EXPR, gnu_in_basetype, gnu_saved_result, gnu_adjust);
}
if (TREE_CODE (gnu_ada_base_type) == INTEGER_TYPE
break;
case COMPONENT_REF:
- result = build (COMPONENT_REF, type,
- gnat_stabilize_reference (TREE_OPERAND (ref, 0),
- force),
- TREE_OPERAND (ref, 1), NULL_TREE);
+ result = build3 (COMPONENT_REF, type,
+ gnat_stabilize_reference (TREE_OPERAND (ref, 0),
+ force),
+ TREE_OPERAND (ref, 1), NULL_TREE);
break;
case BIT_FIELD_REF:
- result = build (BIT_FIELD_REF, type,
- gnat_stabilize_reference (TREE_OPERAND (ref, 0), force),
- gnat_stabilize_reference_1 (TREE_OPERAND (ref, 1),
- force),
- gnat_stabilize_reference_1 (TREE_OPERAND (ref, 2),
- force));
+ result = build3 (BIT_FIELD_REF, type,
+ gnat_stabilize_reference (TREE_OPERAND (ref, 0), force),
+ gnat_stabilize_reference_1 (TREE_OPERAND (ref, 1),
+ force),
+ gnat_stabilize_reference_1 (TREE_OPERAND (ref, 2),
+ force));
break;
case ARRAY_REF:
case ARRAY_RANGE_REF:
- result = build (code, type,
- gnat_stabilize_reference (TREE_OPERAND (ref, 0), force),
- gnat_stabilize_reference_1 (TREE_OPERAND (ref, 1),
- force),
- NULL_TREE, NULL_TREE);
+ result = build4 (code, type,
+ gnat_stabilize_reference (TREE_OPERAND (ref, 0), force),
+ gnat_stabilize_reference_1 (TREE_OPERAND (ref, 1),
+ force),
+ NULL_TREE, NULL_TREE);
break;
case COMPOUND_EXPR:
- result = build (COMPOUND_EXPR, type,
- gnat_stabilize_reference_1 (TREE_OPERAND (ref, 0),
- force),
- gnat_stabilize_reference (TREE_OPERAND (ref, 1),
- force));
+ result = build2 (COMPOUND_EXPR, type,
+ gnat_stabilize_reference_1 (TREE_OPERAND (ref, 0),
+ force),
+ gnat_stabilize_reference (TREE_OPERAND (ref, 1),
+ force));
break;
/* If arg isn't a kind of lvalue we recognize, make no change.
us to more easily find the match for the PLACEHOLDER_EXPR. */
if (code == COMPONENT_REF
&& TYPE_FAT_POINTER_P (TREE_TYPE (TREE_OPERAND (e, 0))))
- result = build (COMPONENT_REF, type,
- gnat_stabilize_reference_1 (TREE_OPERAND (e, 0),
- force),
- TREE_OPERAND (e, 1), TREE_OPERAND (e, 2));
+ result = build3 (COMPONENT_REF, type,
+ gnat_stabilize_reference_1 (TREE_OPERAND (e, 0),
+ force),
+ TREE_OPERAND (e, 1), TREE_OPERAND (e, 2));
else if (TREE_SIDE_EFFECTS (e) || force)
return save_expr (e);
else
case '2':
/* Recursively stabilize each operand. */
- result = build (code, type,
- gnat_stabilize_reference_1 (TREE_OPERAND (e, 0), force),
- gnat_stabilize_reference_1 (TREE_OPERAND (e, 1), force));
+ result = build2 (code, type,
+ gnat_stabilize_reference_1 (TREE_OPERAND (e, 0), force),
+ gnat_stabilize_reference_1 (TREE_OPERAND (e, 1),
+ force));
break;
case '1':
case QUAL_UNION_TYPE:
ada_size
- = fold (build (COND_EXPR, bitsizetype, DECL_QUALIFIER (field),
- this_ada_size, ada_size));
- size = fold (build (COND_EXPR, bitsizetype, DECL_QUALIFIER (field),
- this_size, size));
- size_unit = fold (build (COND_EXPR, sizetype, DECL_QUALIFIER (field),
- this_size_unit, size_unit));
+ = fold (build3 (COND_EXPR, bitsizetype, DECL_QUALIFIER (field),
+ this_ada_size, ada_size));
+ size = fold (build3 (COND_EXPR, bitsizetype, DECL_QUALIFIER (field),
+ this_size, size));
+ size_unit = fold (build3 (COND_EXPR, sizetype,
+ DECL_QUALIFIER (field),
+ this_size_unit, size_unit));
break;
case RECORD_TYPE:
}
else
- new = fold (build (COND_EXPR, type, TREE_OPERAND (size, 0),
- integer_zerop (TREE_OPERAND (size, 1))
- ? last_size : merge_sizes (last_size, first_bit,
- TREE_OPERAND (size, 1),
- 1, has_rep),
- integer_zerop (TREE_OPERAND (size, 2))
- ? last_size : merge_sizes (last_size, first_bit,
- TREE_OPERAND (size, 2),
- 1, has_rep)));
+ new = fold (build3 (COND_EXPR, type, TREE_OPERAND (size, 0),
+ integer_zerop (TREE_OPERAND (size, 1))
+ ? last_size : merge_sizes (last_size, first_bit,
+ TREE_OPERAND (size, 1),
+ 1, has_rep),
+ integer_zerop (TREE_OPERAND (size, 2))
+ ? last_size : merge_sizes (last_size, first_bit,
+ TREE_OPERAND (size, 2),
+ 1, has_rep)));
/* We don't need any NON_VALUE_EXPRs and they can confuse us (especially
when fed through substitute_in_expr) into thinking that a constant
RETURNS_UNCONSTRAINED is nonzero if the function returns an unconstrained
object. RETURNS_BY_REF is nonzero if the function returns by reference.
RETURNS_WITH_DSP is nonzero if the function is to return with a
- depressed stack pointer. */
+ depressed stack pointer. RETURNS_BY_TARGET_PTR is true if the function
+ is to be passed (as its first parameter) the address of the place to copy
+ its result. */
tree
create_subprog_type (tree return_type, tree param_decl_list, tree cico_list,
bool returns_unconstrained, bool returns_by_ref,
- bool returns_with_dsp)
+ bool returns_with_dsp, bool returns_by_target_ptr)
{
/* A chain of TREE_LIST nodes whose TREE_VALUEs are the data type nodes of
the subprogram formal parameters. This list is generated by traversing the
RETURNS_UNCONSTRAINED and RETURNS_BY_REF. */
if (TYPE_CI_CO_LIST (type) || cico_list
|| TYPE_RETURNS_UNCONSTRAINED_P (type) != returns_unconstrained
- || TYPE_RETURNS_BY_REF_P (type) != returns_by_ref)
+ || TYPE_RETURNS_BY_REF_P (type) != returns_by_ref
+ || TYPE_RETURNS_BY_TARGET_PTR_P (type) != returns_by_target_ptr)
type = copy_type (type);
TYPE_CI_CO_LIST (type) = cico_list;
TYPE_RETURNS_UNCONSTRAINED_P (type) = returns_unconstrained;
TYPE_RETURNS_STACK_DEPRESSED (type) = returns_with_dsp;
TYPE_RETURNS_BY_REF_P (type) = returns_by_ref;
+ TYPE_RETURNS_BY_TARGET_PTR_P (type) = returns_by_target_ptr;
return type;
}
\f
TREE_THIS_VOLATILE (var_decl) = TREE_SIDE_EFFECTS (var_decl)
= TYPE_VOLATILE (type);
- /* At the global binding level we need to allocate static storage for the
- variable if and only if its not external. If we are not at the top level
+ /* If it's public and not external, always allocate storage for it.
+ At the global binding level we need to allocate static storage for the
+ variable if and only if it's not external. If we are not at the top level
we allocate automatic storage unless requested not to. */
- TREE_STATIC (var_decl) = global_bindings_p () ? !extern_flag : static_flag;
+ TREE_STATIC (var_decl)
+ = public_flag || (global_bindings_p () ? !extern_flag : static_flag);
if (asm_name)
SET_DECL_ASSEMBLER_NAME (var_decl, asm_name);
&& !TREE_CONSTANT (rhs))
return lhs;
else
- return fold (build (code, type, lhs, rhs));
+ return fold (build2 (code, type, lhs, rhs));
}
case 3:
if (code == SAVE_EXPR)
return exp;
else if (code == COND_EXPR)
- return fold (build (max_p ? MAX_EXPR : MIN_EXPR, type,
- max_size (TREE_OPERAND (exp, 1), max_p),
- max_size (TREE_OPERAND (exp, 2), max_p)));
+ return fold (build2 (max_p ? MAX_EXPR : MIN_EXPR, type,
+ max_size (TREE_OPERAND (exp, 1), max_p),
+ max_size (TREE_OPERAND (exp, 2), max_p)));
else if (code == CALL_EXPR && TREE_OPERAND (exp, 1))
- return build (CALL_EXPR, type, TREE_OPERAND (exp, 0),
- max_size (TREE_OPERAND (exp, 1), max_p), NULL);
+ return build3 (CALL_EXPR, type, TREE_OPERAND (exp, 0),
+ max_size (TREE_OPERAND (exp, 1), max_p), NULL);
}
}
build_pointer_type_for_mode (type, SImode, false), record_type,
build1 (ADDR_EXPR,
build_pointer_type_for_mode (type, SImode, false),
- build (PLACEHOLDER_EXPR, type))));
+ build0 (PLACEHOLDER_EXPR, type))));
switch (mech)
{
size_in_bytes (type)));
/* Now build a pointer to the 0,0,0... element. */
- tem = build (PLACEHOLDER_EXPR, type);
+ tem = build0 (PLACEHOLDER_EXPR, type);
for (i = 0, inner_type = type; i < ndim;
i++, inner_type = TREE_TYPE (inner_type))
- tem = build (ARRAY_REF, TREE_TYPE (inner_type), tem,
- convert (TYPE_DOMAIN (inner_type), size_zero_node),
- NULL_TREE, NULL_TREE);
+ tem = build4 (ARRAY_REF, TREE_TYPE (inner_type), tem,
+ convert (TYPE_DOMAIN (inner_type), size_zero_node),
+ NULL_TREE, NULL_TREE);
field_list
= chainon (field_list,
is now a very "heavy" routine to do this, so it should be replaced
at some point. */
ptr_temp_type = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (ptr)));
- new_ref = build (COMPONENT_REF, ptr_temp_type,
- build (PLACEHOLDER_EXPR, ptr),
- TREE_CHAIN (TYPE_FIELDS (ptr)), NULL_TREE);
+ new_ref = build3 (COMPONENT_REF, ptr_temp_type,
+ build0 (PLACEHOLDER_EXPR, ptr),
+ TREE_CHAIN (TYPE_FIELDS (ptr)), NULL_TREE);
update_pointer_to
(TREE_TYPE (TREE_TYPE (TYPE_FIELDS (ptr))),
/* If the input is a biased type, adjust first. */
if (ecode == INTEGER_TYPE && TYPE_BIASED_REPRESENTATION_P (etype))
- return convert (type, fold (build (PLUS_EXPR, TREE_TYPE (etype),
- fold (build1 (NOP_EXPR,
- TREE_TYPE (etype), expr)),
- TYPE_MIN_VALUE (etype))));
+ return convert (type, fold (build2 (PLUS_EXPR, TREE_TYPE (etype),
+ fold (build1 (NOP_EXPR,
+ TREE_TYPE (etype),
+ expr)),
+ TYPE_MIN_VALUE (etype))));
/* If the input is a left-justified modular type, we need to extract
the actual object before converting it to any other type with the
return unchecked_convert (type, expr, false);
else if (TYPE_BIASED_REPRESENTATION_P (type))
return fold (build1 (CONVERT_EXPR, type,
- fold (build (MINUS_EXPR, TREE_TYPE (type),
- convert (TREE_TYPE (type), expr),
- TYPE_MIN_VALUE (type)))));
+ fold (build2 (MINUS_EXPR, TREE_TYPE (type),
+ convert (TREE_TYPE (type), expr),
+ TYPE_MIN_VALUE (type)))));
/* ... fall through ... */
case COND_EXPR:
/* Distribute the conversion into the arms of a COND_EXPR. */
return fold
- (build (COND_EXPR, type, TREE_OPERAND (expr, 0),
- gnat_truthvalue_conversion (TREE_OPERAND (expr, 1)),
- gnat_truthvalue_conversion (TREE_OPERAND (expr, 2))));
+ (build3 (COND_EXPR, type, TREE_OPERAND (expr, 0),
+ gnat_truthvalue_conversion (TREE_OPERAND (expr, 1)),
+ gnat_truthvalue_conversion (TREE_OPERAND (expr, 2))));
default:
return build_binary_op (NE_EXPR, type, expr,
tree lb2 = TYPE_MIN_VALUE (TYPE_DOMAIN (t2));
tree ub2 = TYPE_MAX_VALUE (TYPE_DOMAIN (t2));
tree bt = get_base_type (TREE_TYPE (lb1));
- tree length1 = fold (build (MINUS_EXPR, bt, ub1, lb1));
- tree length2 = fold (build (MINUS_EXPR, bt, ub2, lb2));
+ tree length1 = fold (build2 (MINUS_EXPR, bt, ub1, lb1));
+ tree length2 = fold (build2 (MINUS_EXPR, bt, ub2, lb2));
tree nbt;
tree tem;
tree comparison, this_a1_is_null, this_a2_is_null;
unless the length of the second array is the constant zero.
Note that we have set the `length' values to the length - 1. */
if (TREE_CODE (length1) == INTEGER_CST
- && !integer_zerop (fold (build (PLUS_EXPR, bt, length2,
- convert (bt, integer_one_node)))))
+ && !integer_zerop (fold (build2 (PLUS_EXPR, bt, length2,
+ convert (bt, integer_one_node)))))
{
tem = a1, a1 = a2, a2 = tem;
tem = t1, t1 = t2, t2 = tem;
/* If the length of this dimension in the second array is the constant
zero, we can just go inside the original bounds for the first
array and see if last < first. */
- if (integer_zerop (fold (build (PLUS_EXPR, bt, length2,
- convert (bt, integer_one_node)))))
+ if (integer_zerop (fold (build2 (PLUS_EXPR, bt, length2,
+ convert (bt, integer_one_node)))))
{
tree ub = TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t1)));
tree lb = TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t1)));
a1 = convert (type, a1), a2 = convert (type, a2);
result = build_binary_op (TRUTH_ANDIF_EXPR, result_type, result,
- fold (build (EQ_EXPR, result_type, a1, a2)));
+ fold (build2 (EQ_EXPR, result_type, a1, a2)));
}
evaluated would be wrong. */
if (contains_save_expr_p (a1))
- result = build (COMPOUND_EXPR, result_type, a1, result);
+ result = build2 (COMPOUND_EXPR, result_type, a1, result);
if (contains_save_expr_p (a2))
- result = build (COMPOUND_EXPR, result_type, a2, result);
+ result = build2 (COMPOUND_EXPR, result_type, a2, result);
return result;
}
/* If this is an addition of a constant, convert it to a subtraction
of a constant since we can do that faster. */
if (op_code == PLUS_EXPR && TREE_CODE (rhs) == INTEGER_CST)
- rhs = fold (build (MINUS_EXPR, type, modulus, rhs)), op_code = MINUS_EXPR;
+ rhs = fold (build2 (MINUS_EXPR, type, modulus, rhs)), op_code = MINUS_EXPR;
/* For the logical operations, we only need PRECISION bits. For
addition and subraction, we need one more and for multiplication we
}
/* Do the operation, then we'll fix it up. */
- result = fold (build (op_code, op_type, lhs, rhs));
+ result = fold (build2 (op_code, op_type, lhs, rhs));
/* For multiplication, we have no choice but to do a full modulus
operation. However, we want to do this in the narrowest
SET_TYPE_MODULUS (div_type, modulus);
TYPE_MODULAR_P (div_type) = 1;
result = convert (op_type,
- fold (build (TRUNC_MOD_EXPR, div_type,
- convert (div_type, result), modulus)));
+ fold (build2 (TRUNC_MOD_EXPR, div_type,
+ convert (div_type, result), modulus)));
}
/* For subtraction, add the modulus back if we are negative. */
else if (op_code == MINUS_EXPR)
{
result = save_expr (result);
- result = fold (build (COND_EXPR, op_type,
- build (LT_EXPR, integer_type_node, result,
- convert (op_type, integer_zero_node)),
- fold (build (PLUS_EXPR, op_type,
- result, modulus)),
- result));
+ result = fold (build3 (COND_EXPR, op_type,
+ build2 (LT_EXPR, integer_type_node, result,
+ convert (op_type, integer_zero_node)),
+ fold (build2 (PLUS_EXPR, op_type,
+ result, modulus)),
+ result));
}
/* For the other operations, subtract the modulus if we are >= it. */
else
{
result = save_expr (result);
- result = fold (build (COND_EXPR, op_type,
- build (GE_EXPR, integer_type_node,
- result, modulus),
- fold (build (MINUS_EXPR, op_type,
- result, modulus)),
- result));
+ result = fold (build3 (COND_EXPR, op_type,
+ build2 (GE_EXPR, integer_type_node,
+ result, modulus),
+ fold (build2 (MINUS_EXPR, op_type,
+ result, modulus)),
+ result));
}
return convert (type, result);
case NE_EXPR:
/* If either operand is a NULL_EXPR, just return a new one. */
if (TREE_CODE (left_operand) == NULL_EXPR)
- return build (op_code, result_type,
- build1 (NULL_EXPR, integer_type_node,
- TREE_OPERAND (left_operand, 0)),
- integer_zero_node);
+ return build2 (op_code, result_type,
+ build1 (NULL_EXPR, integer_type_node,
+ TREE_OPERAND (left_operand, 0)),
+ integer_zero_node);
else if (TREE_CODE (right_operand) == NULL_EXPR)
- return build (op_code, result_type,
- build1 (NULL_EXPR, integer_type_node,
- TREE_OPERAND (right_operand, 0)),
- integer_zero_node);
+ return build2 (op_code, result_type,
+ build1 (NULL_EXPR, integer_type_node,
+ TREE_OPERAND (right_operand, 0)),
+ integer_zero_node);
/* If either object is a left-justified modular types, get the
fields from within. */
else if (TREE_CODE (right_operand) == NULL_EXPR)
return build1 (NULL_EXPR, operation_type, TREE_OPERAND (right_operand, 0));
else if (op_code == ARRAY_REF || op_code == ARRAY_RANGE_REF)
- result = fold (build (op_code, operation_type, left_operand, right_operand,
- NULL_TREE, NULL_TREE));
+ result = fold (build4 (op_code, operation_type, left_operand,
+ right_operand, NULL_TREE, NULL_TREE));
else
result
- = fold (build (op_code, operation_type, left_operand, right_operand));
+ = fold (build2 (op_code, operation_type, left_operand, right_operand));
TREE_SIDE_EFFECTS (result) |= has_side_effects;
TREE_CONSTANT (result)
/* If we are working with modular types, perform the MOD operation
if something above hasn't eliminated the need for it. */
if (modulus)
- result = fold (build (FLOOR_MOD_EXPR, operation_type, result,
- convert (operation_type, modulus)));
+ result = fold (build2 (FLOOR_MOD_EXPR, operation_type, result,
+ convert (operation_type, modulus)));
if (result_type && result_type != operation_type)
result = convert (result_type, result);
the straightforward code; the TRUNC_MOD_EXPR below
is an AND operation. */
if (op_code == NEGATE_EXPR && mod_pow2)
- result = fold (build (TRUNC_MOD_EXPR, operation_type,
- fold (build1 (NEGATE_EXPR, operation_type,
- operand)),
- modulus));
+ result = fold (build2 (TRUNC_MOD_EXPR, operation_type,
+ fold (build1 (NEGATE_EXPR, operation_type,
+ operand)),
+ modulus));
/* For nonbinary negate case, return zero for zero operand,
else return the modulus minus the operand. If the modulus
as an XOR since it is equivalent and faster on most machines. */
else if (op_code == NEGATE_EXPR && !mod_pow2)
{
- if (integer_pow2p (fold (build (PLUS_EXPR, operation_type,
- modulus,
- convert (operation_type,
- integer_one_node)))))
- result = fold (build (BIT_XOR_EXPR, operation_type,
- operand, modulus));
+ if (integer_pow2p (fold (build2 (PLUS_EXPR, operation_type,
+ modulus,
+ convert (operation_type,
+ integer_one_node)))))
+ result = fold (build2 (BIT_XOR_EXPR, operation_type,
+ operand, modulus));
else
- result = fold (build (MINUS_EXPR, operation_type,
+ result = fold (build2 (MINUS_EXPR, operation_type,
modulus, operand));
- result = fold (build (COND_EXPR, operation_type,
- fold (build (NE_EXPR, integer_type_node,
- operand,
- convert (operation_type,
- integer_zero_node))),
- result, operand));
+ result = fold (build3 (COND_EXPR, operation_type,
+ fold (build2 (NE_EXPR,
+ integer_type_node,
+ operand,
+ convert
+ (operation_type,
+ integer_zero_node))),
+ result, operand));
}
else
{
XOR against the constant and subtract the operand from
that constant for nonbinary modulus. */
- tree cnst = fold (build (MINUS_EXPR, operation_type, modulus,
- convert (operation_type,
- integer_one_node)));
+ tree cnst = fold (build2 (MINUS_EXPR, operation_type, modulus,
+ convert (operation_type,
+ integer_one_node)));
if (mod_pow2)
- result = fold (build (BIT_XOR_EXPR, operation_type,
- operand, cnst));
+ result = fold (build2 (BIT_XOR_EXPR, operation_type,
+ operand, cnst));
else
- result = fold (build (MINUS_EXPR, operation_type,
- cnst, operand));
+ result = fold (build2 (MINUS_EXPR, operation_type,
+ cnst, operand));
}
break;
false_operand = build_unary_op (ADDR_EXPR, result_type, false_operand);
}
- result = fold (build (COND_EXPR, result_type, condition_operand,
- true_operand, false_operand));
+ result = fold (build3 (COND_EXPR, result_type, condition_operand,
+ true_operand, false_operand));
/* If either operand is a SAVE_EXPR (possibly surrounded by
arithmetic, make sure it gets done. */
false_operand = skip_simple_arithmetic (false_operand);
if (TREE_CODE (true_operand) == SAVE_EXPR)
- result = build (COMPOUND_EXPR, result_type, true_operand, result);
+ result = build2 (COMPOUND_EXPR, result_type, true_operand, result);
if (TREE_CODE (false_operand) == SAVE_EXPR)
- result = build (COMPOUND_EXPR, result_type, false_operand, result);
+ result = build2 (COMPOUND_EXPR, result_type, false_operand, result);
/* ??? Seems the code above is wrong, as it may move ahead of the COND
SAVE_EXPRs with side effects and not shared by both arms. */
tree
build_call_1_expr (tree fundecl, tree arg)
{
- tree call = build (CALL_EXPR, TREE_TYPE (TREE_TYPE (fundecl)),
- build_unary_op (ADDR_EXPR, NULL_TREE, fundecl),
- chainon (NULL_TREE, build_tree_list (NULL_TREE, arg)),
- NULL_TREE);
+ tree call = build3 (CALL_EXPR, TREE_TYPE (TREE_TYPE (fundecl)),
+ build_unary_op (ADDR_EXPR, NULL_TREE, fundecl),
+ chainon (NULL_TREE, build_tree_list (NULL_TREE, arg)),
+ NULL_TREE);
TREE_SIDE_EFFECTS (call) = 1;
tree
build_call_2_expr (tree fundecl, tree arg1, tree arg2)
{
- tree call = build (CALL_EXPR, TREE_TYPE (TREE_TYPE (fundecl)),
- build_unary_op (ADDR_EXPR, NULL_TREE, fundecl),
- chainon (chainon (NULL_TREE,
- build_tree_list (NULL_TREE, arg1)),
- build_tree_list (NULL_TREE, arg2)),
+ tree call = build3 (CALL_EXPR, TREE_TYPE (TREE_TYPE (fundecl)),
+ build_unary_op (ADDR_EXPR, NULL_TREE, fundecl),
+ chainon (chainon (NULL_TREE,
+ build_tree_list (NULL_TREE, arg1)),
+ build_tree_list (NULL_TREE, arg2)),
NULL_TREE);
TREE_SIDE_EFFECTS (call) = 1;
tree
build_call_0_expr (tree fundecl)
{
- tree call = build (CALL_EXPR, TREE_TYPE (TREE_TYPE (fundecl)),
- build_unary_op (ADDR_EXPR, NULL_TREE, fundecl),
- NULL_TREE, NULL_TREE);
+ tree call = build3 (CALL_EXPR, TREE_TYPE (TREE_TYPE (fundecl)),
+ build_unary_op (ADDR_EXPR, NULL_TREE, fundecl),
+ NULL_TREE, NULL_TREE);
TREE_SIDE_EFFECTS (call) = 1;
}
result = build_constructor (type, list);
- TREE_CONSTANT (result) = allconstant;
- TREE_STATIC (result) = allconstant;
+ TREE_CONSTANT (result) = TREE_INVARIANT (result)
+ = TREE_STATIC (result) = allconstant;
TREE_SIDE_EFFECTS (result) = side_effects;
- TREE_READONLY (result) = TYPE_READONLY (type);
-
+ TREE_READONLY (result) = TYPE_READONLY (type) || allconstant;
return result;
}
\f
/* It would be nice to call "fold" here, but that can lose a type
we need to tag a PLACEHOLDER_EXPR with, so we can't do it. */
- ref = build (COMPONENT_REF, TREE_TYPE (field), record_variable, field,
- NULL_TREE);
+ ref = build3 (COMPONENT_REF, TREE_TYPE (field), record_variable, field,
+ NULL_TREE);
if (TREE_READONLY (record_variable) || TREE_READONLY (field))
TREE_READONLY (ref) = 1;
build_tree_list (NULL_TREE,
convert (gnu_size_type, gnu_align)));
- gnu_call = build (CALL_EXPR, TREE_TYPE (TREE_TYPE (gnu_proc)),
- gnu_proc_addr, gnu_args, NULL_TREE);
+ gnu_call = build3 (CALL_EXPR, TREE_TYPE (TREE_TYPE (gnu_proc)),
+ gnu_proc_addr, gnu_args, NULL_TREE);
TREE_SIDE_EFFECTS (gnu_call) = 1;
return gnu_call;
}
build_tree_list (NULL_TREE,
convert (gnu_size_type, gnu_size)));
- gnu_call = build (CALL_EXPR, TREE_TYPE (TREE_TYPE (gnu_proc)),
- gnu_proc_addr, gnu_args, NULL_TREE);
+ gnu_call = build3 (CALL_EXPR, TREE_TYPE (TREE_TYPE (gnu_proc)),
+ gnu_proc_addr, gnu_args, NULL_TREE);
TREE_SIDE_EFFECTS (gnu_call) = 1;
return gnu_call;
}
else
abort ();
#if 0
- return build (ALLOCATE_EXPR, ptr_void_type_node, gnu_size, gnu_align);
+ return build2 (ALLOCATE_EXPR, ptr_void_type_node, gnu_size, gnu_align);
#endif
}
else
return convert
(result_type,
- build (COMPOUND_EXPR, storage_ptr_type,
- build_binary_op
- (MODIFY_EXPR, storage_type,
- build_unary_op (INDIRECT_REF, NULL_TREE,
- convert (storage_ptr_type, storage)),
- gnat_build_constructor (storage_type, template_cons)),
- convert (storage_ptr_type, storage)));
+ build2 (COMPOUND_EXPR, storage_ptr_type,
+ build_binary_op
+ (MODIFY_EXPR, storage_type,
+ build_unary_op (INDIRECT_REF, NULL_TREE,
+ convert (storage_ptr_type, storage)),
+ gnat_build_constructor (storage_type, template_cons)),
+ convert (storage_ptr_type, storage)));
}
else
- return build
+ return build2
(COMPOUND_EXPR, result_type,
build_binary_op
(MODIFY_EXPR, template_type,
{
result = save_expr (result);
result
- = build (COMPOUND_EXPR, TREE_TYPE (result),
- build_binary_op
- (MODIFY_EXPR, NULL_TREE,
- build_unary_op (INDIRECT_REF, TREE_TYPE (TREE_TYPE (result)),
- result),
- init),
- result);
+ = build2 (COMPOUND_EXPR, TREE_TYPE (result),
+ build_binary_op
+ (MODIFY_EXPR, NULL_TREE,
+ build_unary_op (INDIRECT_REF,
+ TREE_TYPE (TREE_TYPE (result)), result),
+ init),
+ result);
}
return convert (result_type, result);
projects / gcc.git / commitdiff