diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 18 | ||||
| -rw-r--r-- | gcc/ada/exp_cg.adb | 11 | ||||
| -rw-r--r-- | gcc/ada/exp_ch5.adb | 6 | ||||
| -rw-r--r-- | gcc/ada/sem_ch13.adb | 40 | ||||
| -rw-r--r-- | gcc/ada/sem_disp.adb | 30 |
5 files changed, 83 insertions, 22 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index cf85151..1d33f86 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,21 @@ +2010-10-04 Javier Miranda <miranda@adacore.com> + + * exp_cg.adb (Expand_N_Assignment_Statement): Restore tag check when + the target object is an interface. + * sem_disp.adb (Propagate_Tag): If the controlling argument is an + interface type then we generate an implicit conversion to force + displacement of the pointer to the object to reference the secondary + dispatch table associated with the interface. + +2010-10-04 Robert Dewar <dewar@adacore.com> + + * sem_ch13.adb (Analyze_Enumeration_Representation_Clause): Set + Enumeration_Rep_Expr to point to the literal, not the identifier. + (Analyze_Enumeration_Representation_Clause): Improve error message for + size too small for enum rep value + (Analyze_Enumeration_Representation_Clause): Fix size test to use proper + size (RM_Size, not Esize). + 2010-10-04 Robert Dewar <dewar@adacore.com> * s-taprop-vxworks.adb, sem_res.adb: Minor reformatting. diff --git a/gcc/ada/exp_cg.adb b/gcc/ada/exp_cg.adb index 1addb94..4aa7b0b 100644 --- a/gcc/ada/exp_cg.adb +++ b/gcc/ada/exp_cg.adb @@ -409,6 +409,7 @@ package body Exp_CG is Nul : constant Character := Character'First; Line : String (Str'First .. Str'Last + 1); Errno : Integer; + begin -- Add the null character to the string as required by fputs @@ -583,9 +584,9 @@ package body Exp_CG is if Present (Interface_Alias (Prim)) or else - (Present (Alias (Prim)) - and then Find_Dispatching_Type (Prim) - /= Find_Dispatching_Type (Alias (Prim))) + (Present (Alias (Prim)) + and then Find_Dispatching_Type (Prim) /= + Find_Dispatching_Type (Alias (Prim))) then goto Continue; end if; @@ -641,8 +642,8 @@ package body Exp_CG is Int_Alias := Interface_Alias (Prim_Op); if Present (Int_Alias) - and then not Is_Ancestor - (Find_Dispatching_Type (Int_Alias), Typ) + and then + not Is_Ancestor (Find_Dispatching_Type (Int_Alias), Typ) and then (Alias (Prim_Op)) = Prim then Write_Char (','); diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 18bda5d..fb1888da 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -1956,12 +1956,6 @@ package body Exp_Ch5 is if Is_Class_Wide_Type (Typ) and then Is_Tagged_Type (Typ) and then Is_Tagged_Type (Underlying_Type (Etype (Rhs))) - - -- Do not generate a tag check when the target object is - -- an interface since the expression of the right hand - -- side must only cover the interface. - - and then not Is_Interface (Typ) then Append_To (L, Make_Raise_Constraint_Error (Loc, diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index b3dd42c..ef46ad7 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -2098,10 +2098,16 @@ package body Sem_Ch13 is Val : Uint; Err : Boolean := False; - Lo : constant Uint := Expr_Value (Type_Low_Bound (Universal_Integer)); - Hi : constant Uint := Expr_Value (Type_High_Bound (Universal_Integer)); + Lo : constant Uint := Expr_Value (Type_Low_Bound (Universal_Integer)); + Hi : constant Uint := Expr_Value (Type_High_Bound (Universal_Integer)); + -- Allowed range of universal integer (= allowed range of enum lit vals) + Min : Uint; Max : Uint; + -- Minimum and maximum values of entries + + Max_Node : Node_Id; + -- Pointer to node for literal providing max value begin if Ignore_Rep_Clauses then @@ -2260,7 +2266,7 @@ package body Sem_Ch13 is Err := True; end if; - Set_Enumeration_Rep_Expr (Elit, Choice); + Set_Enumeration_Rep_Expr (Elit, Expression (Assoc)); Expr := Expression (Assoc); Val := Static_Integer (Expr); @@ -2306,15 +2312,16 @@ package body Sem_Ch13 is if Max /= No_Uint and then Val <= Max then Error_Msg_NE ("enumeration value for& not ordered!", - Enumeration_Rep_Expr (Elit), Elit); + Enumeration_Rep_Expr (Elit), Elit); end if; + Max_Node := Enumeration_Rep_Expr (Elit); Max := Val; end if; - -- If there is at least one literal whose representation - -- is not equal to the Pos value, then note that this - -- enumeration type has a non-standard representation. + -- If there is at least one literal whose representation is not + -- equal to the Pos value, then note that this enumeration type + -- has a non-standard representation. if Val /= Enumeration_Pos (Elit) then Set_Has_Non_Standard_Rep (Base_Type (Enumtype)); @@ -2331,15 +2338,28 @@ package body Sem_Ch13 is begin if Has_Size_Clause (Enumtype) then - if Esize (Enumtype) >= Minsize then + + -- All OK, if size is OK now + + if RM_Size (Enumtype) >= Minsize then null; else + -- Try if we can get by with biasing + Minsize := UI_From_Int (Minimum_Size (Enumtype, Biased => True)); - if Esize (Enumtype) < Minsize then - Error_Msg_N ("previously given size is too small", N); + -- Error message if even biasing does not work + + if RM_Size (Enumtype) < Minsize then + Error_Msg_Uint_1 := RM_Size (Enumtype); + Error_Msg_Uint_2 := Max; + Error_Msg_N + ("previously given size (^) is too small " + & "for this value (^)", Max_Node); + + -- If biasing worked, indicate that we now have biased rep else Set_Has_Biased_Representation (Enumtype); diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb index 6984693..f40df26 100644 --- a/gcc/ada/sem_disp.adb +++ b/gcc/ada/sem_disp.adb @@ -1959,7 +1959,35 @@ package body Sem_Disp is -- and would have to undo any expansion to an indirect call. if Tagged_Type_Expansion then - Expand_Dispatching_Call (Call_Node); + declare + Call_Typ : constant Entity_Id := Etype (Call_Node); + + begin + Expand_Dispatching_Call (Call_Node); + + -- If the controlling argument is an interface type and the type + -- of Call_Node differs then we must add an implicit conversion to + -- force displacement of the pointer to the object to reference + -- the secondary dispatch table of the interface. + + if Is_Interface (Etype (Control)) + and then Etype (Control) /= Call_Typ + then + -- Cannot use Convert_To because the previous call to + -- Expand_Dispatching_Call leaves decorated the Call_Node + -- with the type of Control. + + Rewrite (Call_Node, + Make_Type_Conversion (Sloc (Call_Node), + Subtype_Mark => + New_Occurrence_Of (Etype (Control), Sloc (Call_Node)), + Expression => Relocate_Node (Call_Node))); + Set_Etype (Call_Node, Etype (Control)); + Set_Analyzed (Call_Node); + + Expand_Interface_Conversion (Call_Node, Is_Static => False); + end if; + end; -- Expansion of a dispatching call results in an indirect call, which in -- turn causes current values to be killed (see Resolve_Call), so on VM |