|
DataMuseum.dkPresents historical artifacts from the history of: Rational R1000/400 Tapes |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about Rational R1000/400 Tapes Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - downloadIndex: ┃ B T ┃
Length: 40739 (0x9f23)
Types: TextFile
Names: »B«
└─⟦516dceb10⟧ Bits:30000751 8mm tape, Rational 1000, RCI_VADS
└─ ⟦9a14c9417⟧ »DATA«
└─⟦this⟧
with Log;
with Product_Authorization;
with Profile;
with String_Utilities;
with Universal;
package body Rcf_Semantics is
package Checking renames Sc.Checking;
package Su renames String_Utilities;
package Text renames Sc.Text;
This_Target : constant String := "Sparc_Sun_Xt";
T_Name : constant String := "Sparc_Sun_Xt";
Supported_Targets : array (1 .. 7) of String (1 .. 16) :=
(1 => "Rs6000_Aix_Ibm ",
2 => "Vax_Vms_Dec_Xt ",
3 => "I386_Lynx_Als_Xt",
4 => "I486_Iux_Als_Xt ",
5 => "I960_Vms_Tar_Xt ",
6 => "IC30_Vms_Tar_Xt ",
7 => "Sparc_Sun_Xt ");
-- Table containing all valid target keys
function Is_Authorized (Target_Key_Name : String) return Boolean is
begin
for I in Supported_Targets'First .. Supported_Targets'Last loop
if Su.Equal (Str1 => Su.Strip (Target_Key_Name),
Str2 => Su.Strip (Supported_Targets (I)),
Ignore_Case => True) then
return Product_Authorization.Is_Registered (Target_Key_Name);
end if;
end loop;
return True;
end Is_Authorized;
function Get_Attribute_Info
(Target_Key_Name : String) return Attributes.Object is
package Attr renames Attributes;
-- GENERAL NOTES PERTAINING TO ATTRIBUTES DEFINED HERE
--
-- There are three "implementation dependant" attributes documented in
-- the Appendix F found in the "Sun Ada 1.0 for Sun4 SunOS 4.x"
-- Programmer's Guide. These include:
--
-- X'Address,
-- X'Ref and System.Address'Ref(N), and
-- X'Task_Id
--
-- The implementation for the X'Address attribute is already provided
-- by the R1000 semanticist and is therefore not defined here.
--
-- 'Ref is "overloaded" in that it has two permitted forms. The form
-- X'Ref is used only in machine code insertions. Both forms could not
-- be implemented in the RCI. Because machine code insertions should be
-- used somewhat infrequently, this customization implements only the
-- System.Address'Ref(N) form.
--
-- In the case of both System.Address'Ref(N) and X'Task_Id a known bug
-- in the Rev1_0_0 release of the RCF prevents usages of these
-- attributes in a view using this customization from semantizing
-- properly. The bug has reportedly been fixed in the upcoming
-- maintanence release. Once this release becomes available, the use
-- of these attributes will have to be tested. It is believed that
-- they are properly defined here.
--
-- 'Ref has two permitted forms
--
-- X'Ref - Used only in machine_code procedures
-- X must be either a constant, variable, procedure, function, or
-- label.
-- Returns a value of type Machine_Code.Operand.
-- May be used only to designate an operand within a code-statement.
--
-- System.Address'Ref(N) - Used anywhere to convert the
-- Universal_Integer value N to an Address.
-- Returns a type of System.Address.
-- N must be a static value of type Universal_Integer.
--
-- Of the two permitted forms, only System.Address'Ref(N) is
-- implemented at this time.
Ref_Textual_Types : constant Checking.Type_Name_Array :=
(1 => Text.Build (S => "System.Address", For_Target => T_Name));
Ref_Type_Set : constant Checking.Type_Set :=
Checking.Build
(Enforced_Type_Restrictions => Checking.All_Type_Restrictions,
Valid_Structural_Types => Checking.No_Structural_Types,
Valid_Textual_Types => Ref_Textual_Types,
For_Target => T_Name);
Ref_Prefix : constant Attr.Prefix :=
Attr.Build
(Valid_Objects => Checking.Null_Object_Set,
Valid_Miscellaneous_Names =>
Checking.Null_Miscellaneous_Name_Set,
Valid_Types => Ref_Type_Set,
For_Target => T_Name);
Ref_Result : constant Attr.Result :=
Attr.Build_With_Value_Result
(Type_Name => "System.Address", For_Target => T_Name);
Ref_Designator : constant Attr.Designator :=
Attr.Build (Function_Parameter =>
Checking.Build
(Expression_Type => "Universal_Integer",
Constraint => Checking.Null_Constraint (T_Name),
For_Target => T_Name),
For_Target => T_Name);
Ref_Attr : constant Attr.Attribute :=
Attr.Build
(The_Name => "Ref",
The_Prefix => Ref_Prefix,
The_Result => Ref_Result,
The_Designator => Ref_Designator,
For_Target => T_Name);
----------------------------------------------------------------------
Xref_Type_Set : Checking.Type_Set :=
Checking.Build (Enforced_Type_Restrictions =>
Checking.No_Type_Restrictions,
Valid_Structural_Types =>
Checking.All_Structural_Types,
Valid_Textual_Types => Checking.No_Type_Names,
Required_Pragmas => Checking.No_Pragmas,
Prohibited_Pragmas => Checking.No_Pragmas,
For_Target => T_Name);
Xref_Objects : constant Checking.Object_Set :=
Checking.Build (Valid_Kinds => (Checking.Constant_Kind => True,
Checking.Variable => True,
others => False),
Allowed_Types => Xref_Type_Set,
Required_Pragmas => Checking.No_Pragmas,
Prohibited_Pragmas => Checking.No_Pragmas,
For_Target => T_Name);
Xref_Misc_Names : constant Checking.Miscellaneous_Name_Set :=
Checking.Build (Valid_Kinds => (Checking.Function_Kind => True,
Checking.Procedure_Kind => True,
Checking.Label_Kind => True,
others => False),
Ambiguity_Allowed => False,
Required_Pragmas => Checking.No_Pragmas,
Prohibited_Pragmas => Checking.No_Pragmas,
For_Target => T_Name);
Xref_Prefix : constant Attr.Prefix :=
Attr.Build
(Valid_Objects => Xref_Objects,
Valid_Miscellaneous_Names => Xref_Misc_Names,
Valid_Types => Checking.Null_Type_Set,
For_Target => T_Name);
Xref_Result : constant Attr.Result :=
Attr.Build_With_Value_Result
(Type_Name => "Machine_Code.Operand", For_Target => T_Name);
Xref_Designator : constant Attr.Designator :=
Attributes.Null_Designator;
Xref_Attr : constant Attr.Attribute :=
Attr.Build
(The_Name => "Ref",
The_Prefix => Xref_Prefix,
The_Result => Xref_Result,
The_Designator => Xref_Designator,
For_Target => T_Name);
---------------------------------------------------------------------------
-- X'Task_Id
-- X is supposed to be limited to a "task object or a value". However,
-- the SunAda documentation is unclear as to what they mean by "a
-- value" in this context. At this time, the implementation limits use
-- of the 'Task_Id to objects which are task types or are derived from
-- task types.
Task_Id_Types_Set : constant Checking.Type_Set :=
Checking.Build
(Enforced_Type_Restrictions => Checking.No_Type_Restrictions,
Valid_Structural_Types =>
(Checking.Task_Type => True, others => False),
For_Target => T_Name);
Task_Id_Object_Set : constant Checking.Object_Set :=
Checking.Build
(Valid_Kinds => Checking.All_Object_Kinds,
Allowed_Types => Task_Id_Types_Set,
For_Target => T_Name);
Task_Id_Misc_Name_Set : constant Checking.Miscellaneous_Name_Set :=
Checking.Build (Valid_Kinds =>
(Checking.Task_Kind => True, others => False),
For_Target => T_Name);
Task_Id_Prefix : constant Attr.Prefix :=
Attr.Build
(Valid_Objects => Task_Id_Object_Set,
Valid_Miscellaneous_Names => Task_Id_Misc_Name_Set,
Valid_Types => Checking.Null_Type_Set,
For_Target => T_Name);
Task_Id_Result : constant Attr.Result :=
Attr.Build_With_Value_Result
(Type_Name => "System.Task_Id", For_Target => T_Name);
Task_Id_Designator : constant Attr.Designator :=
Attr.Null_Designator;
Task_Id_Attr : constant Attr.Attribute :=
Attr.Build
(The_Name => "Task_Id",
The_Prefix => Task_Id_Prefix,
The_Result => Task_Id_Result,
The_Designator => Task_Id_Designator,
For_Target => T_Name);
---------------------------------------------------------------------------
Attr_List : constant Attr.Attribute_Array :=
(1 => Ref_Attr, 2 => Xref_Attr, 3 => Task_Id_Attr);
begin
if not Is_Authorized (This_Target) then
Log.Put_Line
(Message =>
"The " & This_Target &
" target has not been authorized on this machine.",
Kind => Profile.Error_Msg);
raise Program_Error;
end if;
-- FOR I IN Attr_List'Range LOOP
-- Io.Put_Line (Attr.Get_Name (Attr_List (I)));
-- Io.Put_Line (" Result: " & Attr.Get_Name
-- (Attr.Get_Result (Attr_List (I))));
-- END LOOP;
--
return Attr.Build (Attribute_List => Attr_List, For_Target => T_Name);
end Get_Attribute_Info;
function Get_Predefined_Info
(Target_Key_Name : String) return Predefined.Object is
-- AN IMPORTANT NOTE!
-- Any time a change is made to the definitions found in this body, the
-- STANDARD_VERSION parameter to the final Predefined.Build command must be
-- incremented. This is what causes a new version of the package Standard
-- to be created.
--
-- WARNING:
-- Creation of a new version of package standard causes all units contained
-- in any worlds/views with the SPARC_SUN_XT target key to be demoted and
-- repromoted.
--
-- Be advised that running the SPARC_SUN_XT.REGISTER command after making
-- changes to this body and incrementing the STANDARD_VERSION parameter will
-- cause this command to take quite a while to run. BE PATIENT, it really
-- is doing something.
--
--
Tiny_Int : constant Predefined.Integer_Type_Descriptor :=
Predefined.Build (Name => "TINY_INTEGER",
Size => 8,
Lo_Bound => Universal.Value (Integer'(-2 ** 7)),
Hi_Bound => Universal.Value (Integer'(2 ** 7 - 1)),
For_Target => T_Name);
Short_Int : constant Predefined.Integer_Type_Descriptor :=
Predefined.Build
(Name => "SHORT_INTEGER",
Size => 16,
Lo_Bound => Universal.Value (Integer'(-2 ** 15)),
Hi_Bound => Universal.Value (Integer'(2 ** 15 - 1)),
For_Target => T_Name);
Int : constant Predefined.Integer_Type_Descriptor :=
Predefined.Build
(Name => "INTEGER",
Size => 32,
Lo_Bound => Universal.Value (Long_Integer'(-2 ** 31)),
Hi_Bound => Universal.Value (Long_Integer'(2 ** 31 - 1)),
For_Target => T_Name);
-- The definition of the RCF_UNSIGNED_INTEGER is made here to
-- facilitate the implementation of the Ada spec of package
-- Unsigned_Integer. RCF_UNSIGNED_INTEGER IS NOT PORTABLE AND SHOULD
-- NOT BE USED BY IMPLEMENTORS.
--
-- Implementors may chose to use SunAda's package Unsigned_Integer.
-- The RCI implementation of this package spec requires that we create
-- the RCF_UNSIGNED_INTEGER type in package Standard.
--
-- Users should see the WARNINGS pertaining to the use of the
-- non-standard package Unsigned_Integer in the SunAda appendix F.
--
--
Rcf_Us_Int : constant Predefined.Integer_Type_Descriptor :=
Predefined.Build
(Name => "RCF_UNSIGNED_INTEGER",
Size => 32,
Lo_Bound => Universal.Value (Long_Integer'(0)),
Hi_Bound => Universal.Value (Long_Integer'(2 ** 32 - 1)),
For_Target => T_Name);
Integers : constant Predefined.Integer_Type_Array :=
(Tiny_Int, Short_Int, Int, Rcf_Us_Int);
--------------------------------------------------
Single_Last : constant Universal.Real := Universal.Value (3.40282E+38);
Double_Last : constant Universal.Real :=
Universal.Value (1.79769313486231E+308);
Short_Flo : constant Predefined.Float_Type_Descriptor :=
Predefined.Build (Name => "SHORT_FLOAT",
Digitz => 6,
Size => 32,
Lo_Bound => Universal."-" (Single_Last),
Hi_Bound => Single_Last,
Safe_Emax => 125,
Machine_Emax => 128,
Machine_Emin => -125,
Machine_Radix => 2,
Machine_Mantissa => 24,
Machine_Rounds => True,
Machine_Overflows => True,
For_Target => T_Name);
Flo : constant Predefined.Float_Type_Descriptor :=
Predefined.Build (Name => "FLOAT",
Digitz => 15,
Size => 64,
Lo_Bound => Universal."-" (Double_Last),
Hi_Bound => Double_Last,
Safe_Emax => 1021,
Machine_Emax => 1024,
Machine_Emin => -1021,
Machine_Radix => 2,
Machine_Mantissa => 53,
Machine_Rounds => True,
Machine_Overflows => True,
For_Target => T_Name);
Floats : constant Predefined.Float_Type_Array := (Short_Flo, Flo);
------------------------------------------------
Dur : constant Predefined.Fixed_Type_Descriptor :=
Predefined.Build (Name => "DURATION",
Size => 32,
Scale => -10,
Lo_Bound => Universal.Value (-2147483.648),
Hi_Bound => Universal.Value (2147483.647),
For_Target => T_Name);
------------------------------------------------
Predefined_Characteristics : constant Predefined.Object :=
Predefined.Build (Standard_Version => 14,
Integer_Types => Integers,
Float_Types => Floats,
Duration_Type => Dur,
For_Target => T_Name);
begin
if not Is_Authorized (This_Target) then
Log.Put_Line
(Message =>
"The " & This_Target &
" target has not been authorized on this machine.",
Kind => Profile.Error_Msg);
raise Program_Error;
end if;
return Predefined_Characteristics;
end Get_Predefined_Info;
function Get_Pragma_Info (Target_Key_Name : String) return Pragmas.Object is
-- The following pragmas have been implemented. Any limitations in the
-- implementation are included in the comments associated with the
-- pragma involved.
--
-- The details of each pragma's use and functionality are documented in
-- the "Sun Ada 1.0 for Sun4 SunOS 4.x Programmer's Guide".
--
-- Pragma Controlled
-- Pragma Elaborate
-- Pragma External_Name
-- Pragma Implicit_Code (see limitations)
-- Pragma Inline
-- Pragma Inline_Only (see limitations)
-- Pragma Interface
-- Pragma Interface_Name (see limitations)
-- Pragma Link_With
-- Pragma List
-- Pragma Memory_Size
-- Pragma No_Image
-- Pragma Non_Reentrant
-- Pragma Not_Elaborated (see limitations)
-- Pragma Optimize
-- Pragma Optimize_Code (see limitations)
-- Pragma Pack
-- Pragma Page
-- Pragma Passive (see limitations)
-- Pragma Priority
-- Pragma Share_Body (see limitations)
-- Pragma Share_Code (see limitations)
-- Pragma Shared
-- Pragma Storage_Unit
-- Pragma Suppress
-- Pragma System_Name
-- Pragma Volatile
-- Declarations used by more than one pragma definition
All_Types_Allowed : Checking.Type_Set :=
Checking.Build
(Enforced_Type_Restrictions => Checking.No_Type_Restrictions,
Valid_Structural_Types => Checking.All_Structural_Types,
Valid_Textual_Types => Checking.No_Type_Names,
Required_Pragmas => Checking.No_Pragmas,
Prohibited_Pragmas => Checking.No_Pragmas,
For_Target => T_Name);
All_Objects_Allowed : constant Checking.Object_Set :=
Checking.Build
(Valid_Kinds => Checking.All_Object_Kinds,
Allowed_Types => All_Types_Allowed,
For_Target => T_Name);
Null_Constraint : constant Checking.Range_Constraint :=
Checking.Null_Constraint (For_Target => T_Name);
String_Expression : constant Checking.Expression :=
Checking.Build (Expression_Type => "String",
Constraint => Null_Constraint,
For_Target => T_Name);
On_Off_Argument : constant Pragmas.Argument :=
Pragmas.Build_Name_Argument
(Name => "On_Off",
Valid_Special_Identifiers =>
(Text.Build ("On", T_Name),
Text.Build ("Off", T_Name)),
For_Target => T_Name);
On_Off_Arguments : constant Pragmas.Argument_Array :=
(1 => On_Off_Argument);
Link_Name_Arg : constant Pragmas.Argument :=
Pragmas.Build_Expression_Argument
(Name => "Link_Name",
Valid_Expressions => String_Expression,
For_Target => T_Name);
Subprogram_Misc_Names : Checking.Miscellaneous_Name_Set :=
Checking.Build
(Valid_Kinds =>
(Checking.Function_Kind => True,
Checking.Procedure_Kind => True,
Checking.Generic_Function_Kind => True,
Checking.Generic_Procedure_Kind => True,
others => False),
For_Target => T_Name);
----------------------------------------------------------------------
-- PRAGMA EXTERNAL_NAME(Ada_Name,"Link_Name")
External_Name_Objects : Checking.Object_Set :=
Checking.Build
(Valid_Kinds =>
(Checking.Variable => True,
others => False),
Allowed_Types => All_Types_Allowed,
For_Target => T_Name);
External_Name_Misc_Names : Checking.Miscellaneous_Name_Set :=
Checking.Build
(Valid_Kinds =>
(Checking.Function_Kind => True,
Checking.Procedure_Kind => True,
others => False),
Ambiguity_Allowed => False,
For_Target => T_Name);
External_Name_Arg_1 : constant Pragmas.Argument :=
Pragmas.Build_Name_Argument
(Name => "Ada_Name",
Valid_Objects => External_Name_Objects,
Valid_Miscellaneous_Names => External_Name_Misc_Names,
For_Target => T_Name);
External_Name_Arguments : constant Pragmas.Argument_Array :=
(External_Name_Arg_1, Link_Name_Arg);
External_Name_Pragma : constant Pragmas.Target_Pragma :=
Pragmas.Build
(Name => "External_Name",
Valid_Locations =>
(Pragmas.Declaration => True,
others => False),
Arguments => External_Name_Arguments,
Last_Required_Argument => 2,
For_Target => T_Name);
----------------------------------------------------------------------
--PRAGMA IMPLICIT_CODE(ON)
--PRAGMA IMPLICIT_CODE(OFF)
-- Allowed only in the declarative part of a machine code
-- procedure. No way to really enforce this.
Implicit_Code_Pragma : constant Pragmas.Target_Pragma :=
Pragmas.Build
(Name => "Implicit_Code",
Valid_Locations =>
(Pragmas.Declaration => True, others => False),
Arguments => On_Off_Arguments,
Last_Required_Argument => 1,
For_Target => T_Name);
----------------------------------------------------------------------
-- PRAGMA INLINE_ONLY
-- Used in the same manner as pragma INLINE, refer Appendix B of the
-- LRM. This implementation arbitrarily limits the number of arguments
-- to 5, but the Sun Ada documentation imposes no limitation. If more
-- than 5 parameters are supplied, the semanticist will only issue a
-- warning, but the code will still install.
Inline_Only_Arg_1 : constant Pragmas.Argument :=
Pragmas.Build_Name_Argument
(Name => "Ada_Subprogram_Name",
Valid_Objects => Checking.Null_Object_Set,
Valid_Miscellaneous_Names => Subprogram_Misc_Names,
For_Target => T_Name);
Inline_Only_Arguments : constant Pragmas.Argument_Array :=
(1 => Inline_Only_Arg_1,
2 => Inline_Only_Arg_1,
3 => Inline_Only_Arg_1,
4 => Inline_Only_Arg_1,
5 => Inline_Only_Arg_1);
Inline_Only_Pragma : constant Pragmas.Target_Pragma :=
Pragmas.Build
(Name => "Inline_Only",
Valid_Locations =>
(Pragmas.Comp_Unit => True,
Pragmas.Declaration => True,
others => False),
Arguments => Inline_Only_Arguments,
Last_Required_Argument => 1,
For_Target => T_Name);
----------------------------------------------------------------------
--PRAGMA INTERFACE_NAME (Ada_Name,"Link_Name")
-- Allowed only in declarative portion of a package spec. If applied to
-- an object, must be scalar or Access Type and cannot be loop
-- variable, constant, initialized_variable, array or record. If
-- applied to a subprogram, a pragma INTERFACE must have already been
-- specified for the subprogram. It may not be possible to correctly
-- enforce these restrictions.
Interface_Name_Allowed_Types : constant Checking.Type_Set :=
Checking.Build
(Enforced_Type_Restrictions => Checking.No_Type_Restrictions,
Valid_Structural_Types =>
(Checking.Array_Type => False,
Checking.Record_Type => False,
Checking.Task_Type => False,
others => True
),
For_Target => T_Name);
Interface_Name_Objects : Checking.Object_Set :=
Checking.Build
(Valid_Kinds =>
(Checking.Variable => True,
others => False
),
Allowed_Types => Interface_Name_Allowed_Types,
For_Target => T_Name);
Interface_Name_Required_Pragmas : constant Checking.Pragma_Array :=
(1 => Text.Build (S => "Interface", For_Target => T_Name));
Interface_Name_Misc_Names : Checking.Miscellaneous_Name_Set :=
Checking.Build
(Valid_Kinds =>
(Checking.Function_Kind => True,
Checking.Procedure_Kind => True,
others => False),
Ambiguity_Allowed => False,
Required_Pragmas => Interface_Name_Required_Pragmas,
For_Target => T_Name);
Interface_Name_Arg_1 : constant Pragmas.Argument :=
Pragmas.Build_Name_Argument
(Name => "Ada_Name",
Valid_Objects => Interface_Name_Objects,
Valid_Miscellaneous_Names => Interface_Name_Misc_Names,
For_Target => T_Name);
Interface_Name_Arguments : constant Pragmas.Argument_Array :=
(Interface_Name_Arg_1, Link_Name_Arg);
Interface_Name_Pragma : constant Pragmas.Target_Pragma :=
Pragmas.Build
(Name => "Interface_Name",
Valid_Locations =>
(Pragmas.Declaration => True,
others => False),
Arguments => Interface_Name_Arguments,
Last_Required_Argument => 2,
For_Target => T_Name);
----------------------------------------------------------------------
-- PRAGMA LINK_WITH ("Linker_Argument");
Link_With_Argument : constant Pragmas.Argument :=
Pragmas.Build_Expression_Argument
(Name => "Linker_Option",
Valid_Expressions => String_Expression,
For_Target => T_Name);
Link_With_Pragma : constant Pragmas.Target_Pragma :=
Pragmas.Build
(Name => "Link_With",
Valid_Locations =>
(Pragmas.Declaration => True,
others => False),
Arguments => (1 => Link_With_Argument),
Last_Required_Argument => 1,
For_Target => T_Name);
----------------------------------------------------------------------
-- PRAGMA NO_IMAGE (Type_Name);
No_Image_Arg_Types : constant Checking.Type_Set :=
Checking.Build
(Enforced_Type_Restrictions => Checking.No_Type_Restrictions,
Valid_Structural_Types =>
(Checking.Enumeration_Type => True,
others => False),
For_Target => T_Name);
No_Image_Argument : constant Pragmas.Argument :=
Pragmas.Build_Name_Argument
(Name => "No_Image",
Valid_Types => No_Image_Arg_Types,
For_Target => T_Name);
No_Image_Pragma : constant Pragmas.Target_Pragma :=
Pragmas.Build
(Name => "No_Image",
Valid_Locations => (Pragmas.Declaration => True,
others => False),
Arguments => (1 => No_Image_Argument),
Last_Required_Argument => 1,
For_Target => T_Name);
----------------------------------------------------------------------
-- PRAGMA NON_REENTRANT(Ada_Subprogram_Name)
Non_Reentrant_Arg : constant Pragmas.Argument :=
Pragmas.Build_Name_Argument
(Name => "Ada_Subprogram_Name",
Valid_Objects => Checking.Null_Object_Set,
Valid_Miscellaneous_Names => Subprogram_Misc_Names,
For_Target => T_Name);
Non_Reentrant_Pragma : constant Pragmas.Target_Pragma :=
Pragmas.Build
(Name => "Non_Reentrant",
Valid_Locations => (Pragmas.Comp_Unit => True,
Pragmas.Declaration => True,
others => False),
Arguments => (1 => Non_Reentrant_Arg),
Last_Required_Argument => 1,
For_Target => T_Name);
----------------------------------------------------------------------
-- PRAGMA NOT_ELABORATED
-- Can appear ONLY in a package spec.
--
-- Valid_Locations is currently limited in its ability to limit where a
-- pragma may appear. It is up to the user to properly locate the
-- pragma.
Not_Elaborated_Pragma : constant Pragmas.Target_Pragma :=
Pragmas.Build
(Name => "Not_Elaborated",
Valid_Locations => (Pragmas.Comp_Unit => True,
Pragmas.Declaration => True,
others => False),
Arguments => Pragmas.No_Arguments,
Last_Required_Argument => 0,
For_Target => T_Name);
----------------------------------------------------------------------
-- PRAGMA Optimize_Code(ON)
-- PRAGMA Optimize_Code(OFF)
-- May appear in any subprogram. Default is ON.
--
-- Valid_Locations is currently limited in its ability to limit where a
-- pragma may appear. It is up to the user to properly locate the
-- pragma.
Optimize_Code_Pragma : constant Pragmas.Target_Pragma :=
Pragmas.Build
(Name => "Optimize_Code",
Valid_Locations => (Pragmas.Declaration => True,
others => False),
Arguments => On_Off_Arguments,
Last_Required_Argument => 1,
For_Target => T_Name);
----------------------------------------------------------------------
-- PRAGMA Passive
-- PRAGMA Passive(Semaphore)
-- PRAGMA Passive(Interrupt,nnn)
--
-- Because there are three valid forms of the Pragma, the code below
-- allows the user to successfully semanticize all three. However,
-- improper combinations will also semanticize on the R1000 (such as
-- PRAGMA Passive(nnn), PRAGMA Passive(Semaphore,nnn) or
-- PRAGMA Passive(Interrupt)). It is up to the user to use the pragma
-- correctly.
--
-- Pragma can only be applied to a task or task type declared
-- immediately within a package spec or body.
--
-- Valid_Locations is currently limited in its ability to limit where a
-- pragma may appear. It is up to the user to properly locate the
-- pragma.
Passive_Arguments : constant Pragmas.Argument_Array :=
(1 => Pragmas.Build_Name_Argument
(Name => "Semaphore_or_Interrupt",
Valid_Objects => Checking.Null_Object_Set,
Valid_Miscellaneous_Names =>
Checking.Null_Miscellaneous_Name_Set,
Valid_Types => Checking.Null_Type_Set,
Valid_Special_Identifiers =>
(Text.Build (S => "Semaphore", For_Target => T_Name),
Text.Build (S => "Interrupt", For_Target => T_Name)),
For_Target => T_Name),
2 => Pragmas.Build_Expression_Argument
(Name => "Interrupt_Mask",
Valid_Expressions =>
Checking.Build
(Expression_Type => "Integer",
Constraint => Checking.Null_Constraint (T_Name),
For_Target => T_Name),
For_Target => T_Name));
Passive_Pragma : constant Pragmas.Target_Pragma :=
Pragmas.Build
(Name => "Passive",
Valid_Locations => (Pragmas.Task_Spec => True,
others => False),
Arguments => Passive_Arguments,
Last_Required_Argument => 0,
For_Target => T_Name);
----------------------------------------------------------------------
-- PRAGMA SHARE_BODY(Generic_Unit_Name,TRUE)
-- PRAGMA SHARE_BODY(Generic_Unit_Name,FALSE)
--
-- PRAGMA SHARE_CODE(Generic_Unit_Name,TRUE)
-- PRAGMA SHARE_CODE(Generic_Unit_Name,FALSE)
--
-- SHARE_BODY and SHARE_CODE are identical.
--
-- This pragma may be applied to EITHER a generic unit OR to an
-- an instanitation of a generic unit. We can only check for the
-- former. Therefore, the use of this pragma applied to an
-- instantiation will cause the R1000 to generate a compiler warning
-- that may be ignored.
Share_Code_Misc_Names : Checking.Miscellaneous_Name_Set :=
Checking.Build
(Valid_Kinds =>
(Checking.Generic_Package_Kind => True,
Checking.Generic_Procedure_Kind => True,
Checking.Generic_Function_Kind => True,
Checking.Package_Kind => True,
Checking.Procedure_Kind => True,
Checking.Function_Kind => True,
others => False),
Ambiguity_Allowed => False,
For_Target => T_Name);
Share_Code_Arguments : constant Pragmas.Argument_Array :=
(1 => Pragmas.Build_Name_Argument
(Name => "Generic_Unit_Or_Instantiation",
Valid_Objects => Checking.Null_Object_Set,
Valid_Miscellaneous_Names => Share_Code_Misc_Names,
For_Target => T_Name),
2 => Pragmas.Build_Name_Argument
(Name => "True_False",
Valid_Special_Identifiers =>
(Text.Build ("True", T_Name),
Text.Build ("False", T_Name)),
For_Target => T_Name));
Share_Body_Pragma : constant Pragmas.Target_Pragma :=
Pragmas.Build (Name => "Share_Body",
Valid_Locations => (Pragmas.Context_Clause => False,
Pragmas.Statement => False,
others => True),
Arguments => Share_Code_Arguments,
Last_Required_Argument => 2,
For_Target => T_Name);
Share_Code_Pragma : constant Pragmas.Target_Pragma :=
Pragmas.Build (Name => "Share_Code",
Valid_Locations => (Pragmas.Context_Clause => False,
Pragmas.Statement => False,
others => True),
Arguments => Share_Code_Arguments,
Last_Required_Argument => 2,
For_Target => T_Name);
----------------------------------------------------------------------
-- PRAGMA VOLATILE(Object_Name)
Volatile_Argument : constant Pragmas.Argument :=
Pragmas.Build_Name_Argument
(Name => "Volatile_Object",
Valid_Objects => All_Objects_Allowed,
For_Target => T_Name);
Volatile_Pragma : constant Pragmas.Target_Pragma :=
Pragmas.Build
(Name => "Volatile",
Valid_Locations =>
(Pragmas.Declaration => True, others => False),
Arguments => (1 => Volatile_Argument),
Last_Required_Argument => 1,
For_Target => T_Name);
----------------------------------------------------------------------
-- The above definitions are used to create the following structures
----------------------------------------------------------------------
Implementation_Dependent_Pragmas :
constant Pragmas.Target_Pragma_Array :=
(External_Name_Pragma,
Implicit_Code_Pragma,
Inline_Only_Pragma,
Interface_Name_Pragma,
Link_With_Pragma,
No_Image_Pragma,
Non_Reentrant_Pragma,
Not_Elaborated_Pragma,
Optimize_Code_Pragma,
Passive_Pragma,
Share_Body_Pragma,
Share_Code_Pragma,
Volatile_Pragma);
Lrm_Defined_Pragmas :
constant Pragmas.Ada_Pragma_Array := (others => True);
Pragma_Object : constant Pragmas.Object :=
Pragmas.Build
(Supported_Ada_Pragmas => Lrm_Defined_Pragmas,
Target_Pragmas => Implementation_Dependent_Pragmas,
Interface_Languages =>
(1 => Text.Build ("C", T_Name),
2 => Text.Build ("Ada", T_Name),
3 => Text.Build ("FORTRAN", T_Name),
4 => Text.Build ("Pascal", T_Name),
5 => Text.Build ("Unchecked", T_Name)
),
For_Target => T_Name);
begin
if not Is_Authorized (This_Target) then
Log.Put_Line
(Message =>
"The " & This_Target &
" target has not been authorized on this machine.",
Kind => Profile.Error_Msg);
raise Program_Error;
end if;
return Pragma_Object;
end Get_Pragma_Info;
function Get_Rep_Spec_Info
(Target_Key_Name : String) return Rep_Specs.Object is
begin
if not Is_Authorized (This_Target) then
Log.Put_Line
(Message =>
"The " & This_Target &
" target has not been authorized on this machine.",
Kind => Profile.Error_Msg);
raise Program_Error;
end if;
return (Rep_Specs.Build (For_Target => Target_Key_Name));
end Get_Rep_Spec_Info;
end Rcf_Semantics;