home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Geek Gadgets 1
/
ADE-1.bin
/
ade-dist
/
gnat-2.06-src.tgz
/
tar.out
/
fsf
/
gnat
/
ada
/
exp_prag.adb
< prev
next >
Wrap
Text File
|
1996-09-28
|
14KB
|
408 lines
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- E X P _ P R A G --
-- --
-- B o d y --
-- --
-- $Revision: 1.24 $ --
-- --
-- Copyright (c) 1992,1993,1994 NYU, All Rights Reserved --
-- --
-- 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, 675 Mass Ave, Cambridge, MA 02139, USA. --
-- --
------------------------------------------------------------------------------
with Atree; use Atree;
with Einfo; use Einfo;
with Exp_TSS; use Exp_TSS;
with Exp_Util; use Exp_Util;
with Lib; use Lib;
with Namet; use Namet;
with Nlists; use Nlists;
with Nmake; use Nmake;
with Opt; use Opt;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Eval; use Sem_Eval;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Sinput; use Sinput;
with Snames; use Snames;
with Stringt; use Stringt;
with Tbuild; use Tbuild;
package body Exp_Prag is
-----------------------
-- Local Subprograms --
-----------------------
function Arg1 (N : Node_Id) return Node_Id;
function Arg2 (N : Node_Id) return Node_Id;
function Arg3 (N : Node_Id) return Node_Id;
-- Obtain specified Pragma_Argument_Association
procedure Expand_Pragma_Abort_Defer (N : Node_Id);
procedure Expand_Pragma_Assert (N : Node_Id);
procedure Expand_Pragma_Convention (N : Node_Id);
procedure Expand_Pragma_Export (N : Node_Id);
procedure Expand_Pragma_Import (N : Node_Id);
procedure Expand_Pragma_Interface (N : Node_Id);
procedure Expand_Pragma_Interrupt_Priority (N : Node_Id);
procedure Make_Stdcall_Pragma (N : Node_Id);
-- This is used for Convention, Import, Export and Interface attributes.
-- If the convention is Stdcall, then a pragma Machine_Attribute that
-- specifies the machine attribute "stdcall" for the relevant entity is
-- constructed and inserted following the pragma being expanded.
--------------
-- Arg1,2,3 --
--------------
function Arg1 (N : Node_Id) return Node_Id is
begin
return First (Pragma_Argument_Associations (N));
end Arg1;
function Arg2 (N : Node_Id) return Node_Id is
begin
return Next (Arg1 (N));
end Arg2;
function Arg3 (N : Node_Id) return Node_Id is
begin
return Next (Arg2 (N));
end Arg3;
---------------------
-- Expand_N_Pragma --
---------------------
procedure Expand_N_Pragma (N : Node_Id) is
begin
case Get_Pragma_Id (Chars (N)) is
-- Pragmas requiring special expander action
when Pragma_Convention =>
Expand_Pragma_Convention (N);
when Pragma_Abort_Defer =>
Expand_Pragma_Abort_Defer (N);
when Pragma_Assert =>
Expand_Pragma_Assert (N);
when Pragma_Export =>
Expand_Pragma_Export (N);
when Pragma_Interrupt_Priority =>
Expand_Pragma_Interrupt_Priority (N);
when Pragma_Import =>
Expand_Pragma_Import (N);
when Pragma_Interface =>
Expand_Pragma_Interface (N);
-- All other pragmas need no expander action
when others => null;
end case;
end Expand_N_Pragma;
-------------------------------
-- Expand_Pragma_Abort_Defer --
-------------------------------
-- An Abort_Defer pragma appears as the first statement in a handled
-- statement sequence (right after the begin). It defers aborts for
-- the entire statement sequence, but not for any declarations or
-- handlers (if any) associated with this statement sequence.
-- With the current approach of explicit calls to Abort_Defer and
-- Abort_Undefer, we accomplish this by inserting a call to Abort_Defer
-- at the end of the associated declarations, and a call to Abort_Undefer
-- at the end of the sequence of statements. In addition, if there are
-- any exception handlers, a call to Abort_Undefer is placed at the start
-- of the statements of each of the handlers.
procedure Expand_Pragma_Abort_Defer (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
HSS : constant Node_Id := Parent (N);
-- The N_Handled_Sequence_Of_Statements node
P : constant Node_Id := Parent (HSS);
-- The parent of the handled sequence has the declarations
EH : Node_Id;
-- An exception handler
Call : Node_Id;
begin
pragma Assert (Nkind (HSS) = N_Handled_Sequence_Of_Statements);
if No (Declarations (P)) then
Set_Declarations (P, New_List);
end if;
Call := Build_Runtime_Call (Loc, RE_Abort_Defer);
Append (Call, Declarations (P));
Analyze (Call);
Call := Build_Runtime_Call (Loc, RE_Abort_Undefer);
Append (Call, Statements (HSS));
Analyze (Call);
if Present (Exception_Handlers (HSS)) then
EH := First (Exception_Handlers (HSS));
while Present (EH) loop
Call := Build_Runtime_Call (Loc, RE_Abort_Undefer);
Prepend (Call, Statements (EH));
Analyze (Call);
EH := Next (EH);
end loop;
end if;
end Expand_Pragma_Abort_Defer;
--------------------------
-- Expand_Pragma_Assert --
--------------------------
procedure Expand_Pragma_Assert (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
begin
-- If we are not in debug mode then rewrite the pragma with
-- a null statement and do not even analyze the pragma.
if not Assertions_Enabled then
Rewrite_Substitute_Tree (N, Make_Null_Statement (Loc));
-- If we are in debug mode, then rewrite the pragma with its
-- corresponding if statement, and then analyze the statement
-- The expansion transforms:
-- pragma Assert (condition [,message]);
-- into
-- if not condition then
-- System.Assertions.Raise_Assert_Failure (Str);
-- end if;
-- where Str is the message if one is present, or the default of
-- file:line if no message is given.
else
Assert : declare
Msg : String_Id;
procedure Store_String_Int (N : Logical_Line_Number);
-- Store characters of decimal representation of N in string
-- currently being constructed by Stringt.Store_String_Char.
procedure Store_String_Int (N : Logical_Line_Number) is
begin
if N > 9 then
Store_String_Int (N / 10);
end if;
Store_String_Char
(Get_Char_Code
(Character'Val (N mod 10 + Character'Pos ('0'))));
end Store_String_Int;
-- Start of processing for Assert
begin
-- First, we need to prepare the character literal
if Present (Arg2 (N)) then
Msg := Expr_Value_S (Expression (Arg2 (N)));
else
Start_String;
Get_Name_String
(Reference_Name (Source_Index (Get_Sloc_Unit_Number (Loc))));
for J in 1 .. Name_Len loop
Store_String_Char (Get_Char_Code (Name_Buffer (J)));
end loop;
Store_String_Char (Get_Char_Code (':'));
Store_String_Int (Get_Line_Number (Loc));
end if;
Store_String_Char (Get_Char_Code (Ascii.NUL));
Msg := End_String;
-- Now generate the if statement
Rewrite_Substitute_Tree (N,
Make_If_Statement (Loc,
Condition =>
Make_Op_Not (Loc,
Right_Opnd => Expression (Arg1 (N))),
Then_Statements => New_List (
Make_Procedure_Call_Statement (Loc,
Name =>
New_Reference_To (RTE (RE_Raise_Assert_Failure), Loc),
Parameter_Associations => New_List (
Make_String_Literal (Loc, Msg))))));
Analyze (N);
end Assert;
end if;
end Expand_Pragma_Assert;
------------------------------
-- Expand_Pragma_Convention --
------------------------------
-- The only processing that is required at this stage is the possible
-- expansion of a stdcall pragma. All other processing was done during
-- the semantic analysis.
procedure Expand_Pragma_Convention (N : Node_Id) is
begin
Make_Stdcall_Pragma (N);
end Expand_Pragma_Convention;
--------------------------
-- Expand_Pragma_Export --
--------------------------
-- The only processing that is required at this stage is the possible
-- expansion of a stdcall pragma. All other processing was done during
-- the semantic analysis.
procedure Expand_Pragma_Export (N : Node_Id) is
begin
Make_Stdcall_Pragma (N);
end Expand_Pragma_Export;
--------------------------
-- Expand_Pragma_Import --
--------------------------
-- When applied to a variable, the default initialization must not be
-- done. As it is already done when the pragma is found, we just get rid
-- of the call the initialization procedure which followed the object
-- declaration.
-- We can't use the freezing mechanism for this purpose, since we
-- have to elaborate the initialization expression when it is first
-- seen (i.e. this elaboration cannot be deferred to the freeze point).
procedure Expand_Pragma_Import (N : Node_Id) is
Def_Id : constant Entity_Id := Entity (Expression (Arg2 (N)));
Init : Entity_Id;
After_Def : Node_Id;
begin
Make_Stdcall_Pragma (N);
if Ekind (Def_Id) = E_Variable then
Init := Base_Init_Proc (Etype (Def_Id));
After_Def := Next (Parent (Def_Id));
if Present (Init)
and then Nkind (After_Def) = N_Procedure_Call_Statement
and then Is_Entity_Name (Name (After_Def))
and then Entity (Name (After_Def)) = Init
then
Remove (After_Def);
elsif Is_Access_Type (Etype (Def_Id)) then
Set_Expression (Parent (Def_Id), Empty);
end if;
end if;
end Expand_Pragma_Import;
-----------------------------
-- Expand_Pragma_Interface --
-----------------------------
-- The only processing that is required at this stage is the possible
-- expansion of a stdcall pragma. All other processing was done during
-- the semantic analysis.
procedure Expand_Pragma_Interface (N : Node_Id) is
begin
Make_Stdcall_Pragma (N);
end Expand_Pragma_Interface;
--------------------------------------
-- Expand_Pragma_Interrupt_Priority --
--------------------------------------
-- Supply default argument if none exists (System.Interrupt_Priority'Last)
procedure Expand_Pragma_Interrupt_Priority (N : Node_Id) is
begin
if No (Pragma_Argument_Associations (N)) then
Set_Pragma_Argument_Associations (N, New_List (
Make_Pragma_Argument_Association (Sloc (N),
Expression =>
Make_Attribute_Reference (Sloc (N),
Prefix => RTE (RE_Interrupt_Priority),
Attribute_Name => Name_Last))));
end if;
end Expand_Pragma_Interrupt_Priority;
-------------------------
-- Make_Stdcall_Pragma --
-------------------------
procedure Make_Stdcall_Pragma (N : Node_Id) is
Stdcall : String_Id;
begin
if Chars (Expression (Arg1 (N))) = Name_Stdcall then
Start_String;
Store_String_Chars ("stdcall");
Stdcall := End_String;
-- Now construct the pragma:
-- pragma Machine_Attribute
-- (Attribute_Name => "stdcall", Entity => xxx);
-- where xxx is the entity from the Convention, Import, Export
-- pragma which caused this procedure to be called, and insert
-- this pragma immediately after the parent pragma.
Insert_After (N,
Make_Pragma (Sloc (N),
Chars => Name_Machine_Attribute,
Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Sloc (N),
Chars => Name_Attribute_Name,
Expression =>
Make_String_Literal (Sloc (N), Stdcall)),
Make_Pragma_Argument_Association (Sloc (N),
Chars => Name_Entity,
Expression =>
Make_Identifier (Sloc (N),
Chars => Chars (Expression (Arg2 (N))))))));
end if;
end Make_Stdcall_Pragma;
end Exp_Prag;
