|
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: 21336 (0x5358)
Types: TextFile
Names: »B«
└─⟦516dceb10⟧ Bits:30000751 8mm tape, Rational 1000, RCI_VADS
└─ ⟦9a14c9417⟧ »DATA«
└─⟦this⟧
separate (M68k_Sunos_Vdx)
function Get_Pragma_Info 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_Code (see limitations)
-- Pragma Share_Body (same as Share_Code)
-- 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);
True_False_Argument : constant Pragmas.Argument :=
Pragmas.Build_Name_Argument
(Name => "True_False",
Valid_Special_Identifiers =>
(Text.Build ("True", T_Name),
Text.Build ("False", T_Name)),
For_Target => T_Name);
True_False_Argument_Array : constant Pragmas.Argument_Array :=
(1 => True_False_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 abritrarily 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);
----------------------------------------------------------------------
-- This pragma definition was changed to add the second required
-- parameter of either True or False. This parameter was inadvertently
-- left off in previous versions.
-- CHANGED BY: Larry Paise, Rational
-- April 7, 1992 18:20
--
-- PRAGMA SHARE_CODE(Generic_Unit_Name,True_False_Value)
-- 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,
others => False),
Ambiguity_Allowed => False,
For_Target => T_Name);
Share_Code_Argurment : constant Pragmas.Argument :=
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);
Share_Code_Pragma : constant Pragmas.Target_Pragma :=
Pragmas.Build
(Name => "Share_Code",
Valid_Locations =>
(Pragmas.Context_Clause => False,
Pragmas.Statement => False,
others => True),
Arguments =>
(1 => Share_Code_Argurment, 2 => True_False_Argument),
Last_Required_Argument => 2,
For_Target => T_Name);
----------------------------------------------------------------------
-- ADDED BY: Larry Paise, Rational
-- April 7, 1992 18:20
--
-- PRAGMA SHARE_BODY(Generic_Unit_Name,True_False_Value)
-- Per the SunAda Appendix F, this pragma may be used in the place of
-- pragma SHARE_CODE with the same effect. Checking for this pragma has
-- the same limitations as pragma SHARE_CODE.
Share_Body_Pragma : constant Pragmas.Target_Pragma :=
Pragmas.Build
(Name => "Share_Body",
Valid_Locations =>
(Pragmas.Context_Clause => False,
Pragmas.Statement => False,
others => True),
Arguments =>
(1 => Share_Code_Argurment, 2 => True_False_Argument),
Last_Required_Argument => 2,
For_Target => T_Name);
----------------------------------------------------------------------
-- PRAGMA VOLATILE(Object_Name)
Volatile_Argurment : 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_Argurment),
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_Code_Pragma,
Share_Body_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
return Pragma_Object;
end Get_Pragma_Info;