diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 29 | ||||
| -rw-r--r-- | gcc/ada/back_end.adb | 38 | ||||
| -rw-r--r-- | gcc/ada/back_end.ads | 7 | ||||
| -rw-r--r-- | gcc/ada/gcc-interface/Make-lang.in | 65 | ||||
| -rw-r--r-- | gcc/ada/gcc-interface/Makefile.in | 1 | ||||
| -rw-r--r-- | gcc/ada/get_scos.adb | 12 | ||||
| -rw-r--r-- | gcc/ada/par_sco.adb | 80 | ||||
| -rw-r--r-- | gcc/ada/par_sco.ads | 8 | ||||
| -rw-r--r-- | gcc/ada/put_scos.adb | 18 | ||||
| -rw-r--r-- | gcc/ada/scos.adb | 3 | ||||
| -rw-r--r-- | gcc/ada/scos.ads | 25 | ||||
| -rw-r--r-- | gcc/ada/sem_ch12.adb | 19 | ||||
| -rw-r--r-- | gcc/ada/sem_prag.adb | 16 | ||||
| -rw-r--r-- | gcc/ada/switch-c.adb | 79 | ||||
| -rw-r--r-- | gcc/ada/switch-c.ads | 11 |
15 files changed, 269 insertions, 142 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index cfc39d0..2d47168 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,32 @@ +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 diff --git a/gcc/ada/back_end.adb b/gcc/ada/back_end.adb index 47836cb..974c4b3 100644 --- a/gcc/ada/back_end.adb +++ b/gcc/ada/back_end.adb @@ -46,10 +46,6 @@ package body Back_End is 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 @@ -166,6 +162,9 @@ package body Back_End is 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" @@ -232,6 +231,7 @@ package body Back_End is -- 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); @@ -284,7 +284,7 @@ package body Back_End is 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 @@ -296,32 +296,4 @@ package body Back_End is 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; diff --git a/gcc/ada/back_end.ads b/gcc/ada/back_end.ads index a9108f5..fb11939 100644 --- a/gcc/ada/back_end.ads +++ b/gcc/ada/back_end.ads @@ -61,11 +61,4 @@ package Back_End is -- 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; diff --git a/gcc/ada/gcc-interface/Make-lang.in b/gcc/ada/gcc-interface/Make-lang.in index fdd7506..ac68435 100644 --- a/gcc/ada/gcc-interface/Make-lang.in +++ b/gcc/ada/gcc-interface/Make-lang.in @@ -1834,21 +1834,22 @@ ada/exp_ch4.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ 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 \ @@ -2911,11 +2912,16 @@ ada/prepcomp.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ 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 \ @@ -4194,15 +4200,16 @@ ada/switch-b.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ 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 \ diff --git a/gcc/ada/gcc-interface/Makefile.in b/gcc/ada/gcc-interface/Makefile.in index 2740d35..47bf9fd 100644 --- a/gcc/ada/gcc-interface/Makefile.in +++ b/gcc/ada/gcc-interface/Makefile.in @@ -1451,6 +1451,7 @@ ifeq ($(strip $(filter-out alpha% dec osf%,$(targ))),) EH_MECHANISM=-gcc GMEM_LIB=gmemlib + MISCLIB = -lexc THREADSLIB = -lpthread -lmach -lexc -lrt GNATLIB_SHARED = gnatlib-shared-default LIBRARY_VERSION := $(LIB_VERSION) diff --git a/gcc/ada/get_scos.adb b/gcc/ada/get_scos.adb index 04fbd51..70d77c8 100644 --- a/gcc/ada/get_scos.adb +++ b/gcc/ada/get_scos.adb @@ -315,6 +315,7 @@ begin declare Loc : Source_Location; + C2v : Character; begin -- Acquire location information @@ -325,9 +326,18 @@ begin 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); diff --git a/gcc/ada/par_sco.adb b/gcc/ada/par_sco.adb index 5b5e4cf..d0b2a9f 100644 --- a/gcc/ada/par_sco.adb +++ b/gcc/ada/par_sco.adb @@ -63,13 +63,14 @@ package body Par_SCO is 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; @@ -81,7 +82,7 @@ package body Par_SCO is 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 @@ -116,7 +117,6 @@ package body Par_SCO is 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 @@ -232,11 +232,6 @@ package body Par_SCO is 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; @@ -409,7 +404,6 @@ package body Par_SCO is C2 => ' ', From => Sloc (N), To => No_Location, - Node => Empty, Last => False); Output_Decision_Operand (L); @@ -436,9 +430,8 @@ package body Par_SCO is 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; ------------------- @@ -458,26 +451,32 @@ package body Par_SCO is 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' => @@ -489,7 +488,6 @@ package body Par_SCO is C2 => ' ', From => No_Location, To => No_Location, - Node => Empty, Last => False); -- No other possibilities @@ -821,13 +819,38 @@ package body Par_SCO is (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 -- --------------------- @@ -837,7 +860,6 @@ package body Par_SCO is C2 : Character; From : Source_Ptr; To : Source_Ptr; - Node : Node_Id; Last : Boolean) is function To_Source_Location (S : Source_Ptr) return Source_Location; @@ -866,7 +888,6 @@ package body Par_SCO is C2 => C2, From => To_Source_Location (From), To => To_Source_Location (To), - Node => Node, Last => Last); end Set_Table_Entry; @@ -1001,7 +1022,6 @@ package body Par_SCO is C2 => SCE.Typ, From => SCE.From, To => SCE.To, - Node => Empty, Last => (J = SC_Last)); end; end loop; @@ -1397,7 +1417,6 @@ package body Par_SCO is C2 => ' ', From => First, To => Last, - Node => Empty, Last => True); -- Now output any embedded decisions @@ -1423,7 +1442,6 @@ package body Par_SCO is 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. diff --git a/gcc/ada/par_sco.ads b/gcc/ada/par_sco.ads index 9bbe04f..97e4a6a 100644 --- a/gcc/ada/par_sco.ads +++ b/gcc/ada/par_sco.ads @@ -49,6 +49,14 @@ package Par_SCO is -- 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, diff --git a/gcc/ada/put_scos.adb b/gcc/ada/put_scos.adb index db608af..9d3bcd7 100644 --- a/gcc/ada/put_scos.adb +++ b/gcc/ada/put_scos.adb @@ -23,9 +23,7 @@ -- -- ------------------------------------------------------------------------------ -with Atree; use Atree; -with SCOs; use SCOs; -with Sinfo; use Sinfo; +with SCOs; use SCOs; procedure Put_SCOs is Ctr : Nat; @@ -147,17 +145,9 @@ begin 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; diff --git a/gcc/ada/scos.adb b/gcc/ada/scos.adb index 3c0caee..c559e6f 100644 --- a/gcc/ada/scos.adb +++ b/gcc/ada/scos.adb @@ -34,11 +34,10 @@ package body SCOs is 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; ---------------- diff --git a/gcc/ada/scos.ads b/gcc/ada/scos.ads index 9e6a973..dc02e28 100644 --- a/gcc/ada/scos.ads +++ b/gcc/ada/scos.ads @@ -286,7 +286,6 @@ package SCOs is type SCO_Table_Entry is record From : Source_Location; To : Source_Location; - Node : Node_Id; C1 : Character; C2 : Character; Last : Boolean; @@ -306,7 +305,6 @@ package SCOs is -- 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 @@ -321,32 +319,32 @@ package SCOs is -- 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 @@ -354,7 +352,6 @@ package SCOs is -- C2 = ' ' -- From = location of NOT/AND/OR token -- To = No_Source_Location - -- Node = Empty -- Last = False -- Element (condition) @@ -362,7 +359,6 @@ package SCOs is -- 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 @@ -415,7 +411,6 @@ package SCOs is 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 diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index faff561..db3eac6 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -12223,6 +12223,25 @@ package body Sem_Ch12 is -- 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)); diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 0e8157a..147a920 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -46,6 +46,7 @@ with Nlists; use Nlists; 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; @@ -1393,9 +1394,12 @@ package body Sem_Prag is 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. @@ -5776,8 +5780,12 @@ package body Sem_Prag is -- 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: diff --git a/gcc/ada/switch-c.adb b/gcc/ada/switch-c.adb index 8beaec8..1ad7c3c 100644 --- a/gcc/ada/switch-c.adb +++ b/gcc/ada/switch-c.adb @@ -23,7 +23,6 @@ -- -- ------------------------------------------------------------------------------ -with Back_End; use Back_End; with Debug; use Debug; with Lib; use Lib; with Osint; use Osint; @@ -39,14 +38,57 @@ with System.WCh_Con; use System.WCh_Con; 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 @@ -665,7 +707,7 @@ package body Switch.C is -- 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 @@ -1078,4 +1120,35 @@ package body Switch.C is 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; diff --git a/gcc/ada/switch-c.ads b/gcc/ada/switch-c.ads index 09ac49e..126183e 100644 --- a/gcc/ada/switch-c.ads +++ b/gcc/ada/switch-c.ads @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -31,13 +31,18 @@ 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; |