+2010-06-17 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch12.adb: propagate Pragma_Enabled flag to generic.
+ * get_scos.adb: Set C2 flag in decision entry of pragma to 'e' (enabled)
+ * par_sco.ads, par_sco.adb (Set_SCO_Pragma_Enabled): New procedure
+ Remove use of Node field in SCOs table
+ (Output_Header): Set 'd' to initially disable pragma entry
+ * put_scos.adb (Put_SCOs): New flag indicating if pragma is enabled
+ * scos.ads, scos.adb: Remove Node field from internal SCOs table.
+ Use C2 field of pragma decision header to indicate enabled.
+ * sem_prag.adb: Add calls to Set_SCO_Pragma_Enabled.
+ * gcc-interface/Make-lang.in: Update dependencies.
+
+2010-06-17 Vincent Celier <celier@adacore.com>
+
+ * back_end.adb (Next_Arg): Moved to procedure Scan_Compiler_Arguments
+ (Scan_Compiler_Arguments): Call Scan_Front_End_Switches with Next_Arg
+ (Switch_Subsequently_Cancelled): Function moved to the body of Switch.C
+ * back_end.ads (Scan_Front_End_Switches): Function moved to the body of
+ Switch.C.
+ * switch-c.adb: Copied a number of global declarations from back_end.adb
+ (Len_Arg): New function copied from back_end.adb
+ (Switch_Subsequently_Cancelled): New function moved from back_end.adb
+ (Scan_Front_End_Switches): New parameter Arg_Rank used to call
+ Switch_Subsequently_Cancelled.
+ * switch-c.ads (Scan_Front_End_Switches): New parameter Arg_Rank.
+ * gcc-interface/Makefile.in: Add line so that shared libgnat is linked
+ with -lexc on Tru64.
+
2010-06-17 Robert Dewar <dewar@adacore.com>
* prj.ads, prj.adb: Minor reformatting
type Arg_Array_Ptr is access Arg_Array;
-- Types to access compiler arguments
- Next_Arg : Pos := 1;
- -- Next argument to be scanned by Scan_Compiler_Arguments. We make this
- -- global so that it can be accessed by Switch_Subsequently_Cancelled.
-
flag_stack_check : Int;
pragma Import (C, flag_stack_check);
-- Indicates if stack checking is enabled, imported from toplev.c
procedure Scan_Compiler_Arguments is
+ Next_Arg : Pos;
+ -- Next argument to be scanned
+
Output_File_Name_Seen : Boolean := False;
-- Set to True after having scanned file_name for switch "-gnatO file"
-- Loop through command line arguments, storing them for later access
+ Next_Arg := 1;
while Next_Arg < save_argc loop
Look_At_Arg : declare
Argv_Ptr : constant Big_String_Ptr := save_argv (Next_Arg);
Opt.No_Stdlib := True;
elsif Is_Front_End_Switch (Argv) then
- Scan_Front_End_Switches (Argv);
+ Scan_Front_End_Switches (Argv, Next_Arg);
-- All non-front-end switches are back-end switches
Next_Arg := Next_Arg + 1;
end loop;
end Scan_Compiler_Arguments;
-
- -----------------------------------
- -- Switch_Subsequently_Cancelled --
- -----------------------------------
-
- function Switch_Subsequently_Cancelled (C : String) return Boolean is
- Arg : Pos;
-
- begin
- Arg := Next_Arg + 1;
- while Arg < save_argc loop
- declare
- Argv_Ptr : constant Big_String_Ptr := save_argv (Arg);
- Argv_Len : constant Nat := Len_Arg (Arg);
- Argv : constant String :=
- Argv_Ptr (1 .. Natural (Argv_Len));
- begin
- if Argv = "-gnat-" & C then
- return True;
- end if;
- end;
-
- Arg := Arg + 1;
- end loop;
-
- return False;
- end Switch_Subsequently_Cancelled;
-
end Back_End;
-- Any processed switches that influence the result of a compilation must
-- be added to the Compilation_Arguments table.
- function Switch_Subsequently_Cancelled (C : String) return Boolean;
- -- This function is called from Scan_Front_End_Switches. It determines if
- -- the switch currently being scanned is followed by a switch of the form
- -- "-gnat-" & C, where C is the argument. If so, then True is returned,
- -- and Scan_Front_End_Switches will cancel the effect of the switch. If
- -- no such switch is found, False is returned.
-
end Back_End;
ada/get_targ.ads ada/gnat.ads ada/g-htable.ads ada/hostparm.ads \
ada/inline.ads ada/itypes.ads ada/lib.ads ada/namet.ads ada/nlists.ads \
ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \
- ada/restrict.ads ada/restrict.adb ada/rident.ads ada/rtsfind.ads \
- ada/sem.ads ada/sem_aux.ads ada/sem_cat.ads ada/sem_ch13.ads \
- ada/sem_ch3.ads ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_eval.ads \
- ada/sem_eval.adb ada/sem_res.ads ada/sem_scil.ads ada/sem_type.ads \
- ada/sem_util.ads ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb \
- ada/sinput.ads ada/snames.ads ada/sprint.ads ada/stand.ads \
- ada/stringt.ads ada/stringt.adb ada/system.ads ada/s-exctab.ads \
- ada/s-exctab.adb ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \
- ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-soflin.ads \
- ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \
- ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \
- ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \
- ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads ada/types.ads \
- ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \
- ada/unchdeal.ads ada/urealp.ads ada/urealp.adb ada/validsw.ads
+ ada/par_sco.ads ada/restrict.ads ada/restrict.adb ada/rident.ads \
+ ada/rtsfind.ads ada/sem.ads ada/sem_aux.ads ada/sem_cat.ads \
+ ada/sem_ch13.ads ada/sem_ch3.ads ada/sem_ch6.ads ada/sem_ch8.ads \
+ ada/sem_eval.ads ada/sem_eval.adb ada/sem_res.ads ada/sem_scil.ads \
+ ada/sem_type.ads ada/sem_util.ads ada/sem_warn.ads ada/sinfo.ads \
+ ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/sprint.ads \
+ ada/stand.ads ada/stringt.ads ada/stringt.adb ada/system.ads \
+ ada/s-exctab.ads ada/s-exctab.adb ada/s-htable.ads ada/s-imenne.ads \
+ ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \
+ ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \
+ ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \
+ ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \
+ ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads \
+ ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \
+ ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/urealp.adb \
+ ada/validsw.ads
ada/exp_ch5.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \
ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \
ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \
ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads
-ada/put_scos.o : ada/ada.ads ada/a-unccon.ads ada/gnat.ads ada/g-table.ads \
- ada/g-table.adb ada/put_scos.ads ada/put_scos.adb ada/scos.ads \
- ada/system.ads ada/s-exctab.ads ada/s-memory.ads ada/s-stalib.ads \
- ada/s-unstyp.ads ada/types.ads ada/unchconv.ads ada/unchdeal.ads \
- ada/atree.ads ada/sinfo.ads ada/snames.ads
+ada/put_scos.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \
+ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/debug.ads \
+ ada/einfo.ads ada/gnat.ads ada/g-table.ads ada/g-table.adb \
+ ada/hostparm.ads ada/namet.ads ada/opt.ads ada/output.ads \
+ ada/put_scos.ads ada/put_scos.adb ada/scos.ads ada/sinfo.ads \
+ ada/snames.ads ada/system.ads ada/s-exctab.ads ada/s-memory.ads \
+ ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads ada/s-string.ads \
+ ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \
+ ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \
+ ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads
ada/repinfo.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \
ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \
ada/types.ads ada/unchconv.ads ada/unchdeal.ads
ada/switch-c.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \
- ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/gnatvsn.ads \
- ada/hostparm.ads ada/lib.ads ada/namet.ads ada/opt.ads ada/osint.ads \
- ada/output.ads ada/prepcomp.ads ada/sem_warn.ads ada/stylesw.ads \
- ada/switch.ads ada/switch-c.ads ada/switch-c.adb ada/system.ads \
- ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \
- ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \
- ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \
- ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \
- ada/types.ads ada/unchconv.ads ada/unchdeal.ads ada/validsw.ads
+ ada/a-uncdea.ads ada/alloc.ads ada/back_end.ads ada/debug.ads \
+ ada/gnatvsn.ads ada/hostparm.ads ada/lib.ads ada/namet.ads ada/opt.ads \
+ ada/osint.ads ada/output.ads ada/prepcomp.ads ada/sem_warn.ads \
+ ada/stylesw.ads ada/switch.ads ada/switch-c.ads ada/switch-c.adb \
+ ada/system.ads ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads \
+ ada/s-parame.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \
+ ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \
+ ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \
+ ada/tree_io.ads ada/types.ads ada/unchconv.ads ada/unchdeal.ads \
+ ada/validsw.ads
ada/switch.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \
ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/gnatvsn.ads \
EH_MECHANISM=-gcc
GMEM_LIB=gmemlib
+ MISCLIB = -lexc
THREADSLIB = -lpthread -lmach -lexc -lrt
GNATLIB_SHARED = gnatlib-shared-default
LIBRARY_VERSION := $(LIB_VERSION)
declare
Loc : Source_Location;
+ C2v : Character;
begin
-- Acquire location information
Get_Source_Location (Loc);
end if;
+ -- C2 is a space except for pragmas where it is 'e' since
+ -- clearly the pragma is enabled if it was written out.
+
+ if C = 'P' then
+ C2v := 'e';
+ else
+ C2v := ' ';
+ end if;
+
Add_SCO
(C1 => Dtyp,
- C2 => ' ',
+ C2 => C2v,
From => Loc,
To => No_Source_Location,
Last => False);
Table_Increment => 200,
Table_Name => "SCO_Unit_Number_Entry");
- --------------------------
- -- Condition Hash Table --
- --------------------------
+ ---------------------------------
+ -- Condition/Pragma Hash Table --
+ ---------------------------------
-- We need to be able to get to conditions quickly for handling the calls
- -- to Set_SCO_Condition efficiently. For this purpose we identify the
- -- conditions in the table by their starting sloc, and use the following
+ -- to Set_SCO_Condition efficiently, and similarly to get to pragmas to
+ -- handle calls to Set_SCO_Pragma_Enabled. For this purpose we identify the
+ -- conditions and pragmas in the table by their starting sloc, and use this
-- hash table to map from these starting sloc values to SCO_Table indexes.
type Header_Num is new Integer range 0 .. 996;
function Equal (F1, F2 : Source_Ptr) return Boolean;
-- Function to test two keys for equality
- package Condition_Hash_Table is new Simple_HTable
+ package Condition_Pragma_Hash_Table is new Simple_HTable
(Header_Num, Int, 0, Source_Ptr, Hash, Equal);
-- The actual hash table
C2 : Character;
From : Source_Ptr;
To : Source_Ptr;
- Node : Node_Id;
Last : Boolean);
-- Append an entry to SCO_Table with fields set as per arguments
Write_Str (" False");
end if;
- if Present (T.Node) then
- Write_Str (" Node = ");
- Write_Int (Int (T.Node));
- end if;
-
Write_Eol;
end;
end loop;
C2 => ' ',
From => Sloc (N),
To => No_Location,
- Node => Empty,
Last => False);
Output_Decision_Operand (L);
C2 => 'c',
From => FSloc,
To => LSloc,
- Node => Empty,
Last => False);
- Condition_Hash_Table.Set (FSloc, SCO_Table.Last);
+ Condition_Pragma_Hash_Table.Set (FSloc, SCO_Table.Last);
end Output_Element;
-------------------
C2 => ' ',
From => Sloc (Parent (N)),
To => No_Location,
- Node => Empty,
Last => False);
when 'P' =>
- -- For PRAGMA, we must record the pragma node. Argument N
- -- is the pragma argument, and we have to go up two levels
- -- (through the pragma argument association) to get to the
- -- pragma node itself.
+ -- For PRAGMA, we must get the location from the pragma node.
+ -- Argument N is the pragma argument, and we have to go up two
+ -- levels (through the pragma argument association) to get to
+ -- the pragma node itself.
declare
- Pnode : constant Node_Id := Parent (Parent (N));
+ Loc : constant Source_Ptr := Sloc (Parent (Parent (N)));
+
begin
Set_Table_Entry
(C1 => 'P',
- C2 => ' ',
- From => Sloc (Pnode),
+ C2 => 'd',
+ From => Loc,
To => No_Location,
- Node => Pnode,
Last => False);
+
+ -- For pragmas we also must make an entry in the hash table
+ -- for later access by Set_SCO_Pragma_Enabled. We set the
+ -- pragma as disabled above, the call will change C2 to 'e'
+ -- to enable the pragma header entry.
+
+ Condition_Pragma_Hash_Table.Set (Loc, SCO_Table.Last);
end;
when 'X' =>
C2 => ' ',
From => No_Location,
To => No_Location,
- Node => Empty,
Last => False);
-- No other possibilities
(False => 'f', True => 't');
begin
Sloc_Range (Orig, Start, Dummy);
- Index := Condition_Hash_Table.Get (Start);
+ Index := Condition_Pragma_Hash_Table.Get (Start);
+
+ -- The test here for zero is to deal with possible previous errors
if Index /= 0 then
+ pragma Assert (SCO_Table.Table (Index).C1 = ' ');
SCO_Table.Table (Index).C2 := Constant_Condition_Code (Val);
end if;
end Set_SCO_Condition;
+ ----------------------------
+ -- Set_SCO_Pragma_Enabled --
+ ----------------------------
+
+ procedure Set_SCO_Pragma_Enabled (Loc : Source_Ptr) is
+ Index : Nat;
+
+ begin
+ -- Note: the reason we use the Sloc value as the key is that in the
+ -- generic case, the call to this procedure is made on a copy of the
+ -- original node, so we can't use the Node_Id value.
+
+ Index := Condition_Pragma_Hash_Table.Get (Loc);
+
+ -- The test here for zero is to deal with possible previous errors
+
+ if Index /= 0 then
+ pragma Assert (SCO_Table.Table (Index).C1 = 'P');
+ SCO_Table.Table (Index).C2 := 'e';
+ end if;
+ end Set_SCO_Pragma_Enabled;
+
---------------------
-- Set_Table_Entry --
---------------------
C2 : Character;
From : Source_Ptr;
To : Source_Ptr;
- Node : Node_Id;
Last : Boolean)
is
function To_Source_Location (S : Source_Ptr) return Source_Location;
C2 => C2,
From => To_Source_Location (From),
To => To_Source_Location (To),
- Node => Node,
Last => Last);
end Set_Table_Entry;
C2 => SCE.Typ,
From => SCE.From,
To => SCE.To,
- Node => Empty,
Last => (J = SC_Last));
end;
end loop;
C2 => ' ',
From => First,
To => Last,
- Node => Empty,
Last => True);
-- Now output any embedded decisions
Handler : Node_Id;
begin
-
-- For package bodies without a statement part, the parser adds an empty
-- one, to normalize the representation. The null statement therein,
-- which does not come from source, does not get a SCO.
-- by Val. The condition is identified by the First_Sloc value in the
-- original tree associated with Cond.
+ procedure Set_SCO_Pragma_Enabled (Loc : Source_Ptr);
+ -- This procedure is called from Sem_Prag when a pragma is enabled (i.e.
+ -- when the Pragma_Enabled flag is set). Loc is the Sloc of the N_Pragma
+ -- node. This is used to enable the corresponding SCO table entry. Note
+ -- that we use the Sloc as the key here, since in the generic case, the
+ -- analysis is on a copy of the node, which is different from the node
+ -- seen by Par_SCO in the parse tree (but the Sloc values are the same).
+
procedure SCO_Output;
-- Outputs SCO lines for all units, with appropriate section headers, for
-- unit U in the ALI file, as recorded by previous calls to SCO_Record,
-- --
------------------------------------------------------------------------------
-with Atree; use Atree;
-with SCOs; use SCOs;
-with Sinfo; use Sinfo;
+with SCOs; use SCOs;
procedure Put_SCOs is
Ctr : Nat;
when 'I' | 'E' | 'P' | 'W' | 'X' =>
Start := Start + 1;
- -- For disabled pragma, skip decision output. Note that
- -- if the SCO table has been populated by Get_SCOs
- -- (re-reading previously generated SCO information),
- -- then the Node field of pragma entries is Empty. This
- -- is the only way that Node can be Empty, so if we see
- -- an Empty node field, we know the pragma is enabled.
-
- if T.C1 = 'P'
- and then Present (T.Node)
- and then not Pragma_Enabled (Original_Node (T.Node))
- then
+ -- For disabled pragma, skip decision output
+
+ if T.C1 = 'P' and then T.C2 = 'd' then
while not SCO_Table.Table (Start).Last loop
Start := Start + 1;
end loop;
To : Source_Location := No_Source_Location;
C1 : Character := ' ';
C2 : Character := ' ';
- Node : Node_Id := Empty;
Last : Boolean := False)
is
begin
- SCO_Table.Append ((From, To, Node, C1, C2, Last));
+ SCO_Table.Append ((From, To, C1, C2, Last));
end Add_SCO;
----------------
type SCO_Table_Entry is record
From : Source_Location;
To : Source_Location;
- Node : Node_Id;
C1 : Character;
C2 : Character;
Last : Boolean;
-- C2 = statement type code to appear on CS line (or ' ' if none)
-- From = starting source location
-- To = ending source location
- -- Node = Empty
-- Last = False for all but the last entry, True for last entry
-- Note: successive statements (possibly interspersed with entries of
-- C2 = ' '
-- From = IF/EXIT/WHILE token
-- To = No_Source_Location
- -- Node = Empty
-- Last = unused
-- Decision (PRAGMA)
-- C1 = 'P'
- -- C2 = ' '
+ -- C2 = 'e'/'d' for enabled/disabled
-- From = PRAGMA token
-- To = No_Source_Location
- -- Node = N_Pragma node or Empty when reading SCO data (see below)
-- Last = unused
-- Note: when the parse tree is first scanned, we unconditionally build
-- a pragma decision entry for any decision in a pragma (here as always
- -- in SCO contexts, the only relevant pragmas are Assert, Check,
- -- Precondition and Postcondition). Then when we output the SCO info
- -- to the ALI file, we use the Node field to check the Pragma_Enabled
- -- flag, and if it is False, we suppress output of the pragma decision
- -- line. On reading back SCO data from an ALI file, the Node field is
- -- always set to Empty.
+ -- in SCO contexts, the only pragmas with decisions are Assert, Check,
+ -- Precondition and Postcondition), and we mark the pragma as disabled.
+ --
+ -- During analysis, if the pragma is enabled, Set_SCO_Pragma_Enabled to
+ -- mark the SCO decision table entry as enabled (C2 set to 'e'). Then
+ -- in Put_SCOs, we only output the decision for a pragma if C2 is 'e'.
+ --
+ -- When we read SCOs from an ALI file (in Get_SCOs), we always set C2
+ -- to 'e', since clearly the pragma is enabled if it was written out.
-- Decision (Expression)
-- C1 = 'X'
-- C2 = ' '
-- From = No_Source_Location
-- To = No_Source_Location
- -- Node = Empty
-- Last = unused
-- Operator
-- C2 = ' '
-- From = location of NOT/AND/OR token
-- To = No_Source_Location
- -- Node = Empty
-- Last = False
-- Element (condition)
-- C2 = 'c', 't', or 'f' (condition/true/false)
-- From = starting source location
-- To = ending source location
- -- Node = Empty
-- Last = False for all but the last entry, True for last entry
-- Note: the sequence starting with a decision, and continuing with
To : Source_Location := No_Source_Location;
C1 : Character := ' ';
C2 : Character := ' ';
- Node : Node_Id := Empty;
Last : Boolean := False);
-- Adds one entry to SCO table with given field values
-- All other cases than aggregates
else
+
+ -- For pragmas, we propagate the Enabled status for the
+ -- relevant pragmas to the original generic tree. This was
+ -- originally needed for SCO generation. It is no longer
+ -- needed there (since we use the Sloc value in calls to
+ -- Set_SCO_Pragma_Enabled), but it seems a generally good
+ -- idea to have this flag set properly.
+
+ if Nkind (N) = N_Pragma
+ and then
+ (Pragma_Name (N) = Name_Precondition
+ or else Pragma_Name (N) = Name_Postcondition)
+ and then Present (Associated_Node (Pragma_Identifier (N)))
+ then
+ Set_Pragma_Enabled (N,
+ Pragma_Enabled
+ (Parent (Associated_Node (Pragma_Identifier (N)))));
+ end if;
+
Save_Global_Descendant (Field1 (N));
Save_Global_Descendant (Field2 (N));
Save_Global_Descendant (Field3 (N));
with Nmake; use Nmake;
with Opt; use Opt;
with Output; use Output;
+with Par_SCO; use Par_SCO;
with Restrict; use Restrict;
with Rident; use Rident;
with Rtsfind; use Rtsfind;
Pragma_Misplaced;
end if;
- -- Record whether pragma is enabled
+ -- Record if pragma is enabled
- Set_Pragma_Enabled (N, Check_Enabled (Pname));
+ if Check_Enabled (Pname) then
+ Set_Pragma_Enabled (N);
+ Set_SCO_Pragma_Enabled (Loc);
+ end if;
-- If we are within an inlined body, the legality of the pragma
-- has been checked already.
-- is to deal with pragma Assert rewritten as a Check pragma.
Check_On := Check_Enabled (Chars (Get_Pragma_Arg (Arg1)));
- Set_Pragma_Enabled (N, Check_On);
- Set_Pragma_Enabled (Original_Node (N), Check_On);
+
+ if Check_On then
+ Set_Pragma_Enabled (N);
+ Set_Pragma_Enabled (Original_Node (N));
+ Set_SCO_Pragma_Enabled (Loc);
+ end if;
-- If expansion is active and the check is not enabled then we
-- rewrite the Check as:
-- --
------------------------------------------------------------------------------
-with Back_End; use Back_End;
with Debug; use Debug;
with Lib; use Lib;
with Osint; use Osint;
package body Switch.C is
+ type Arg_Array is array (Nat) of Big_String_Ptr;
+ type Arg_Array_Ptr is access Arg_Array;
+ -- Types to access compiler arguments
+
+ save_argc : Nat;
+ pragma Import (C, save_argc);
+ -- Saved value of argc (number of arguments), imported from toplev.c
+
+ save_argv : Arg_Array_Ptr;
+ pragma Import (C, save_argv);
+ -- Saved value of argv (argument pointers), imported from toplev.c
+
RTS_Specified : String_Access := null;
-- Used to detect multiple use of --RTS= flag
+ function Len_Arg (Arg : Pos) return Nat;
+ -- Determine length of argument number Arg on original gnat1 command line
+
+ function Switch_Subsequently_Cancelled
+ (C : String;
+ Arg_Rank : Pos)
+ return Boolean;
+ -- This function is called from Scan_Front_End_Switches. It determines if
+ -- the switch currently being scanned is followed by a switch of the form
+ -- "-gnat-" & C, where C is the argument. If so, then True is returned,
+ -- and Scan_Front_End_Switches will cancel the effect of the switch. If
+ -- no such switch is found, False is returned.
+
+ -------------
+ -- Len_Arg --
+ -------------
+
+ function Len_Arg (Arg : Pos) return Nat is
+ begin
+ for J in 1 .. Nat'Last loop
+ if save_argv (Arg).all (Natural (J)) = ASCII.NUL then
+ return J - 1;
+ end if;
+ end loop;
+
+ raise Program_Error;
+ end Len_Arg;
+
-----------------------------
-- Scan_Front_End_Switches --
-----------------------------
- procedure Scan_Front_End_Switches (Switch_Chars : String) is
+ procedure Scan_Front_End_Switches
+ (Switch_Chars : String;
+ Arg_Rank : Pos)
+ is
First_Switch : Boolean := True;
-- False for all but first switch
-- Skip processing if cancelled by subsequent -gnat-p
- if Switch_Subsequently_Cancelled ("p") then
+ if Switch_Subsequently_Cancelled ("p", Arg_Rank) then
Store_Switch := False;
else
end if;
end Scan_Front_End_Switches;
+ -----------------------------------
+ -- Switch_Subsequently_Cancelled --
+ -----------------------------------
+
+ function Switch_Subsequently_Cancelled
+ (C : String;
+ Arg_Rank : Pos)
+ return Boolean
+ is
+ Arg : Pos;
+
+ begin
+ Arg := Arg_Rank + 1;
+ while Arg < save_argc loop
+ declare
+ Argv_Ptr : constant Big_String_Ptr := save_argv (Arg);
+ Argv_Len : constant Nat := Len_Arg (Arg);
+ Argv : constant String :=
+ Argv_Ptr (1 .. Natural (Argv_Len));
+ begin
+ if Argv = "-gnat-" & C then
+ return True;
+ end if;
+ end;
+
+ Arg := Arg + 1;
+ end loop;
+
+ return False;
+ end Switch_Subsequently_Cancelled;
+
end Switch.C;
-- --
-- S p e c --
-- --
--- Copyright (C) 2001-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2009, 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- --
package Switch.C is
- procedure Scan_Front_End_Switches (Switch_Chars : String);
+ procedure Scan_Front_End_Switches
+ (Switch_Chars : String;
+ Arg_Rank : Pos);
-- Procedures to scan out front end switches stored in the given string.
-- The first character is known to be a valid switch character, and there
-- are no blanks or other switch terminator characters in the string, so
-- the entire string should consist of valid switch characters, except that
-- an optional terminating NUL character is allowed. A bad switch causes
-- a fatal error exit and control does not return. The call also sets
- -- Usage_Requested to True if a ? switch is encountered.
+ -- Usage_Requested to True if a switch -gnath is encountered.
+ -- Arg_Rank is the position of the switch in the command line arguments.
+ -- It is used for certain switches -gnatx to check if a subsequent switch
+ -- -gnat-x cancels the switch -gnatx.
end Switch.C;
OSDN Git Service
