+2013-04-11 Arnaud Charlet <charlet@adacore.com>
+
+ * xgnatugn.adb: Remove obsolete comments.
+
+2013-04-11 Robert Dewar <dewar@adacore.com>
+
+ * back_end.ads, back_end.adb: Minor reformatting.
+ * set_targ.ads, set_targ.adb: New files.
+
+2013-04-11 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_case.adb (Check_Against_Predicate): New routine.
+ (Check_Choices): When the type covered by the list of choices
+ is a static subtype with a static predicate, check all choices
+ agains the predicate.
+ (Issue_Msg): All versions removed.
+ (Missing_Choice): New routines.
+ * sem_ch4.adb: Code and comment reformatting.
+ (Analyze_Case_Expression): Do not check the choices when the case
+ expression is being preanalyzed and the type of the expression
+ is a subtype with a static predicate.
+ (Has_Static_Predicate): New routine.
+ * sem_ch13.adb: Code and comment reformatting. (Build_Range):
+ Always build a range even if the low and hi bounds denote the
+ same value. This is needed by the machinery in Check_Choices.
+ (Build_Static_Predicate): Always build a range even if the low and
+ hi bounds denote the same value. This is needed by the machinery
+ in Check_Choices.
+
2013-04-11 Robert Dewar <dewar@adacore.com>
* einfo.ads, sem_util.adb, exp_ch6.adb, xgnatugn.adb: Minor
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2013, 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- --
procedure Register_Back_End_Types (Call_Back : Register_Type_Proc) is
procedure Enumerate_Modes (Call_Back : Register_Type_Proc);
pragma Import (C, Enumerate_Modes, "enumerate_modes");
-
begin
Enumerate_Modes (Call_Back);
end Register_Back_End_Types;
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2013, 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- --
------------------------------------------------------------------------------
-- Call the back end with all the information needed. Also contains other
--- back-end specific interfaces required by the front end.
+-- back-end specific interfaces required by the front end. See also Get_Targ,
+-- which defines additional interfaces to the back end.
with Einfo; use Einfo;
-- the back end.
procedure Register_Back_End_Types (Call_Back : Register_Type_Proc);
- -- Calls the Call_Back function with information for each supported type.
+ -- Calls the Call_Back function with information for each supported type
procedure Call_Back_End (Mode : Back_End_Mode_Type);
-- Call back end, i.e. make call to driver traversing the tree and
- -- outputting code. This call is made with all tables locked.
- -- The back end is responsible for unlocking any tables it may need
- -- to change, and locking them again before returning.
+ -- outputting code. This call is made with all tables locked. The back
+ -- end is responsible for unlocking any tables it may need to change,
+ -- and locking them again before returning.
procedure Scan_Compiler_Arguments;
-- Acquires command-line parameters passed to the compiler and processes
-- --
-- B o d y --
-- --
--- Copyright (C) 1996-2012, Free Software Foundation, Inc. --
+-- Copyright (C) 1996-2013, 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- --
Others_Present : Boolean;
Case_Node : Node_Id)
is
+ procedure Check_Against_Predicate
+ (Pred : in out Node_Id;
+ Choice : Choice_Bounds;
+ Prev_Lo : in out Uint;
+ Prev_Hi : in out Uint;
+ Error : in out Boolean);
+ -- Determine whether a choice covers legal values as defined by a static
+ -- predicate set. Pred is a static predicate range. Choice is the choice
+ -- to be examined. Prev_Lo and Prev_Hi are the bounds of the previous
+ -- choice that covered a predicate set. Error denotes whether the check
+ -- found an illegal intersection.
+
procedure Explain_Non_Static_Bound;
-- Called when we find a non-static bound, requiring the base type to
-- be covered. Provides where possible a helpful explanation of why the
-- Comparison routine for comparing Choice_Table entries. Use the lower
-- bound of each Choice as the key.
+ procedure Missing_Choice (Value1 : Node_Id; Value2 : Node_Id);
+ procedure Missing_Choice (Value1 : Node_Id; Value2 : Uint);
+ procedure Missing_Choice (Value1 : Uint; Value2 : Node_Id);
+ procedure Missing_Choice (Value1 : Uint; Value2 : Uint);
+ -- Issue an error message indicating that there are missing choices,
+ -- followed by the image of the missing choices themselves which lie
+ -- between Value1 and Value2 inclusive.
+
+ procedure Missing_Choices (Pred : Node_Id; Prev_Hi : Uint);
+ -- Emit an error message for each non-covered static predicate set.
+ -- Prev_Hi denotes the upper bound of the last choice that covered a
+ -- set.
+
procedure Move_Choice (From : Natural; To : Natural);
-- Move routine for sorting the Choice_Table
package Sorting is new GNAT.Heap_Sort_G (Move_Choice, Lt_Choice);
- procedure Issue_Msg (Value1 : Node_Id; Value2 : Node_Id);
- procedure Issue_Msg (Value1 : Node_Id; Value2 : Uint);
- procedure Issue_Msg (Value1 : Uint; Value2 : Node_Id);
- procedure Issue_Msg (Value1 : Uint; Value2 : Uint);
- -- Issue an error message indicating that there are missing choices,
- -- followed by the image of the missing choices themselves which lie
- -- between Value1 and Value2 inclusive.
+ -----------------------------
+ -- Check_Against_Predicate --
+ -----------------------------
- ---------------
- -- Issue_Msg --
- ---------------
+ procedure Check_Against_Predicate
+ (Pred : in out Node_Id;
+ Choice : Choice_Bounds;
+ Prev_Lo : in out Uint;
+ Prev_Hi : in out Uint;
+ Error : in out Boolean)
+ is
+ procedure Illegal_Range
+ (Loc : Source_Ptr;
+ Lo : Uint;
+ Hi : Uint);
+ -- Emit an error message regarding a choice that clashes with the
+ -- legal static predicate sets. Loc is the location of the choice
+ -- that introduced the illegal range. Lo .. Hi is the range.
+
+ function Inside_Range
+ (Lo : Uint;
+ Hi : Uint;
+ Val : Uint) return Boolean;
+ -- Determine whether position Val within a discrete type is within
+ -- the range Lo .. Hi inclusive.
+
+ -------------------
+ -- Illegal_Range --
+ -------------------
+
+ procedure Illegal_Range
+ (Loc : Source_Ptr;
+ Lo : Uint;
+ Hi : Uint)
+ is
+ begin
+ Error_Msg_Name_1 := Chars (Bounds_Type);
- procedure Issue_Msg (Value1 : Node_Id; Value2 : Node_Id) is
- begin
- Issue_Msg (Expr_Value (Value1), Expr_Value (Value2));
- end Issue_Msg;
+ -- Single value
- procedure Issue_Msg (Value1 : Node_Id; Value2 : Uint) is
- begin
- Issue_Msg (Expr_Value (Value1), Value2);
- end Issue_Msg;
+ if Lo = Hi then
+ if Is_Integer_Type (Bounds_Type) then
+ Error_Msg_Uint_1 := Lo;
+ Error_Msg ("static predicate on % excludes value ^!", Loc);
+ else
+ Error_Msg_Name_2 := Choice_Image (Lo, Bounds_Type);
+ Error_Msg ("static predicate on % excludes value %!", Loc);
+ end if;
- procedure Issue_Msg (Value1 : Uint; Value2 : Node_Id) is
- begin
- Issue_Msg (Value1, Expr_Value (Value2));
- end Issue_Msg;
+ -- Range
- procedure Issue_Msg (Value1 : Uint; Value2 : Uint) is
- Msg_Sloc : constant Source_Ptr := Sloc (Case_Node);
+ else
+ if Is_Integer_Type (Bounds_Type) then
+ Error_Msg_Uint_1 := Lo;
+ Error_Msg_Uint_2 := Hi;
+ Error_Msg
+ ("static predicate on % excludes range ^ .. ^!", Loc);
+ else
+ Error_Msg_Name_2 := Choice_Image (Lo, Bounds_Type);
+ Error_Msg_Name_3 := Choice_Image (Hi, Bounds_Type);
+ Error_Msg
+ ("static predicate on % excludes range % .. %!", Loc);
+ end if;
+ end if;
+ end Illegal_Range;
+
+ ------------------
+ -- Inside_Range --
+ ------------------
+
+ function Inside_Range
+ (Lo : Uint;
+ Hi : Uint;
+ Val : Uint) return Boolean
+ is
+ begin
+ return
+ Val = Lo or else Val = Hi or else (Lo < Val and then Val < Hi);
+ end Inside_Range;
+
+ -- Local variables
+
+ Choice_Hi : constant Uint := Expr_Value (Choice.Hi);
+ Choice_Lo : constant Uint := Expr_Value (Choice.Lo);
+ Loc : Source_Ptr;
+ Next_Hi : Uint;
+ Next_Lo : Uint;
+ Pred_Hi : Uint;
+ Pred_Lo : Uint;
+
+ -- Start of processing for Check_Against_Predicate
begin
- -- AI05-0188 : within an instance the non-others choices do not
- -- have to belong to the actual subtype.
+ -- Find the proper error message location
- if Ada_Version >= Ada_2012 and then In_Instance then
- return;
+ if Present (Choice.Node) then
+ Loc := Sloc (Choice.Node);
+ else
+ Loc := Sloc (Case_Node);
end if;
- -- In some situations, we call this with a null range, and
- -- obviously we don't want to complain in this case!
+ if Present (Pred) then
+ Pred_Lo := Expr_Value (Low_Bound (Pred));
+ Pred_Hi := Expr_Value (High_Bound (Pred));
+
+ -- Previous choices managed to satisfy all static predicate sets
+
+ else
+ Illegal_Range (Loc, Choice_Lo, Choice_Hi);
+ Error := True;
- if Value1 > Value2 then
return;
end if;
- -- Case of only one value that is missing
+ -- Step 1: Detect duplicate choices
- if Value1 = Value2 then
- if Is_Integer_Type (Bounds_Type) then
- Error_Msg_Uint_1 := Value1;
- Error_Msg ("missing case value: ^!", Msg_Sloc);
+ if Inside_Range (Choice_Lo, Choice_Hi, Prev_Lo)
+ or else Inside_Range (Choice_Lo, Choice_Hi, Prev_Hi)
+ then
+ Error_Msg ("duplication of choice value", Loc);
+ Error := True;
+
+ -- Step 2: Detect full coverage
+
+ -- Choice_Lo Choice_Hi
+ -- +============+
+ -- Pred_Lo Pred_Hi
+
+ elsif Choice_Lo = Pred_Lo and then Choice_Hi = Pred_Hi then
+ Prev_Lo := Choice_Lo;
+ Prev_Hi := Choice_Hi;
+ Next (Pred);
+
+ -- Step 3: Detect all cases where a choice mentions values that are
+ -- not part of the static predicate sets.
+
+ -- Choice_Lo Choice_Hi Pred_Lo Pred_Hi
+ -- +-----------+ . . . . . +=========+
+ -- ^ illegal ^
+
+ elsif Choice_Lo < Pred_Lo and then Choice_Hi < Pred_Lo then
+ Illegal_Range (Loc, Choice_Lo, Choice_Hi);
+ Error := True;
+
+ -- Choice_Lo Pred_Lo Choice_Hi Pred_Hi
+ -- +-----------+=========+===========+
+ -- ^ illegal ^
+
+ elsif Choice_Lo < Pred_Lo
+ and then Inside_Range (Pred_Lo, Pred_Hi, Choice_Hi)
+ then
+ Illegal_Range (Loc, Choice_Lo, Pred_Lo - 1);
+ Error := True;
+
+ -- Pred_Lo Pred_Hi Choice_Lo Choice_Hi
+ -- +=========+ . . . . +-----------+
+ -- ^ illegal ^
+
+ elsif Pred_Lo < Choice_Lo and then Pred_Hi < Choice_Lo then
+ Missing_Choice (Pred_Lo, Pred_Hi);
+ Error := True;
+
+ -- There may be several static predicate sets between the current
+ -- one and the choice. Inspect the next static predicate set.
+
+ Next (Pred);
+ Check_Against_Predicate
+ (Pred => Pred,
+ Choice => Choice,
+ Prev_Lo => Prev_Lo,
+ Prev_Hi => Prev_Hi,
+ Error => Error);
+
+ -- Pred_Lo Choice_Lo Pred_Hi Choice_Hi
+ -- +=========+===========+-----------+
+ -- ^ illegal ^
+
+ elsif Pred_Hi < Choice_Hi
+ and then Inside_Range (Pred_Lo, Pred_Hi, Choice_Lo)
+ then
+ Next (Pred);
+
+ -- The choice may fall in a static predicate set. If this is the
+ -- case, avoid mentioning legal values in the error message.
+
+ if Present (Pred) then
+ Next_Lo := Expr_Value (Low_Bound (Pred));
+ Next_Hi := Expr_Value (High_Bound (Pred));
+
+ -- The next static predicate set is to the right of the choice
+
+ if Choice_Hi < Next_Lo and then Choice_Hi < Next_Hi then
+ Illegal_Range (Loc, Pred_Hi + 1, Choice_Hi);
+ else
+ Illegal_Range (Loc, Pred_Hi + 1, Next_Lo - 1);
+ end if;
else
- Error_Msg_Name_1 := Choice_Image (Value1, Bounds_Type);
- Error_Msg ("missing case value: %!", Msg_Sloc);
+ Illegal_Range (Loc, Pred_Hi + 1, Choice_Hi);
end if;
- -- More than one choice value, so print range of values
+ Error := True;
+
+ -- Choice_Lo Pred_Lo Pred_Hi Choice_Hi
+ -- +-----------+=========+-----------+
+ -- ^ illegal ^ ^ illegal ^
+
+ -- Emit an error on the low gap, disregard the upper gap
+
+ elsif Choice_Lo < Pred_Lo and then Pred_Hi < Choice_Hi then
+ Illegal_Range (Loc, Choice_Lo, Pred_Lo - 1);
+ Error := True;
+
+ -- Step 4: Detect all cases of partial or missing coverage
+
+ -- Pred_Lo Choice_Lo Choice_Hi Pred_Hi
+ -- +=========+==========+===========+
+ -- ^ gap ^ ^ gap ^
else
- if Is_Integer_Type (Bounds_Type) then
- Error_Msg_Uint_1 := Value1;
- Error_Msg_Uint_2 := Value2;
- Error_Msg ("missing case values: ^ .. ^!", Msg_Sloc);
- else
- Error_Msg_Name_1 := Choice_Image (Value1, Bounds_Type);
- Error_Msg_Name_2 := Choice_Image (Value2, Bounds_Type);
- Error_Msg ("missing case values: % .. %!", Msg_Sloc);
- end if;
- end if;
- end Issue_Msg;
+ -- An "others" choice covers all gaps
- ---------------
- -- Lt_Choice --
- ---------------
+ if Others_Present then
+ Prev_Lo := Choice_Lo;
+ Prev_Hi := Choice_Hi;
+ Next (Pred);
- function Lt_Choice (C1, C2 : Natural) return Boolean is
- begin
- return
- Expr_Value (Choice_Table (Nat (C1)).Lo)
- <
- Expr_Value (Choice_Table (Nat (C2)).Lo);
- end Lt_Choice;
+ -- Choice_Lo Choice_Hi Pred_Hi
+ -- +===========+===========+
+ -- Pred_Lo ^ gap ^
- -----------------
- -- Move_Choice --
- -----------------
+ -- The upper gap may be covered by a subsequent choice
- procedure Move_Choice (From : Natural; To : Natural) is
- begin
- Choice_Table (Nat (To)) := Choice_Table (Nat (From));
- end Move_Choice;
+ elsif Pred_Lo = Choice_Lo then
+ Prev_Lo := Choice_Lo;
+ Prev_Hi := Choice_Hi;
+
+ -- Pred_Lo Prev_Hi Choice_Lo Choice_Hi Pred_Hi
+ -- +===========+=========+===========+===========+
+ -- ^ covered ^ ^ gap ^
+
+ else pragma Assert (Pred_Lo < Choice_Lo);
+
+ -- A previous choice covered the gap up to the current choice
+
+ if Prev_Hi = Choice_Lo - 1 then
+ Prev_Lo := Choice_Lo;
+ Prev_Hi := Choice_Hi;
+
+ if Choice_Hi = Pred_Hi then
+ Next (Pred);
+ end if;
+
+ -- The previous choice did not intersect with the current
+ -- static predicate set.
+
+ elsif Prev_Hi < Pred_Lo then
+ Missing_Choice (Pred_Lo, Choice_Lo - 1);
+ Error := True;
+
+ -- The previous choice covered part of the static predicate set
+
+ else
+ Missing_Choice (Prev_Hi, Choice_Lo - 1);
+ Error := True;
+ end if;
+ end if;
+ end if;
+ end Check_Against_Predicate;
------------------------------
-- Explain_Non_Static_Bound --
if Bounds_Type /= Subtyp then
- -- If the case is a variant part, the expression is given by
- -- the discriminant itself, and the bounds are the culprits.
+ -- If the case is a variant part, the expression is given by the
+ -- discriminant itself, and the bounds are the culprits.
if Nkind (Case_Node) = N_Variant_Part then
Error_Msg_NE
("bounds of & are not static," &
" alternatives must cover base type", Expr, Expr);
- -- If this is a case statement, the expression may be
- -- non-static or else the subtype may be at fault.
+ -- If this is a case statement, the expression may be non-static
+ -- or else the subtype may be at fault.
elsif Is_Entity_Name (Expr) then
Error_Msg_NE
end if;
end Explain_Non_Static_Bound;
- -- Variables local to Check_Choices
+ ---------------
+ -- Lt_Choice --
+ ---------------
+
+ function Lt_Choice (C1, C2 : Natural) return Boolean is
+ begin
+ return
+ Expr_Value (Choice_Table (Nat (C1)).Lo)
+ <
+ Expr_Value (Choice_Table (Nat (C2)).Lo);
+ end Lt_Choice;
+
+ --------------------
+ -- Missing_Choice --
+ --------------------
- Choice : Node_Id;
- Bounds_Lo : constant Node_Id := Type_Low_Bound (Bounds_Type);
- Bounds_Hi : constant Node_Id := Type_High_Bound (Bounds_Type);
+ procedure Missing_Choice (Value1 : Node_Id; Value2 : Node_Id) is
+ begin
+ Missing_Choice (Expr_Value (Value1), Expr_Value (Value2));
+ end Missing_Choice;
- Prev_Choice : Node_Id;
+ procedure Missing_Choice (Value1 : Node_Id; Value2 : Uint) is
+ begin
+ Missing_Choice (Expr_Value (Value1), Value2);
+ end Missing_Choice;
+
+ procedure Missing_Choice (Value1 : Uint; Value2 : Node_Id) is
+ begin
+ Missing_Choice (Value1, Expr_Value (Value2));
+ end Missing_Choice;
+
+ procedure Missing_Choice (Value1 : Uint; Value2 : Uint) is
+ Msg_Sloc : constant Source_Ptr := Sloc (Case_Node);
+
+ begin
+ -- AI05-0188 : within an instance the non-others choices do not have
+ -- to belong to the actual subtype.
+
+ if Ada_Version >= Ada_2012 and then In_Instance then
+ return;
+
+ -- In some situations, we call this with a null range, and obviously
+ -- we don't want to complain in this case.
+
+ elsif Value1 > Value2 then
+ return;
+ end if;
+
+ -- Case of only one value that is missing
+
+ if Value1 = Value2 then
+ if Is_Integer_Type (Bounds_Type) then
+ Error_Msg_Uint_1 := Value1;
+ Error_Msg ("missing case value: ^!", Msg_Sloc);
+ else
+ Error_Msg_Name_1 := Choice_Image (Value1, Bounds_Type);
+ Error_Msg ("missing case value: %!", Msg_Sloc);
+ end if;
+
+ -- More than one choice value, so print range of values
+
+ else
+ if Is_Integer_Type (Bounds_Type) then
+ Error_Msg_Uint_1 := Value1;
+ Error_Msg_Uint_2 := Value2;
+ Error_Msg ("missing case values: ^ .. ^!", Msg_Sloc);
+ else
+ Error_Msg_Name_1 := Choice_Image (Value1, Bounds_Type);
+ Error_Msg_Name_2 := Choice_Image (Value2, Bounds_Type);
+ Error_Msg ("missing case values: % .. %!", Msg_Sloc);
+ end if;
+ end if;
+ end Missing_Choice;
+
+ ---------------------
+ -- Missing_Choices --
+ ---------------------
- Hi : Uint;
- Lo : Uint;
- Prev_Hi : Uint;
+ procedure Missing_Choices (Pred : Node_Id; Prev_Hi : Uint) is
+ Hi : Uint;
+ Lo : Uint;
+ Set : Node_Id;
+
+ begin
+ Set := Pred;
+ while Present (Set) loop
+ Lo := Expr_Value (Low_Bound (Set));
+ Hi := Expr_Value (High_Bound (Set));
+
+ -- A choice covered part of a static predicate set
+
+ if Lo <= Prev_Hi and then Prev_Hi < Hi then
+ Missing_Choice (Prev_Hi + 1, Hi);
+
+ else
+ Missing_Choice (Lo, Hi);
+ end if;
+
+ Next (Set);
+ end loop;
+ end Missing_Choices;
+
+ -----------------
+ -- Move_Choice --
+ -----------------
+
+ procedure Move_Choice (From : Natural; To : Natural) is
+ begin
+ Choice_Table (Nat (To)) := Choice_Table (Nat (From));
+ end Move_Choice;
+
+ -- Local variables
+
+ Bounds_Hi : constant Node_Id := Type_High_Bound (Bounds_Type);
+ Bounds_Lo : constant Node_Id := Type_Low_Bound (Bounds_Type);
+ Has_Predicate : constant Boolean :=
+ Is_Static_Subtype (Bounds_Type)
+ and then Present (Static_Predicate (Bounds_Type));
+ Num_Choices : constant Nat := Choice_Table'Last;
+
+ Choice : Node_Id;
+ Choice_Hi : Uint;
+ Choice_Lo : Uint;
+ Error : Boolean;
+ Pred : Node_Id;
+ Prev_Choice : Node_Id;
+ Prev_Lo : Uint;
+ Prev_Hi : Uint;
-- Start of processing for Check_Choices
begin
- -- Choice_Table must start at 0 which is an unused location used
- -- by the sorting algorithm. However the first valid position for
- -- a discrete choice is 1.
+ -- Choice_Table must start at 0 which is an unused location used by the
+ -- sorting algorithm. However the first valid position for a discrete
+ -- choice is 1.
pragma Assert (Choice_Table'First = 0);
- if Choice_Table'Last = 0 then
+ -- The choices do not cover the base range. Emit an error if "others" is
+ -- not available and return as there is no need for further processing.
+
+ if Num_Choices = 0 then
if not Others_Present then
- Issue_Msg (Bounds_Lo, Bounds_Hi);
+ Missing_Choice (Bounds_Lo, Bounds_Hi);
end if;
return;
Sorting.Sort (Positive (Choice_Table'Last));
- Lo := Expr_Value (Choice_Table (1).Lo);
- Hi := Expr_Value (Choice_Table (1).Hi);
- Prev_Hi := Hi;
+ -- The type covered by the list of choices is actually a static subtype
+ -- subject to a static predicate. The predicate defines subsets of legal
+ -- values and requires finer grained analysis.
+
+ if Has_Predicate then
+ Pred := First (Static_Predicate (Bounds_Type));
+ Prev_Lo := Uint_Minus_1;
+ Prev_Hi := Uint_Minus_1;
+ Error := False;
+
+ for Index in 1 .. Num_Choices loop
+ Check_Against_Predicate
+ (Pred => Pred,
+ Choice => Choice_Table (Index),
+ Prev_Lo => Prev_Lo,
+ Prev_Hi => Prev_Hi,
+ Error => Error);
+
+ -- The analysis detected an illegal intersection between a choice
+ -- and a static predicate set.
- if not Others_Present and then Expr_Value (Bounds_Lo) < Lo then
- Issue_Msg (Bounds_Lo, Lo - 1);
+ if Error then
+ return;
+ end if;
+ end loop;
- -- If values are missing outside of the subtype, add explanation.
- -- No additional message if only one value is missing.
+ -- The choices may legally cover some of the static predicate sets,
+ -- but not all. Emit an error for each non-covered set.
- if Expr_Value (Bounds_Lo) < Lo - 1 then
- Explain_Non_Static_Bound;
+ if not Others_Present then
+ Missing_Choices (Pred, Prev_Hi);
end if;
- end if;
- for J in 2 .. Choice_Table'Last loop
- Lo := Expr_Value (Choice_Table (J).Lo);
- Hi := Expr_Value (Choice_Table (J).Hi);
+ -- Default analysis
- if Lo <= Prev_Hi then
- Choice := Choice_Table (J).Node;
+ else
+ Choice_Lo := Expr_Value (Choice_Table (1).Lo);
+ Choice_Hi := Expr_Value (Choice_Table (1).Hi);
+ Prev_Hi := Choice_Hi;
- -- Find first previous choice that overlaps
+ if not Others_Present and then Expr_Value (Bounds_Lo) < Choice_Lo then
+ Missing_Choice (Bounds_Lo, Choice_Lo - 1);
- for K in 1 .. J - 1 loop
- if Lo <= Expr_Value (Choice_Table (K).Hi) then
- Prev_Choice := Choice_Table (K).Node;
- exit;
- end if;
- end loop;
+ -- If values are missing outside of the subtype, add explanation.
+ -- No additional message if only one value is missing.
- if Sloc (Prev_Choice) <= Sloc (Choice) then
- Error_Msg_Sloc := Sloc (Prev_Choice);
- Error_Msg_N ("duplication of choice value#", Choice);
- else
- Error_Msg_Sloc := Sloc (Choice);
- Error_Msg_N ("duplication of choice value#", Prev_Choice);
+ if Expr_Value (Bounds_Lo) < Choice_Lo - 1 then
+ Explain_Non_Static_Bound;
end if;
-
- elsif not Others_Present and then Lo /= Prev_Hi + 1 then
- Issue_Msg (Prev_Hi + 1, Lo - 1);
end if;
- if Hi > Prev_Hi then
- Prev_Hi := Hi;
- end if;
- end loop;
+ for Outer_Index in 2 .. Num_Choices loop
+ Choice_Lo := Expr_Value (Choice_Table (Outer_Index).Lo);
+ Choice_Hi := Expr_Value (Choice_Table (Outer_Index).Hi);
+
+ if Choice_Lo <= Prev_Hi then
+ Choice := Choice_Table (Outer_Index).Node;
- if not Others_Present and then Expr_Value (Bounds_Hi) > Hi then
- Issue_Msg (Hi + 1, Bounds_Hi);
+ -- Find first previous choice that overlaps
- if Expr_Value (Bounds_Hi) > Hi + 1 then
- Explain_Non_Static_Bound;
+ for Inner_Index in 1 .. Outer_Index - 1 loop
+ if Choice_Lo <=
+ Expr_Value (Choice_Table (Inner_Index).Hi)
+ then
+ Prev_Choice := Choice_Table (Inner_Index).Node;
+ exit;
+ end if;
+ end loop;
+
+ if Sloc (Prev_Choice) <= Sloc (Choice) then
+ Error_Msg_Sloc := Sloc (Prev_Choice);
+ Error_Msg_N ("duplication of choice value#", Choice);
+ else
+ Error_Msg_Sloc := Sloc (Choice);
+ Error_Msg_N ("duplication of choice value#", Prev_Choice);
+ end if;
+
+ elsif not Others_Present and then Choice_Lo /= Prev_Hi + 1 then
+ Missing_Choice (Prev_Hi + 1, Choice_Lo - 1);
+ end if;
+
+ if Choice_Hi > Prev_Hi then
+ Prev_Hi := Choice_Hi;
+ end if;
+ end loop;
+
+ if not Others_Present and then Expr_Value (Bounds_Hi) > Choice_Hi then
+ Missing_Choice (Choice_Hi + 1, Bounds_Hi);
+
+ if Expr_Value (Bounds_Hi) > Choice_Hi + 1 then
+ Explain_Non_Static_Bound;
+ end if;
end if;
end if;
end Check_Choices;
-- the function is inserted before the freeze node, and the body of the
-- function is inserted after the freeze node. If the predicate expression
-- has at least one Raise_Expression, then this procedure also builds the
- -- M version of the predicate function for ue in membership tests.
+ -- M version of the predicate function for use in membership tests.
procedure Build_Static_Predicate
(Typ : Entity_Id;
type REnt is record
Lo, Hi : Uint;
end record;
- -- One entry in a Rlist value, a single REnt (range entry) value
- -- denotes one range from Lo to Hi. To represent a single value
- -- range Lo = Hi = value.
+ -- One entry in a Rlist value, a single REnt (range entry) value denotes
+ -- one range from Lo to Hi. To represent a single value range Lo = Hi =
+ -- value.
type RList is array (Nat range <>) of REnt;
- -- A list of ranges. The ranges are sorted in increasing order,
- -- and are disjoint (there is a gap of at least one value between
- -- each range in the table). A value is in the set of ranges in
- -- Rlist if it lies within one of these ranges
+ -- A list of ranges. The ranges are sorted in increasing order, and are
+ -- disjoint (there is a gap of at least one value between each range in
+ -- the table). A value is in the set of ranges in Rlist if it lies
+ -- within one of these ranges.
False_Range : constant RList :=
RList'(1 .. 0 => REnt'(No_Uint, No_Uint));
True_Range : constant RList := RList'(1 => REnt'(BLo, BHi));
-- Range representing True, value must be in the base range
- function "and" (Left, Right : RList) return RList;
- -- And's together two range lists, returning a range list. This is
- -- a set intersection operation.
+ function "and" (Left : RList; Right : RList) return RList;
+ -- And's together two range lists, returning a range list. This is a set
+ -- intersection operation.
- function "or" (Left, Right : RList) return RList;
- -- Or's together two range lists, returning a range list. This is a
- -- set union operation.
+ function "or" (Left : RList; Right : RList) return RList;
+ -- Or's together two range lists, returning a range list. This is a set
+ -- union operation.
function "not" (Right : RList) return RList;
-- Returns complement of a given range list, i.e. a range list
- -- representing all the values in TLo .. THi that are not in the
- -- input operand Right.
+ -- representing all the values in TLo .. THi that are not in the input
+ -- operand Right.
function Build_Val (V : Uint) return Node_Id;
-- Return an analyzed N_Identifier node referencing this value, suitable
-- for use as an entry in the Static_Predicate list. This node is typed
-- with the base type.
- function Build_Range (Lo, Hi : Uint) return Node_Id;
- -- Return an analyzed N_Range node referencing this range, suitable
- -- for use as an entry in the Static_Predicate list. This node is typed
- -- with the base type.
+ function Build_Range (Lo : Uint; Hi : Uint) return Node_Id;
+ -- Return an analyzed N_Range node referencing this range, suitable for
+ -- use as an entry in the Static_Predicate list. This node is typed with
+ -- the base type.
function Get_RList (Exp : Node_Id) return RList;
- -- This is a recursive routine that converts the given expression into
- -- a list of ranges, suitable for use in building the static predicate.
+ -- This is a recursive routine that converts the given expression into a
+ -- list of ranges, suitable for use in building the static predicate.
function Is_False (R : RList) return Boolean;
pragma Inline (Is_False);
- -- Returns True if the given range list is empty, and thus represents
- -- a False list of ranges that can never be satisfied.
+ -- Returns True if the given range list is empty, and thus represents a
+ -- False list of ranges that can never be satisfied.
function Is_True (R : RList) return Boolean;
- -- Returns True if R trivially represents the True predicate by having
- -- a single range from BLo to BHi.
+ -- Returns True if R trivially represents the True predicate by having a
+ -- single range from BLo to BHi.
function Is_Type_Ref (N : Node_Id) return Boolean;
pragma Inline (Is_Type_Ref);
-- "and" --
-----------
- function "and" (Left, Right : RList) return RList is
+ function "and" (Left : RList; Right : RList) return RList is
FEnt : REnt;
-- First range of result
return False_Range;
end if;
- -- Loop to remove entries at start that are disjoint, and thus
- -- just get discarded from the result entirely.
+ -- Loop to remove entries at start that are disjoint, and thus just
+ -- get discarded from the result entirely.
loop
-- If no operands left in either operand, result is false
end if;
end loop;
- -- Now we have two non-null operands, and first entries overlap.
- -- The first entry in the result will be the overlapping part of
- -- these two entries.
+ -- Now we have two non-null operands, and first entries overlap. The
+ -- first entry in the result will be the overlapping part of these
+ -- two entries.
FEnt := REnt'(Lo => UI_Max (Left (SLeft).Lo, Right (SRight).Lo),
Hi => UI_Min (Left (SLeft).Hi, Right (SRight).Hi));
- -- Now we can remove the entry that ended at a lower value, since
- -- its contribution is entirely contained in Fent.
+ -- Now we can remove the entry that ended at a lower value, since its
+ -- contribution is entirely contained in Fent.
if Left (SLeft).Hi <= Right (SRight).Hi then
SLeft := SLeft + 1;
SRight := SRight + 1;
end if;
- -- Compute result by concatenating this first entry with the "and"
- -- of the remaining parts of the left and right operands. Note that
- -- if either of these is empty, "and" will yield empty, so that we
- -- will end up with just Fent, which is what we want in that case.
+ -- Compute result by concatenating this first entry with the "and" of
+ -- the remaining parts of the left and right operands. Note that if
+ -- either of these is empty, "and" will yield empty, so that we will
+ -- end up with just Fent, which is what we want in that case.
return
FEnt & (Left (SLeft .. Left'Last) and Right (SRight .. Right'Last));
-- "or" --
----------
- function "or" (Left, Right : RList) return RList is
+ function "or" (Left : RList; Right : RList) return RList is
FEnt : REnt;
-- First range of result
return Left;
end if;
- -- Initialize result first entry from left or right operand
- -- depending on which starts with the lower range.
+ -- Initialize result first entry from left or right operand depending
+ -- on which starts with the lower range.
if Left (SLeft).Lo < Right (SRight).Lo then
FEnt := Left (SLeft);
SRight := SRight + 1;
end if;
- -- This loop eats ranges from left and right operands that
- -- are contiguous with the first range we are gathering.
+ -- This loop eats ranges from left and right operands that are
+ -- contiguous with the first range we are gathering.
loop
- -- Eat first entry in left operand if contiguous or
- -- overlapped by gathered first operand of result.
+ -- Eat first entry in left operand if contiguous or overlapped by
+ -- gathered first operand of result.
if SLeft <= Left'Last
and then Left (SLeft).Lo <= FEnt.Hi + 1
FEnt.Hi := UI_Max (FEnt.Hi, Left (SLeft).Hi);
SLeft := SLeft + 1;
- -- Eat first entry in right operand if contiguous or
- -- overlapped by gathered right operand of result.
+ -- Eat first entry in right operand if contiguous or overlapped by
+ -- gathered right operand of result.
elsif SRight <= Right'Last
and then Right (SRight).Lo <= FEnt.Hi + 1
FEnt.Hi := UI_Max (FEnt.Hi, Right (SRight).Hi);
SRight := SRight + 1;
- -- All done if no more entries to eat!
+ -- All done if no more entries to eat
else
exit;
-- Build_Range --
-----------------
- function Build_Range (Lo, Hi : Uint) return Node_Id is
+ function Build_Range (Lo : Uint; Hi : Uint) return Node_Id is
Result : Node_Id;
+
begin
- if Lo = Hi then
- return Build_Val (Hi);
- else
- Result :=
- Make_Range (Loc,
- Low_Bound => Build_Val (Lo),
- High_Bound => Build_Val (Hi));
- Set_Etype (Result, Btyp);
- Set_Analyzed (Result);
- return Result;
- end if;
+ Result :=
+ Make_Range (Loc,
+ Low_Bound => Build_Val (Lo),
+ High_Bound => Build_Val (Hi));
+ Set_Etype (Result, Btyp);
+ Set_Analyzed (Result);
+
+ return Result;
end Build_Range;
---------------
-- Convert range into required form
- if Lo = Hi then
- Append_To (Plist, Build_Val (Lo));
- else
- Append_To (Plist, Build_Range (Lo, Hi));
- end if;
+ Append_To (Plist, Build_Range (Lo, Hi));
end if;
end;
end loop;
-- storage orders differ.
if (Is_Record_Type (T1) or else Is_Array_Type (T1))
- and then
+ and then
(Is_Record_Type (T2) or else Is_Array_Type (T2))
and then
(Component_Alignment (T1) /= Component_Alignment (T2)
or else
- Reverse_Storage_Order (T1) /= Reverse_Storage_Order (T2))
+ Reverse_Storage_Order (T1) /= Reverse_Storage_Order (T2))
then
return False;
end if;
-----------------------------
procedure Analyze_Case_Expression (N : Node_Id) is
- Expr : constant Node_Id := Expression (N);
- FirstX : constant Node_Id := Expression (First (Alternatives (N)));
- Alt : Node_Id;
- Exp_Type : Entity_Id;
- Exp_Btype : Entity_Id;
-
- Dont_Care : Boolean;
- Others_Present : Boolean;
+ function Has_Static_Predicate (Subtyp : Entity_Id) return Boolean;
+ -- Determine whether subtype Subtyp has aspect Static_Predicate
procedure Non_Static_Choice_Error (Choice : Node_Id);
-- Error routine invoked by the generic instantiation below when
Process_Associated_Node => No_OP);
use Case_Choices_Processing;
+ --------------------------
+ -- Has_Static_Predicate --
+ --------------------------
+
+ function Has_Static_Predicate (Subtyp : Entity_Id) return Boolean is
+ Item : Node_Id;
+
+ begin
+ Item := First_Rep_Item (Subtyp);
+ while Present (Item) loop
+ if Nkind (Item) = N_Aspect_Specification
+ and then Chars (Identifier (Item)) = Name_Static_Predicate
+ then
+ return True;
+ end if;
+
+ Next_Rep_Item (Item);
+ end loop;
+
+ return False;
+ end Has_Static_Predicate;
+
-----------------------------
-- Non_Static_Choice_Error --
-----------------------------
("choice given in case expression is not static!", Choice);
end Non_Static_Choice_Error;
+ -- Local variables
+
+ Expr : constant Node_Id := Expression (N);
+ FirstX : constant Node_Id := Expression (First (Alternatives (N)));
+ Alt : Node_Id;
+ Exp_Type : Entity_Id;
+ Exp_Btype : Entity_Id;
+
+ Dont_Care : Boolean;
+ Others_Present : Boolean;
+
-- Start of processing for Analyze_Case_Expression
begin
Exp_Type := Exp_Btype;
end if;
+ -- The case expression alternatives cover the range of a static subtype
+ -- subject to aspect Static_Predicate. Do not check the choices when the
+ -- case expression has not been fully analyzed yet because this may lead
+ -- to bogus errors.
+
+ if Is_Static_Subtype (Exp_Type)
+ and then Has_Static_Predicate (Exp_Type)
+ and then In_Spec_Expression
+ then
+ null;
+
-- Call instantiated Analyze_Choices which does the rest of the work
- Analyze_Choices (N, Exp_Type, Dont_Care, Others_Present);
+ else
+ Analyze_Choices (N, Exp_Type, Dont_Care, Others_Present);
+ end if;
if Exp_Type = Universal_Integer and then not Others_Present then
Error_Msg_N
begin
A := First (Actions (N));
- loop
+ while Present (A) loop
Analyze (A);
Next (A);
- exit when No (A);
end loop;
-- This test needs a comment ???
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S E T _ T A R G --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2013, 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- --
+-- ware Foundation; either version 3, 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 COPYING3. If not, go to --
+-- http://www.gnu.org/licenses for a complete copy of the license. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Debug; use Debug;
+with Get_Targ; use Get_Targ;
+with Opt; use Opt;
+with Output; use Output;
+
+with System; use System;
+with System.OS_Lib; use System.OS_Lib;
+
+with Unchecked_Conversion;
+
+package body Set_Targ is
+
+ ---------------------------------------------
+ -- Data Used to Read/Write target.atp File --
+ ---------------------------------------------
+
+ File_Name : aliased constant String := "target.atp";
+ -- Name of file to read/write
+
+ -- Table of string names written to file
+
+ subtype Str is String;
+
+ S_Bits_BE : constant Str := "Bits_BE";
+ S_Bits_Per_Unit : constant Str := "Bits_Per_Unit";
+ S_Bits_Per_Word : constant Str := "Bits_Per_Word";
+ S_Bytes_BE : constant Str := "Bytes_BE";
+ S_Char_Size : constant Str := "Char_Size";
+ S_Double_Float_Alignment : constant Str := "Double_Float_Alignment";
+ S_Double_Scalar_Alignment : constant Str := "Double_Scalar_Alignment";
+ S_Double_Size : constant Str := "Double_Size";
+ S_Float_Size : constant Str := "Float_Size";
+ S_Float_Words_BE : constant Str := "Float_Words_BE";
+ S_Int_Size : constant Str := "Int_Size";
+ S_Long_Double_Size : constant Str := "Long_Double_Size";
+ S_Long_Long_Size : constant Str := "Long_Long_Size";
+ S_Long_Size : constant Str := "Long_Size";
+ S_Maximum_Alignment : constant Str := "Maximum_Alignment";
+ S_Max_Unaligned_Field : constant Str := "Max_Unaligned_Field";
+ S_Pointer_Size : constant Str := "Pointer_Size";
+ S_Short_Size : constant Str := "Short_Size";
+ S_Strict_Alignment : constant Str := "Strict_Alignment";
+ S_System_Allocator_Alignment : constant Str := "System_Allocator_Alignment";
+ S_Wchar_T_Size : constant Str := "Wchar_T_Size";
+ S_Words_BE : constant Str := "Words_BE";
+
+ -- Table of names
+
+ type AStr is access all String;
+
+ DTN : constant array (Nat range <>) of AStr := (
+ S_Bits_BE 'Unrestricted_Access,
+ S_Bits_Per_Unit 'Unrestricted_Access,
+ S_Bits_Per_Word 'Unrestricted_Access,
+ S_Bytes_BE 'Unrestricted_Access,
+ S_Char_Size 'Unrestricted_Access,
+ S_Double_Float_Alignment 'Unrestricted_Access,
+ S_Double_Scalar_Alignment 'Unrestricted_Access,
+ S_Double_Size 'Unrestricted_Access,
+ S_Float_Size 'Unrestricted_Access,
+ S_Float_Words_BE 'Unrestricted_Access,
+ S_Int_Size 'Unrestricted_Access,
+ S_Long_Double_Size 'Unrestricted_Access,
+ S_Long_Long_Size 'Unrestricted_Access,
+ S_Long_Size 'Unrestricted_Access,
+ S_Maximum_Alignment 'Unrestricted_Access,
+ S_Max_Unaligned_Field 'Unrestricted_Access,
+ S_Pointer_Size 'Unrestricted_Access,
+ S_Short_Size 'Unrestricted_Access,
+ S_Strict_Alignment 'Unrestricted_Access,
+ S_System_Allocator_Alignment 'Unrestricted_Access,
+ S_Wchar_T_Size 'Unrestricted_Access,
+ S_Words_BE 'Unrestricted_Access);
+
+ -- Table of corresponding value pointers
+
+ DTV : constant array (Nat range <>) of System.Address := (
+ Bits_BE 'Address,
+ Bits_Per_Unit 'Address,
+ Bits_Per_Word 'Address,
+ Bytes_BE 'Address,
+ Char_Size 'Address,
+ Double_Float_Alignment 'Address,
+ Double_Scalar_Alignment 'Address,
+ Double_Size 'Address,
+ Float_Size 'Address,
+ Float_Words_BE 'Address,
+ Int_Size 'Address,
+ Long_Double_Size 'Address,
+ Long_Long_Size 'Address,
+ Long_Size 'Address,
+ Maximum_Alignment 'Address,
+ Max_Unaligned_Field 'Address,
+ Pointer_Size 'Address,
+ Short_Size 'Address,
+ Strict_Alignment 'Address,
+ System_Allocator_Alignment 'Address,
+ Wchar_T_Size 'Address,
+ Words_BE 'Address);
+
+ DTR : array (Nat range DTV'Range) of Boolean := (others => False);
+ -- Table of flags used to validate that all values are present in file
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ procedure Fail (E : String);
+ pragma No_Return (Fail);
+ -- Terminate program with fatal error message passed as parameter
+
+ type C_String is array (0 .. 255) of aliased Character;
+ pragma Convention (C, C_String);
+ -- String long enough to hold any mode name for the following call
+
+ procedure Register_Float_Type
+ (Name : C_String;
+ Digs : Natural;
+ Complex : Boolean;
+ Count : Natural;
+ Float_Rep : Float_Rep_Kind;
+ Size : Positive;
+ Alignment : Natural);
+ pragma Convention (C, Register_Float_Type);
+ -- Call back to allow the back end to register available types. This call
+ -- back makes entries in the FPT_Mode_Table for any floating point types
+ -- reported by the back end. Name is the name of the type as a normal
+ -- format Null-terminated string. Digs is the number of digits, where 0
+ -- means it is not a fpt type (ignored during registration). Complex is
+ -- non-zero if the type has real and imaginary parts (also ignored during
+ -- registration). Count is the number of elements in a vector type (zero =
+ -- not a vector, registration ignores vectors). Float_Rep shows the kind of
+ -- floating-point type, and Size/Alignment are the size/alignment in bits.
+ --
+ -- So to summarize, the only types that are actually registered have Digs
+ -- non-zero, Complex zero (false), and Count zero (not a vector).
+
+ ----------
+ -- Fail --
+ ----------
+
+ procedure Fail (E : String) is
+ E_Fatal : constant := 4;
+ -- Code for fatal error
+ begin
+ Write_Str (E);
+ Write_Eol;
+ OS_Exit (E_Fatal);
+ end Fail;
+
+ -------------------------
+ -- Register_Float_Type --
+ -------------------------
+
+ procedure Register_Float_Type
+ (Name : C_String;
+ Digs : Natural;
+ Complex : Boolean;
+ Count : Natural;
+ Float_Rep : Float_Rep_Kind;
+ Size : Positive;
+ Alignment : Natural)
+ is
+ T : String (1 .. Name'Length);
+ Last : Natural := 0;
+
+ procedure Dump;
+ -- Dump information given by the back end for the type to register
+
+ ----------
+ -- Dump --
+ ----------
+
+ procedure Dump is
+ begin
+ Write_Str ("type " & T (1 .. Last) & " is ");
+
+ if Count > 0 then
+ Write_Str ("array (1 .. ");
+ Write_Int (Int (Count));
+
+ if Complex then
+ Write_Str (", 1 .. 2");
+ end if;
+
+ Write_Str (") of ");
+
+ elsif Complex then
+ Write_Str ("array (1 .. 2) of ");
+ end if;
+
+ if Digs > 0 then
+ Write_Str ("digits ");
+ Write_Int (Int (Digs));
+ Write_Line (";");
+
+ Write_Str ("pragma Float_Representation (");
+
+ case Float_Rep is
+ when IEEE_Binary =>
+ Write_Str ("IEEE");
+
+ when VAX_Native =>
+ case Digs is
+ when 6 =>
+ Write_Str ("VAXF");
+
+ when 9 =>
+ Write_Str ("VAXD");
+
+ when 15 =>
+ Write_Str ("VAXG");
+
+ when others =>
+ Write_Str ("VAX_");
+ Write_Int (Int (Digs));
+ end case;
+
+ when AAMP => Write_Str ("AAMP");
+ end case;
+
+ Write_Line (", " & T (1 .. Last) & ");");
+
+ else
+ Write_Str ("mod 2**");
+ Write_Int (Int (Size / Positive'Max (1, Count)));
+ Write_Line (";");
+ end if;
+
+ Write_Str ("for " & T (1 .. Last) & "'Size use ");
+ Write_Int (Int (Size));
+ Write_Line (";");
+
+ Write_Str ("for " & T (1 .. Last) & "'Alignment use ");
+ Write_Int (Int (Alignment / 8));
+ Write_Line (";");
+ Write_Eol;
+ end Dump;
+
+ -- Start of processing for Register_Float_Type
+
+ begin
+ -- Acquire name
+
+ for J in T'Range loop
+ T (J) := Name (Name'First + J - 1);
+
+ if T (J) = ASCII.NUL then
+ Last := J - 1;
+ exit;
+ end if;
+ end loop;
+
+ -- Dump info if debug flag set
+
+ if Debug_Flag_Dot_B then
+ Dump;
+ end if;
+
+ -- Acquire entry if non-vector non-complex fpt type (digits non-zero)
+
+ if Digs > 0 and then not Complex and then Count = 0 then
+ Num_FPT_Modes := Num_FPT_Modes + 1;
+ FPT_Mode_Table (Num_FPT_Modes) :=
+ (NAME => new String'(T (1 .. Last)),
+ DIGS => Digs,
+ FLOAT_REP => Float_Rep,
+ SIZE => Size,
+ ALIGNMENT => Alignment);
+ end if;
+ end Register_Float_Type;
+
+ -----------------------------------
+ -- Write_Target_Dependent_Values --
+ -----------------------------------
+
+ -- We do this at the System.Os_Lib level, since we have to do the read at
+ -- that level anyway, so it is easier and more consistent to follow the
+ -- same path for the write.
+
+ procedure Write_Target_Dependent_Values is
+ Fdesc : File_Descriptor;
+ OK : Boolean;
+
+ Buffer : String (1 .. 80);
+ Buflen : Natural;
+ -- Buffer used to build line one of file
+
+ type ANat is access all Natural;
+ -- Pointer to Nat or Pos value (it is harmless to treat Pos values and
+ -- Nat values as Natural via Unchecked_Conversion).
+
+ function To_ANat is new Unchecked_Conversion (Address, ANat);
+
+ procedure AddC (C : Character);
+ -- Add one character to buffer
+
+ procedure AddN (N : Natural);
+ -- Add representation of integer N to Buffer, updating Buflen. N
+ -- must be less than 1000, and output is 3 characters with leading
+ -- spaces as needed.
+
+ procedure Write_Line;
+ -- Output contents of Buffer (1 .. Buflen) followed by a New_Line,
+ -- and set Buflen back to zero.
+
+ ----------
+ -- AddC --
+ ----------
+
+ procedure AddC (C : Character) is
+ begin
+ Buflen := Buflen + 1;
+ Buffer (Buflen) := C;
+ end AddC;
+
+ ----------
+ -- AddN --
+ ----------
+
+ procedure AddN (N : Natural) is
+ begin
+ if N > 999 then
+ raise Program_Error;
+ end if;
+
+ if N > 99 then
+ AddC (Character'Val (48 + N / 100));
+ else
+ AddC (' ');
+ end if;
+
+ if N > 9 then
+ AddC (Character'Val (48 + N / 10 mod 10));
+ else
+ AddC (' ');
+ end if;
+
+ AddC (Character'Val (48 + N mod 10));
+ end AddN;
+
+ ----------------
+ -- Write_Line --
+ ----------------
+
+ procedure Write_Line is
+ begin
+ AddC (ASCII.LF);
+
+ if Buflen /= Write (Fdesc, Buffer'Address, Buflen) then
+ Delete_File (File_Name'Address, OK);
+ Fail ("disk full writing target.atp");
+ end if;
+
+ Buflen := 0;
+ end Write_Line;
+
+ -- Start of processing for Write_Target_Dependent_Values
+
+ begin
+ Fdesc := Create_File (File_Name'Address, Text);
+
+ if Fdesc = Invalid_FD then
+ Fail ("cannot create target.atp");
+ end if;
+
+ -- Loop through values
+
+ for J in DTN'Range loop
+
+ -- Output name
+
+ Buflen := DTN (J)'Length;
+ Buffer (1 .. Buflen) := DTN (J).all;
+
+ -- Line up values
+
+ while Buflen < 26 loop
+ AddC (' ');
+ end loop;
+
+ AddC (' ');
+ AddC (' ');
+
+ -- Output value and write line
+
+ AddN (To_ANat (DTV (J)).all);
+ Write_Line;
+ end loop;
+
+ -- Blank line to separate sections
+
+ Write_Line;
+
+ -- Write lines for registered FPT types
+
+ for J in 1 .. Num_FPT_Modes loop
+ declare
+ E : FPT_Mode_Entry renames FPT_Mode_Table (J);
+ begin
+ Buflen := E.NAME'Last;
+ Buffer (1 .. Buflen) := E.NAME.all;
+
+ -- Pad out to line up values
+
+ while Buflen < 11 loop
+ AddC (' ');
+ end loop;
+
+ AddC (' ');
+ AddC (' ');
+
+ AddN (E.DIGS);
+ AddC (' ');
+ AddC (' ');
+
+ case E.FLOAT_REP is
+ when IEEE_Binary =>
+ AddC ('I');
+ when VAX_Native =>
+ AddC ('V');
+ when AAMP =>
+ AddC ('A');
+ end case;
+
+ AddC (' ');
+
+ AddN (E.SIZE);
+ AddC (' ');
+
+ AddN (E.ALIGNMENT);
+ Write_Line;
+ end;
+ end loop;
+
+ -- Close file
+
+ Close (Fdesc, OK);
+
+ if not OK then
+ Fail ("disk full writing target.atp");
+ end if;
+ end Write_Target_Dependent_Values;
+
+-- Package Initialization, set target dependent values. This must be done
+-- early on, before we start accessing various compiler packages, since
+-- these values are used all over the place.
+
+begin
+ -- First step: see if the -gnateT switch is present. As we have noted,
+ -- this has to be done very early, so can not depend on the normal circuit
+ -- for reading switches and setting switches in opt. The following code
+ -- will set Opt.Target_Dependent_Info_Read if an option starting -gnatet
+ -- is present in the options string.
+
+ declare
+ 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 misc.c
+
+ save_argv : Arg_Array_Ptr;
+ pragma Import (C, save_argv);
+ -- Saved value of argv (argument pointers), imported from misc.c
+
+ begin
+ -- Loop through arguments looking for -gnateT, also look for -gnatd.b
+
+ for Arg in 1 .. save_argc - 1 loop
+ declare
+ Argv_Ptr : constant Big_String_Ptr := save_argv (Arg);
+ begin
+ if Argv_Ptr (1 .. 7) = "-gnateT" then
+ Opt.Target_Dependent_Info_Read := True;
+ elsif Argv_Ptr (1 .. 8) = "-gnatd.b" then
+ Debug_Flag_Dot_B := True;
+ end if;
+ end;
+ end loop;
+ end;
+
+ -- If the switch is not set, we get all values from the back end
+
+ if not Opt.Target_Dependent_Info_Read then
+
+ -- Set values set by direct calls to the back end
+
+ Bits_BE := Get_Bits_BE;
+ Bits_Per_Unit := Get_Bits_Per_Unit;
+ Bits_Per_Word := Get_Bits_Per_Word;
+ Bytes_BE := Get_Bytes_BE;
+ Char_Size := Get_Char_Size;
+ Double_Float_Alignment := Get_Double_Float_Alignment;
+ Double_Scalar_Alignment := Get_Double_Scalar_Alignment;
+ Double_Size := Get_Double_Size;
+ Float_Size := Get_Float_Size;
+ Float_Words_BE := Get_Float_Words_BE;
+ Int_Size := Get_Int_Size;
+ Long_Double_Size := Get_Long_Double_Size;
+ Long_Long_Size := Get_Long_Long_Size;
+ Long_Size := Get_Long_Size;
+ Maximum_Alignment := Get_Maximum_Alignment;
+ Max_Unaligned_Field := Get_Max_Unaligned_Field;
+ Pointer_Size := Get_Pointer_Size;
+ Short_Size := Get_Short_Size;
+ Strict_Alignment := Get_Strict_Alignment;
+ System_Allocator_Alignment := Get_System_Allocator_Alignment;
+ Wchar_T_Size := Get_Wchar_T_Size;
+ Words_BE := Get_Words_BE;
+
+ -- Register floating-point types from the back end (depending on the
+ -- back end in use, we have to do different things to get this info).
+
+ case Get_Back_End is
+
+ -- GCC back end, get information using Enumerate_Modes
+
+ when GCC =>
+ declare
+ type Register_Type_Proc is access procedure
+ (C_Name : C_String;
+ Digs : Natural;
+ Complex : Boolean;
+ Count : Natural;
+ Float_Rep : Float_Rep_Kind;
+ Size : Positive;
+ Alignment : Natural);
+ pragma Convention (C, Register_Type_Proc);
+ -- Call back procedure for Register_Back_End_Types
+
+ procedure Enumerate_Modes (Call_Back : Register_Type_Proc);
+ pragma Import (C, Enumerate_Modes, "enumerate_modes");
+ -- Back end procedure that does the call backs (see misc.c)
+
+ begin
+ Num_FPT_Modes := 0;
+ Enumerate_Modes (Register_Float_Type'Access);
+ end;
+
+ -- AAMP back end, supply the two needed types directly
+
+ when AAMP =>
+ declare
+ Str : C_String;
+
+ begin
+ Str (1 .. 6) := "float" & ASCII.NUL;
+ Register_Float_Type
+ (Name => Str,
+ Digs => 6,
+ Complex => False,
+ Count => 0,
+ Float_Rep => AAMP,
+ Size => 32,
+ Alignment => 16);
+
+ Str (1 .. 7) := "double" & ASCII.NUL;
+ Register_Float_Type
+ (Name => Str,
+ Digs => 9,
+ Complex => False,
+ Count => 0,
+ Float_Rep => AAMP,
+ Size => 48,
+ Alignment => 16);
+ end;
+
+ -- DotNet TBD
+
+ when DOTNET =>
+ null;
+ end case;
+
+ -- Case of reading the target dependent values from target.atp
+
+ -- This is bit more complex than might be expected, because it has to
+ -- be done very early. All kinds of packages depend on these values,
+ -- and we can't wait till the normal processing of reading command line
+ -- switches etc to read the file. We do this at the System.OS_Lib level
+ -- since it is too early to be using Osint directly.
+
+ else
+ Read_File : declare
+ File_Desc : File_Descriptor;
+ N : Natural;
+
+ type ANat is access all Natural;
+ -- Pointer to Nat or Pos value (it is harmless to treat Pos values
+ -- as Nat via Unchecked_Conversion).
+
+ function To_ANat is new Unchecked_Conversion (Address, ANat);
+
+ VP : ANat;
+
+ Buffer : String (1 .. 2000);
+ Buflen : Natural;
+ -- File information and length (2000 easily enough!)
+
+ Nam_Buf : String (1 .. 40);
+ Nam_Len : Natural;
+
+ procedure Check_Spaces;
+ -- Checks that we have one or more spaces and skips them
+
+ procedure FailN (S : String);
+ -- Calls Fail prefixing "target.atp: " to the start of the given
+ -- string, and " name" to the end where name is the currently
+ -- gathered name in Nam_Buf, surrounded by quotes.
+
+ procedure Get_Name;
+ -- Scan out name, leaving it in Nam_Buf with Nam_Len set. Calls
+ -- Skip_Spaces to skip any following spaces. Note that the name is
+ -- terminated by a sequence of at least two spaces.
+
+ function Get_Nat return Natural;
+ -- N on entry points to decimal integer, scan out decimal integer
+ -- and return it, leaving N pointing to following space or LF.
+
+ procedure Skip_Spaces;
+ -- Skip past spaces
+
+ ------------------
+ -- Check_Spaces --
+ ------------------
+
+ procedure Check_Spaces is
+ begin
+ if N > Buflen or else Buffer (N) /= ' ' then
+ FailN ("missing space for");
+ end if;
+
+ Skip_Spaces;
+ return;
+ end Check_Spaces;
+
+ -----------
+ -- FailN --
+ -----------
+
+ procedure FailN (S : String) is
+ begin
+ Fail ("target.atp: " & S & " """ & Nam_Buf (1 .. Nam_Len) & '"');
+ end FailN;
+
+ --------------
+ -- Get_Name --
+ --------------
+
+ procedure Get_Name is
+ begin
+ Nam_Len := 0;
+
+ -- Scan out name and put it in Nam_Buf
+
+ loop
+ if N > Buflen or else Buffer (N) = ASCII.LF then
+ FailN ("incorrectly formatted line for");
+ end if;
+
+ -- Name is terminated by two blanks
+
+ exit when N < Buflen and then Buffer (N .. N + 1) = " ";
+
+ Nam_Len := Nam_Len + 1;
+
+ if Nam_Len > Nam_Buf'Last then
+ Fail ("name too long");
+ end if;
+
+ Nam_Buf (Nam_Len) := Buffer (N);
+ N := N + 1;
+ end loop;
+
+ Check_Spaces;
+ end Get_Name;
+
+ -------------
+ -- Get_Nat --
+ -------------
+
+ function Get_Nat return Natural is
+ Result : Natural := 0;
+
+ begin
+ loop
+ if N > Buflen
+ or else Buffer (N) not in '0' .. '9'
+ or else Result > 999
+ then
+ FailN ("bad value for");
+ end if;
+
+ Result := Result * 10 + (Character'Pos (Buffer (N)) - 48);
+ N := N + 1;
+
+ exit when N <= Buflen
+ and then (Buffer (N) = ASCII.LF or else Buffer (N) = ' ');
+ end loop;
+
+ return Result;
+ end Get_Nat;
+
+ -----------------
+ -- Skip_Spaces --
+ -----------------
+
+ procedure Skip_Spaces is
+ begin
+ while N <= Buflen and Buffer (N) = ' ' loop
+ N := N + 1;
+ end loop;
+ end Skip_Spaces;
+
+ -- Start of processing for Read_File
+
+ begin
+ File_Desc := Open_Read ("target.atp", Text);
+
+ if File_Desc = Invalid_FD then
+ Fail ("cannot read target.atp file");
+ end if;
+
+ Buflen := Read (File_Desc, Buffer'Address, Buffer'Length);
+
+ if Buflen = Buffer'Length then
+ Fail ("target.atp file is too long");
+ end if;
+
+ -- Scan through file for properly formatted entries in first section
+
+ N := 1;
+ while N <= Buflen and then Buffer (N) /= ASCII.LF loop
+ Get_Name;
+
+ -- Validate name and get corresponding value pointer
+
+ VP := null;
+
+ for J in DTN'Range loop
+ if DTN (J).all = Nam_Buf (1 .. Nam_Len) then
+ VP := To_ANat (DTV (J));
+ DTR (J) := True;
+ exit;
+ end if;
+ end loop;
+
+ if VP = null then
+ FailN ("unrecognized name");
+ end if;
+
+ -- Scan out value
+
+ VP.all := Get_Nat;
+
+ if N > Buflen or else Buffer (N) /= ASCII.LF then
+ FailN ("misformatted line for");
+ end if;
+
+ N := N + 1; -- skip LF
+ end loop;
+
+ -- Fall through this loop when all lines in first section read.
+ -- Check that values have been supplied for all entries.
+
+ for J in DTR'Range loop
+ if not DTR (J) then
+ Fail ("missing entry in target.atp for " & DTN (J).all);
+ end if;
+ end loop;
+
+ -- Now acquire FPT entries
+
+ if N >= Buflen then
+ Fail ("target.atp is missing entries for FPT modes");
+ end if;
+
+ if Buffer (N) = ASCII.LF then
+ N := N + 1;
+ else
+ Fail ("target.atp is missing blank line");
+ end if;
+
+ Num_FPT_Modes := 0;
+ while N <= Buflen loop
+ Get_Name;
+
+ Num_FPT_Modes := Num_FPT_Modes + 1;
+
+ declare
+ E : FPT_Mode_Entry renames FPT_Mode_Table (Num_FPT_Modes);
+
+ begin
+ E.NAME := new String'(Nam_Buf (1 .. Nam_Len));
+
+ E.DIGS := Get_Nat;
+ Check_Spaces;
+
+ case Buffer (N) is
+ when 'I' =>
+ E.FLOAT_REP := IEEE_Binary;
+ when 'V' =>
+ E.FLOAT_REP := VAX_Native;
+ when 'A' =>
+ E.FLOAT_REP := AAMP;
+ when others =>
+ FailN ("bad float rep field for");
+ end case;
+
+ N := N + 1;
+ Check_Spaces;
+
+ E.SIZE := Get_Nat;
+ Check_Spaces;
+
+ E.ALIGNMENT := Get_Nat;
+
+ if Buffer (N) /= ASCII.LF then
+ FailN ("junk at end of line for");
+ end if;
+
+ N := N + 1;
+ end;
+ end loop;
+ end Read_File;
+ end if;
+end Set_Targ;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S E T _ T A R G --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2013, 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- --
+-- ware Foundation; either version 3, 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 COPYING3. If not, go to --
+-- http://www.gnu.org/licenses for a complete copy of the license. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package handles setting target dependent parameters. If the -gnatet
+-- switch is not set, then these values are taken from the back end (via the
+-- routines in Get_Targ, and the enumerate_modes routine in misc.c). If the
+-- switch is set, then the values are read from the target.atp file in the
+-- current directory (usually written with the Write_Target_Dependent_Values
+-- procedure defined in this package).
+
+-- Note that all these values return sizes of C types with corresponding
+-- names. This allows GNAT to define the corresponding Ada types to have
+-- the same representation. There is one exception: the representation
+-- of Wide_Character_Type uses twice the size of a C char, instead of the
+-- size of wchar_t, since this corresponds to expected Ada usage.
+
+with Einfo; use Einfo;
+with Types; use Types;
+
+package Set_Targ is
+
+ -----------------------------
+ -- Target-Dependent Values --
+ -----------------------------
+
+ -- The following is a table of target dependent values. In normal operation
+ -- these values are set by calling the appropriate C backend routines that
+ -- interface to back end routines that determine target characteristics.
+
+ -- If the -gnateT switch is used, then any values that are read from the
+ -- file target.atp in the current directory overwrite values set from the
+ -- back end. This is used by tools other than the compiler, e.g. to do
+ -- semantic analysis of programs that will run on some other target than
+ -- the machine on which the tool is run.
+
+ -- Note: fields marked with a question mark are boolean fields, where a
+ -- value of 0 is False, and a value of 1 is True.
+
+ Bits_BE : Nat; -- Bits stored big-endian?
+ Bits_Per_Unit : Pos; -- Bits in a storage unit
+ Bits_Per_Word : Pos; -- Bits in a word
+ Bytes_BE : Nat; -- Bytes stored big-endian?
+ Char_Size : Pos; -- Standard.Character'Size
+ Double_Float_Alignment : Nat; -- Alignment of double float
+ Double_Scalar_Alignment : Nat; -- Alignment of double length scalar
+ Double_Size : Pos; -- Standard.Long_Float'Size
+ Float_Size : Pos; -- Standard.Float'Size
+ Float_Words_BE : Nat; -- Float words stored big-endian?
+ Int_Size : Pos; -- Standard.Integer'Size
+ Long_Double_Size : Pos; -- Standard.Long_Long_Float'Size
+ Long_Long_Size : Pos; -- Standard.Long_Long_Integer'Size
+ Long_Size : Pos; -- Standard.Long_Integer'Size
+ Maximum_Alignment : Pos; -- Maximum permitted alignment
+ Max_Unaligned_Field : Pos; -- Maximum size for unaligned bit field
+ Pointer_Size : Pos; -- System.Address'Size
+ Short_Size : Pos; -- Standard.Short_Integer'Size
+ Strict_Alignment : Nat; -- Strict alignment?
+ System_Allocator_Alignment : Nat; -- Alignment for malloc calls
+ Wchar_T_Size : Pos; -- Interfaces.C.wchar_t'Size
+ Words_BE : Nat; -- Words stored big-endian?
+
+ -------------------------------------
+ -- Registered Floating-Point Types --
+ -------------------------------------
+
+ -- This table contains the list of modes supported by the back-end as
+ -- provided by the back end routine enumerate_modes in misc.c. Note that
+ -- we only store floating-point modes (see Register_Float_Type).
+
+ type FPT_Mode_Entry is record
+ NAME : String_Ptr; -- Name of mode (no null character at end)
+ DIGS : Natural; -- Digits for floating-point type
+ FLOAT_REP : Float_Rep_Kind; -- Float representation
+ SIZE : Natural; -- Size in bits
+ ALIGNMENT : Natural; -- Alignment in bits
+ end record;
+
+ FPT_Mode_Table : array (1 .. 1000) of FPT_Mode_Entry;
+ Num_FPT_Modes : Natural;
+ -- Table containing the supported modes and number of entries
+
+ -----------------
+ -- Subprograms --
+ -----------------
+
+ procedure Write_Target_Dependent_Values;
+ -- This routine writes the file target.atp in the current directory with
+ -- the values of the global target parameters as listed above, and as set
+ -- by prior calls to Initialize/Read_Target_Dependent_Values. The format
+ -- of the target.atp file is as follows
+ --
+ -- First come the values of the variables defined in this spec:
+ --
+ -- One line per value
+ --
+ -- name value
+ --
+ -- where name is the name of the parameter, spelled out in full,
+ -- and cased as in the above list, and value is an unsigned decimal
+ -- integer. Two or more blanks separates the name from the value.
+ --
+ -- All the variables must be present, in alphabetical order (i.e. the
+ -- same order as the declarations in this spec).
+ --
+ -- Then there is a blank line to separate the two parts of the file. Then
+ -- come the lines showing the floating-point types to be registered.
+ --
+ -- One line per registered mode
+ --
+ -- name digs float_rep size alignment
+ --
+ -- where name is the string name of the type (which can have single
+ -- spaces embedded in the name (e.g. long double). The name is followed
+ -- by at least two blanks. The following fields are as described above
+ -- for a Mode_Entry (where float_rep is I/V/A for IEEE-754-Binary,
+ -- Vax_Native, AAMP), fields are separated by at least one blank, and
+ -- a LF character immediately follows the alignment field.
+ --
+ -- It is a fatal error to call this procedure if the target.atp file is
+ -- not found in the current directory.
+
+end Set_Targ;
-- output. A line containing this escape sequence may not also contain
-- a ^alpha^beta^ sequence.
--- Process @ifset and @ifclear for the target flags (unw, vms);
--- this is because we have menu problems if we let makeinfo handle
--- these ifset/ifclear pairs.
--- Note: @ifset/@ifclear commands for the edition flags (FSFEDITION,
--- PROEDITION, GPLEDITION) are passed through unchanged
-
with Ada.Command_Line; use Ada.Command_Line;
with Ada.Strings; use Ada.Strings;
with Ada.Strings.Fixed; use Ada.Strings.Fixed;
projects / thirdparty / gcc.git / commitdiff
