]> gcc.gnu.org Git - gcc.git/commitdiff
[multiple changes]
authorArnaud Charlet <charlet@gcc.gnu.org>
Thu, 23 Oct 2014 10:39:50 +0000 (12:39 +0200)
committerArnaud Charlet <charlet@gcc.gnu.org>
Thu, 23 Oct 2014 10:39:50 +0000 (12:39 +0200)
2014-10-23  Ed Schonberg  <schonberg@adacore.com>

* sem_ch6.adb (Analyze_Expression_Function): Simplify analysis
in generic context, and generate body in this case as well,
to simplify ASIS traversals on the construct.

2014-10-23  Ed Schonberg  <schonberg@adacore.com>

* sem_ch4.adb (Complete_Object_Operation): Indicate that the
scope of the operation (s) is referenced, to prevent spurious
warnings about unused units.

2014-10-23  Johannes Kanig  <kanig@adacore.com>

* errout.adb (Error_Msg_Internal): Copy check flag, increment
check msg count.
* erroutc.adb (Delete_Msg) adjust check msg count.
(Output_Msg_Text) handle check msg case (do nothing).
(Prescan_Message) recognize check messages with severity prefixes.
* errutil.adb (Error_Msg) handle check flag, adjust counter.

2014-10-23  Ed Schonberg  <schonberg@adacore.com>

* sem_eval.adb (Subtypes_Statically_Match): For a generic actual
type, check for the presence of discriminants in its parent type,
against the presence of discriminants in the context type.

2014-10-23  Tristan Gingold  <gingold@adacore.com>

* adaint.c: __gnat_get_file_names_case_sensitive: Default is
true on arm-darwin.

2014-10-23  Arnaud Charlet  <charlet@adacore.com>

* pprint.adb (Expression_Image): Add handling of quantifiers.

2014-10-23  Ed Schonberg  <schonberg@adacore.com>

* exp_pakd.adb (Expand_Packed_Element_Reference): If the
prefix is a source entity, generate a reference to it before
transformation, because rewritten node might not generate a
proper reference, leading to spurious warnings.

2014-10-23  Tristan Gingold  <gingold@adacore.com>

* init.c: Fix thinko in previous patch.

2014-10-23  Hristian Kirtchev  <kirtchev@adacore.com>

* sem_ch3.adb (Decimal_Fixed_Point_Type_Declaration):
Inherit the rep chain of the implicit base type.
(Floating_Point_Type_Declaration): Inherit the rep chain of the
implicit base type.
(Ordinary_Fixed_Point_Type_Declaration): Inherit the rep chain of the
implicit base type.
(Signed_Integer_Type_Declaration): Inherit the rep chain of the
implicit base type.
* sem_util.ads, sem_util.adb (Inherit_Rep_Item_Chain): New routine.

2014-10-23  Pascal Obry  <obry@adacore.com>

* g-regist.adb, g-regist.ads: Add support for reading 32bit or 64bit
view of the registry.

2014-10-23  Ed Schonberg  <schonberg@adacore.com>

* exp_ch3.adb (Expand_N_Object_Declaration): If type is abstract,
return without expanding expression, to prevent subsequent crash.
* freeze.adb: better error message for illegal declaration.

From-SVN: r216587

21 files changed:
gcc/ada/ChangeLog
gcc/ada/adaint.c
gcc/ada/atree.ads
gcc/ada/errout.adb
gcc/ada/errout.ads
gcc/ada/erroutc.adb
gcc/ada/erroutc.ads
gcc/ada/errutil.adb
gcc/ada/exp_ch3.adb
gcc/ada/exp_pakd.adb
gcc/ada/freeze.adb
gcc/ada/g-regist.adb
gcc/ada/g-regist.ads
gcc/ada/init.c
gcc/ada/pprint.adb
gcc/ada/sem_ch3.adb
gcc/ada/sem_ch4.adb
gcc/ada/sem_ch6.adb
gcc/ada/sem_eval.adb
gcc/ada/sem_util.adb
gcc/ada/sem_util.ads

index 88bfeb73b023a298b20c7039b02b661bcf13b631..353d0a5f1be0cc637f83d9e4148d5f655726fb40 100644 (file)
@@ -1,3 +1,73 @@
+2014-10-23  Ed Schonberg  <schonberg@adacore.com>
+
+       * sem_ch6.adb (Analyze_Expression_Function): Simplify analysis
+       in generic context, and generate body in this case as well,
+       to simplify ASIS traversals on the construct.
+
+2014-10-23  Ed Schonberg  <schonberg@adacore.com>
+
+       * sem_ch4.adb (Complete_Object_Operation): Indicate that the
+       scope of the operation (s) is referenced, to prevent spurious
+       warnings about unused units.
+
+2014-10-23  Johannes Kanig  <kanig@adacore.com>
+
+       * errout.adb (Error_Msg_Internal): Copy check flag, increment
+       check msg count.
+       * erroutc.adb (Delete_Msg) adjust check msg count.
+       (Output_Msg_Text) handle check msg case (do nothing).
+       (Prescan_Message) recognize check messages with severity prefixes.
+       * errutil.adb (Error_Msg) handle check flag, adjust counter.
+
+2014-10-23  Ed Schonberg  <schonberg@adacore.com>
+
+       * sem_eval.adb (Subtypes_Statically_Match): For a generic actual
+       type, check for the presence of discriminants in its parent type,
+       against the presence of discriminants in the context type.
+
+2014-10-23  Tristan Gingold  <gingold@adacore.com>
+
+       * adaint.c: __gnat_get_file_names_case_sensitive: Default is
+       true on arm-darwin.
+
+2014-10-23  Arnaud Charlet  <charlet@adacore.com>
+
+       * pprint.adb (Expression_Image): Add handling of quantifiers.
+
+2014-10-23  Ed Schonberg  <schonberg@adacore.com>
+
+       * exp_pakd.adb (Expand_Packed_Element_Reference): If the
+       prefix is a source entity, generate a reference to it before
+       transformation, because rewritten node might not generate a
+       proper reference, leading to spurious warnings.
+
+2014-10-23  Tristan Gingold  <gingold@adacore.com>
+
+       * init.c: Fix thinko in previous patch.
+
+2014-10-23  Hristian Kirtchev  <kirtchev@adacore.com>
+
+       * sem_ch3.adb (Decimal_Fixed_Point_Type_Declaration):
+       Inherit the rep chain of the implicit base type.
+       (Floating_Point_Type_Declaration): Inherit the rep chain of the
+       implicit base type.
+       (Ordinary_Fixed_Point_Type_Declaration): Inherit the rep chain of the
+       implicit base type.
+       (Signed_Integer_Type_Declaration): Inherit the rep chain of the
+       implicit base type.
+       * sem_util.ads, sem_util.adb (Inherit_Rep_Item_Chain): New routine.
+
+2014-10-23  Pascal Obry  <obry@adacore.com>
+
+       * g-regist.adb, g-regist.ads: Add support for reading 32bit or 64bit
+       view of the registry.
+
+2014-10-23  Ed Schonberg  <schonberg@adacore.com>
+
+       * exp_ch3.adb (Expand_N_Object_Declaration): If type is abstract,
+       return without expanding expression, to prevent subsequent crash.
+       * freeze.adb: better error message for illegal declaration.
+
 2014-10-23  Hristian Kirtchev  <kirtchev@adacore.com>
 
        * sysdep.c (__gnat_localtime_tzoff): Properly delimit the
index 02bce4532973ded6b669a4c580838c1a4e2a5123..0acaa74d3ab4971806b286cc3cce7629c9dfda7a 100644 (file)
@@ -547,11 +547,15 @@ __gnat_get_file_names_case_sensitive (void)
           && sensitive[1] == '\0')
         file_names_case_sensitive_cache = sensitive[0] - '0';
       else
-#if defined (WINNT) || defined (__APPLE__)
-        file_names_case_sensitive_cache = 0;
+       {
+         /* By default, we suppose filesystems aren't case sensitive on
+            Windows and Darwin (but they are on arm-darwin).  */
+#if defined (WINNT) || (defined (__APPLE__) && !defined (__arm__))
+         file_names_case_sensitive_cache = 0;
 #else
-        file_names_case_sensitive_cache = 1;
+         file_names_case_sensitive_cache = 1;
 #endif
+       }
     }
   return file_names_case_sensitive_cache;
 }
index 37b276e9cdbf8d38ec0516466107f37de2638897..3bc71f5974d6bf3e0d065d6edc14ca61fe67c491 100644 (file)
@@ -320,6 +320,10 @@ package Atree is
    --  Number of info messages generated. Info messages are neved treated as
    --  errors (whether from use of the pragma, or the compiler switch -gnatwe).
 
+   Check_Messages : Nat := 0;
+   --  Number of check messages generated. Check messages are neither warnings
+   --  nor errors.
+
    Warnings_Treated_As_Errors : Nat := 0;
    --  Number of warnings changed into errors as a result of matching a pattern
    --  given in a Warning_As_Error configuration pragma.
index e540b41a3dda2f398396b976ce742fbfa6a29362..911820c0363f446b2dddbe47696a7f5176a74d32 100644 (file)
@@ -982,6 +982,7 @@ package body Errout is
           Col      => Get_Column_Number (Sptr),
           Warn     => Is_Warning_Msg,
           Info     => Is_Info_Msg,
+          Check    => Is_Check_Msg,
           Warn_Err => False, -- reset below
           Warn_Chr => Warning_Msg_Char,
           Style    => Is_Style_Msg,
@@ -1140,6 +1141,9 @@ package body Errout is
             Info_Messages := Info_Messages + 1;
          end if;
 
+      elsif Errors.Table (Cur_Msg).Check then
+         Check_Messages := Check_Messages + 1;
+
       else
          Total_Errors_Detected := Total_Errors_Detected + 1;
 
index ef4a9cf682b3a8a9ebc49a68e346cd2f06cb749a..6ca45497fdef75a9d7940217e317a0357d82b164 100644 (file)
@@ -413,6 +413,13 @@ package Errout is
    --      are continuations that are not printed using the -gnatj switch they
    --      will also have this prefix.
 
+   --    Insertion sequence "low: " or "medium: " or "high: " (check message)
+   --      This appears only at the start of the message (and not any of its
+   --      continuations, if any), and indicates that the message is a check
+   --      message. The message will be output with this prefix. Check
+   --      messages are not fatal (so are like info messages in that respect)
+   --      and are not controlled by pragma Warnings.
+
    -----------------------------------------------------
    -- Global Values Used for Error Message Insertions --
    -----------------------------------------------------
index f4f1dfd1c8d4d1f0c4cd324b552d4597b5afb695..32d9bbc786594b946dee5de58c06e2fbdf9476b8 100644 (file)
@@ -145,6 +145,9 @@ package body Erroutc is
                --  because this only gets incremented if we actually output the
                --  message, which we won't do if we are deleting it here!
 
+            elsif Errors.Table (D).Check then
+               Check_Messages := Check_Messages - 1;
+
             else
                Total_Errors_Detected := Total_Errors_Detected - 1;
 
@@ -653,6 +656,11 @@ package body Erroutc is
          elsif Errors.Table (E).Style then
             null;
 
+            --  No prefix needed for check message, severity is there already
+
+         elsif Errors.Table (E).Check then
+            null;
+
             --  All other cases, add "error: " if unique error tag set
 
          elsif Opt.Unique_Error_Tag then
@@ -765,6 +773,15 @@ package body Erroutc is
       Is_Info_Msg :=
         Msg'Length > 6 and then Msg (Msg'First .. Msg'First + 5) = "info: ";
 
+      --  Check check message
+
+      Is_Check_Msg :=
+        (Msg'Length > 8 and then Msg (Msg'First .. Msg'First + 7) = "medium: ")
+        or else
+          (Msg'Length > 6 and then Msg (Msg'First .. Msg'First + 5) = "high: ")
+        or else
+          (Msg'Length > 5 and then Msg (Msg'First .. Msg'First + 4) = "low: ");
+
       --  Loop through message looking for relevant insertion sequences
 
       J := Msg'First;
@@ -833,7 +850,7 @@ package body Erroutc is
          end if;
       end loop;
 
-      if Is_Warning_Msg or Is_Style_Msg then
+      if Is_Warning_Msg or Is_Style_Msg or Is_Check_Msg then
          Is_Serious_Error := False;
       end if;
    end Prescan_Message;
index f23f4df588f9c78d773ae71defe302bcd5befbd6..cb69f17f8b9daba0aa7f10cb665e3293cce9dccc 100644 (file)
@@ -68,6 +68,10 @@ package Erroutc is
    --  "info: " and is to be treated as an information message. This string
    --  will be prepended to the message and all its continuations.
 
+   Is_Check_Msg : Boolean := False;
+   --  Set True to indicate that the current message starts with one of
+   --  "high: ", "medium: ", "low: " and is to be treated as a check message.
+
    Warning_Msg_Char : Character;
    --  Warning character, valid only if Is_Warning_Msg is True
    --    ' '      -- ?   or <   appeared on its own in message
@@ -208,6 +212,9 @@ package Erroutc is
       Info : Boolean;
       --  True if info message
 
+      Check : Boolean;
+      --  True if check message
+
       Warn_Err : Boolean;
       --  True if this is a warning message which is to be treated as an error
       --  as a result of a match with a Warning_As_Error pragma.
index 7eb85a4193aa40c05673eb83ef61c05b09a54a9e..9fd67e16a741f9128b6bbedf514f0dd387af538a 100644 (file)
@@ -213,6 +213,7 @@ package body Errutil is
             Col      => Get_Column_Number (Sptr),
             Warn     => Is_Warning_Msg,
             Info     => Is_Info_Msg,
+            Check    => Is_Check_Msg,
             Warn_Err => Warning_Mode = Treat_As_Error,
             Warn_Chr => Warning_Msg_Char,
             Style    => Is_Style_Msg,
@@ -313,6 +314,9 @@ package body Errutil is
             Info_Messages := Info_Messages + 1;
          end if;
 
+      elsif Errors.Table (Cur_Msg).Check then
+         Check_Messages := Check_Messages + 1;
+
       else
          Total_Errors_Detected := Total_Errors_Detected + 1;
 
index 3aecc9ba37013db0633299dd3305882ca720ffe1..1480c0fa5258eba9139d996921aa7870e03ce558 100644 (file)
@@ -5346,6 +5346,14 @@ package body Exp_Ch3 is
          return;
       end if;
 
+      --  The type of the object cannot be abstract. This is diagnosed at the
+      --  point the object is frozen, which happens after the declaration is
+      --  fully expanded, so simply return now.
+
+      if Is_Abstract_Type (Typ) then
+         return;
+      end if;
+
       --  First we do special processing for objects of a tagged type where
       --  this is the point at which the type is frozen. The creation of the
       --  dispatch table and the initialization procedure have to be deferred
index 21487c0b3f59dedbe80959a185aac584f4a4316e..e6bcb9998690d6dca56085909180e343a1710253 100644 (file)
@@ -30,6 +30,7 @@ with Errout;   use Errout;
 with Exp_Dbug; use Exp_Dbug;
 with Exp_Util; use Exp_Util;
 with Layout;   use Layout;
+with Lib.Xref; use Lib.Xref;
 with Namet;    use Namet;
 with Nlists;   use Nlists;
 with Nmake;    use Nmake;
@@ -1682,6 +1683,16 @@ package body Exp_Pakd is
          Expand_Packed_Element_Reference (Prefix (N));
       end if;
 
+      --  The prefix may be rewritten below as a conversion. If it is a source
+      --  entity generate reference to it now, to prevent spurious warnings
+      --  about unused entities.
+
+      if Is_Entity_Name (Prefix (N))
+        and then Comes_From_Source (Prefix (N))
+      then
+         Generate_Reference (Entity (Prefix (N)), Prefix (N), 'r');
+      end if;
+
       --  If not bit packed, we have the enumeration case, which is easily
       --  dealt with (just adjust the subscripts of the indexed component)
 
index 156afda2e655ed4eee4b5eb344767c72e875d77f..44921d0243c7c4a103b97f6f19a0a880de12e23a 100644 (file)
@@ -4498,6 +4498,11 @@ package body Freeze is
                      Error_Msg_NE
                        ("\} may need a cpp_constructor",
                        Object_Definition (Parent (E)), Etype (E));
+
+                  elsif Present (Expression (Parent (E))) then
+                     Error_Msg_N --  CODEFIX
+                       ("\maybe a class-wide type was meant",
+                         Object_Definition (Parent (E)));
                   end if;
                end if;
 
index ba63b3c8326103103f3a389a738969f0857d6fab..4d989630151157f647d66a052e794bf011bf7bad 100644 (file)
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---           Copyright (C) 2001-2009, Free Software Foundation, Inc.        --
+--           Copyright (C) 2001-2014, 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- --
@@ -529,16 +529,24 @@ package body GNAT.Registry is
    function To_C_Mode (Mode : Key_Mode) return REGSAM is
       use type REGSAM;
 
-      KEY_READ  : constant :=  16#20019#;
-      KEY_WRITE : constant :=  16#20006#;
+      KEY_READ        : constant := 16#20019#;
+      KEY_WRITE       : constant := 16#20006#;
+      KEY_WOW64_64KEY : constant := 16#00100#;
+      KEY_WOW64_32KEY : constant := 16#00200#;
 
    begin
       case Mode is
          when Read_Only =>
-            return KEY_READ;
+            return KEY_READ + KEY_WOW64_32KEY;
 
          when Read_Write =>
-            return KEY_READ + KEY_WRITE;
+            return KEY_READ + KEY_WRITE + KEY_WOW64_32KEY;
+
+         when Read_Only_64 =>
+            return KEY_READ + KEY_WOW64_64KEY;
+
+         when Read_Write_64 =>
+            return KEY_READ + KEY_WRITE + KEY_WOW64_64KEY;
       end case;
    end To_C_Mode;
 
index c7ad4dcfe117bdc86f08d35b72a3c3ae9c5a2f41..0222a1079ef2c6f1e4a828752460b043b453d6d5 100644 (file)
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 2001-2011, Free Software Foundation, Inc.         --
+--          Copyright (C) 2001-2014, 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- --
@@ -54,8 +54,12 @@ package GNAT.Registry is
    HKEY_USERS            : constant HKEY;
    HKEY_PERFORMANCE_DATA : constant HKEY;
 
-   type Key_Mode is (Read_Only, Read_Write);
-   --  Access mode for the registry key
+   type Key_Mode is
+      (Read_Only, Read_Write,        -- operates on 32bit view of the registry
+       Read_Only_64, Read_Write_64); -- operates on 64bit view of the registry
+   --  Access mode for the registry key. The *_64 are only meaningful on
+   --  Windows 64bit and ignored on Windows 32bit where _64 are equivalent to
+   --  the non 64bit versions.
 
    Registry_Error : exception;
    --  Registry_Error is raises by all routines below if a problem occurs
index 9a2290534947b58226526d0f6f0d434f66ab8162..8a33966d62ba9efac5d919ce929712b8be5a255e 100644 (file)
@@ -2238,7 +2238,7 @@ __gnat_is_stack_guard (mach_vm_address_t addr)
   return 0;
 #else
   /* Pagezero for arm.  */
-  return addr < 4096;
+  return addr >= 4096;
 #endif
 }
 
index 8ac3ac63688fff805096c4fbcbe15efea1bd2dd1..f726b644bad93ae475b52b704df03c7c172b0bab 100644 (file)
@@ -623,6 +623,9 @@ package body Pprint is
                   exit;
                end if;
 
+            when N_Quantified_Expression =>
+               Right := Original_Node (Condition (Right));
+
             --  For all other items, quit the loop
 
             when others =>
index e29b65ace0def3baf978f28e2d3f0b73bc4e277c..27c228647d8130979e5a9516becd0c08f5eebca6 100644 (file)
@@ -13914,17 +13914,19 @@ package body Sem_Ch3 is
          Set_Fixed_Range (T, Loc, -Bound_Val, Bound_Val);
       end if;
 
-      --  Complete entity for first subtype
-
-      Set_Ekind          (T, E_Decimal_Fixed_Point_Subtype);
-      Set_Etype          (T, Implicit_Base);
-      Set_Size_Info      (T, Implicit_Base);
-      Set_First_Rep_Item (T, First_Rep_Item (Implicit_Base));
-      Set_Digits_Value   (T, Digs_Val);
-      Set_Delta_Value    (T, Delta_Val);
-      Set_Small_Value    (T, Delta_Val);
-      Set_Scale_Value    (T, Scale_Val);
-      Set_Is_Constrained (T);
+      --  Complete entity for first subtype. The inheritance of the rep item
+      --  chain ensures that SPARK-related pragmas are not clobbered when the
+      --  decimal fixed point type acts as a full view of a private type.
+
+      Set_Ekind              (T, E_Decimal_Fixed_Point_Subtype);
+      Set_Etype              (T, Implicit_Base);
+      Set_Size_Info          (T, Implicit_Base);
+      Inherit_Rep_Item_Chain (T, Implicit_Base);
+      Set_Digits_Value       (T, Digs_Val);
+      Set_Delta_Value        (T, Delta_Val);
+      Set_Small_Value        (T, Delta_Val);
+      Set_Scale_Value        (T, Scale_Val);
+      Set_Is_Constrained     (T);
    end Decimal_Fixed_Point_Type_Declaration;
 
    -----------------------------------
@@ -16725,24 +16727,25 @@ package body Sem_Ch3 is
          Set_Scalar_Range (T, Scalar_Range (Base_Typ));
       end if;
 
-      --  Complete definition of implicit base and declared first subtype
-
-      Set_Etype          (Implicit_Base, Base_Typ);
-
-      Set_Scalar_Range   (Implicit_Base, Scalar_Range   (Base_Typ));
-      Set_Size_Info      (Implicit_Base,                (Base_Typ));
-      Set_RM_Size        (Implicit_Base, RM_Size        (Base_Typ));
-      Set_First_Rep_Item (Implicit_Base, First_Rep_Item (Base_Typ));
-      Set_Digits_Value   (Implicit_Base, Digits_Value   (Base_Typ));
-      Set_Float_Rep      (Implicit_Base, Float_Rep      (Base_Typ));
-
-      Set_Ekind          (T, E_Floating_Point_Subtype);
-      Set_Etype          (T, Implicit_Base);
-
-      Set_Size_Info      (T,                (Implicit_Base));
-      Set_RM_Size        (T, RM_Size        (Implicit_Base));
-      Set_First_Rep_Item (T, First_Rep_Item (Implicit_Base));
-      Set_Digits_Value   (T, Digs_Val);
+      --  Complete definition of implicit base and declared first subtype. The
+      --  inheritance of the rep item chain ensures that SPARK-related pragmas
+      --  are not clobbered when the floating point type acts as a full view of
+      --  a private type.
+
+      Set_Etype              (Implicit_Base,                 Base_Typ);
+      Set_Scalar_Range       (Implicit_Base, Scalar_Range   (Base_Typ));
+      Set_Size_Info          (Implicit_Base,                 Base_Typ);
+      Set_RM_Size            (Implicit_Base, RM_Size        (Base_Typ));
+      Set_First_Rep_Item     (Implicit_Base, First_Rep_Item (Base_Typ));
+      Set_Digits_Value       (Implicit_Base, Digits_Value   (Base_Typ));
+      Set_Float_Rep          (Implicit_Base, Float_Rep      (Base_Typ));
+
+      Set_Ekind              (T, E_Floating_Point_Subtype);
+      Set_Etype              (T,          Implicit_Base);
+      Set_Size_Info          (T,          Implicit_Base);
+      Set_RM_Size            (T, RM_Size (Implicit_Base));
+      Inherit_Rep_Item_Chain (T,          Implicit_Base);
+      Set_Digits_Value       (T, Digs_Val);
    end Floating_Point_Type_Declaration;
 
    ----------------------------
@@ -18436,15 +18439,17 @@ package body Sem_Ch3 is
       Set_Fixed_Range (Implicit_Base, Loc, Low_Val, High_Val);
       Set_Fixed_Range (T, Loc, Low_Val, High_Val);
 
-      --  Complete definition of first subtype
-
-      Set_Ekind          (T, E_Ordinary_Fixed_Point_Subtype);
-      Set_Etype          (T, Implicit_Base);
-      Init_Size_Align    (T);
-      Set_First_Rep_Item (T, First_Rep_Item (Implicit_Base));
-      Set_Small_Value    (T, Small_Val);
-      Set_Delta_Value    (T, Delta_Val);
-      Set_Is_Constrained (T);
+      --  Complete definition of first subtype. The inheritance of the rep item
+      --  chain ensures that SPARK-related pragmas are not clobbered when the
+      --  ordinary fixed point type acts as a full view of a private type.
+
+      Set_Ekind              (T, E_Ordinary_Fixed_Point_Subtype);
+      Set_Etype              (T, Implicit_Base);
+      Init_Size_Align        (T);
+      Inherit_Rep_Item_Chain (T, Implicit_Base);
+      Set_Small_Value        (T, Small_Val);
+      Set_Delta_Value        (T, Delta_Val);
+      Set_Is_Constrained     (T);
    end Ordinary_Fixed_Point_Type_Declaration;
 
    ----------------------------------
@@ -19090,7 +19095,6 @@ package body Sem_Ch3 is
          --  ELSE.
 
          else
-
             --  In formal mode, when completing a private extension the type
             --  named in the private part must be exactly the same as that
             --  named in the visible part.
@@ -21215,23 +21219,24 @@ package body Sem_Ch3 is
          end if;
       end if;
 
-      --  Complete both implicit base and declared first subtype entities
+      --  Complete both implicit base and declared first subtype entities. The
+      --  inheritance of the rep item chain ensures that SPARK-related pragmas
+      --  are not clobbered when the signed integer type acts as a full view of
+      --  a private type.
 
       Set_Etype          (Implicit_Base,                 Base_Typ);
-      Set_Size_Info      (Implicit_Base,                (Base_Typ));
+      Set_Size_Info      (Implicit_Base,                 Base_Typ);
       Set_RM_Size        (Implicit_Base, RM_Size        (Base_Typ));
       Set_First_Rep_Item (Implicit_Base, First_Rep_Item (Base_Typ));
+      Set_Scalar_Range   (Implicit_Base, Scalar_Range   (Base_Typ));
 
-      Set_Ekind          (T, E_Signed_Integer_Subtype);
-      Set_Etype          (T, Implicit_Base);
-
-      Set_Scalar_Range (Implicit_Base, Scalar_Range (Base_Typ));
-
-      Set_Size_Info      (T,                (Implicit_Base));
-      Set_First_Rep_Item (T, First_Rep_Item (Implicit_Base));
-      Set_Scalar_Range   (T, Def);
-      Set_RM_Size        (T, UI_From_Int (Minimum_Size (T)));
-      Set_Is_Constrained (T);
+      Set_Ekind              (T, E_Signed_Integer_Subtype);
+      Set_Etype              (T, Implicit_Base);
+      Set_Size_Info          (T, Implicit_Base);
+      Inherit_Rep_Item_Chain (T, Implicit_Base);
+      Set_Scalar_Range       (T, Def);
+      Set_RM_Size            (T, UI_From_Int (Minimum_Size (T)));
+      Set_Is_Constrained     (T);
    end Signed_Integer_Type_Declaration;
 
 end Sem_Ch3;
index be1b321b253e0213e8067c1e605333b60239a08e..7914fe1e11bcb2335a5bd5738f5dbe0366ecab9c 100644 (file)
@@ -7617,6 +7617,17 @@ package body Sem_Ch4 is
             Rewrite (First_Actual, Obj);
          end if;
 
+         --  The operation is obtained from the dispatch table and not by
+         --  visibility, and may be declared in a unit that is not explicitly
+         --  referenced in the source, but is nevertheless required in the
+         --  context of the current unit. Indicate that operation and its scope
+         --  are referenced, to prevent spurious and misleading warnings. If
+         --  the operation is overloaded, all primitives are in the same scope
+         --  and we can use any of them.
+
+         Set_Referenced (Entity (Subprog), True);
+         Set_Referenced (Scope (Entity (Subprog)), True);
+
          Rewrite (Node_To_Replace, Call_Node);
 
          --  Propagate the interpretations collected in subprog to the new
index 8940d82570472b1106d236d42b79d2278a72a43a..2466e87cbba12e0c7e29bd6e25e45762561fa593 100644 (file)
@@ -454,24 +454,20 @@ package body Sem_Ch6 is
 
          Analyze (N);
 
-         --  Within a generic we only need to analyze the expression. The body
-         --  only needs to be constructed when generating code.
+         --  Within a generic pre-analyze the original expression for name
+         --  capture. The body is also generated but plays no role in
+         --  this because it is not part of the original source.
 
          if Inside_A_Generic then
             declare
                Id : constant Entity_Id := Defining_Entity (N);
-               Save_In_Spec_Expression : constant Boolean
-                  := In_Spec_Expression;
 
             begin
                Set_Has_Completion (Id);
-               In_Spec_Expression := True;
                Push_Scope (Id);
                Install_Formals (Id);
-               Preanalyze_And_Resolve (Expr, Etype (Id));
+               Preanalyze_Spec_Expression (Expr, Etype (Id));
                End_Scope;
-               In_Spec_Expression := Save_In_Spec_Expression;
-               return;
             end;
          end if;
 
index 43db1c74cf18f04efae4500a2102257f0560b6f3..1922d5eca9c3eba249703ae0fcbd8a2b77278d05 100644 (file)
@@ -5737,7 +5737,17 @@ package body Sem_Eval is
          --  same base type.
 
          if Has_Discriminants (T1) /= Has_Discriminants (T2) then
-            if In_Instance then
+            --  A generic actual type is declared through a subtype declaration
+            --  and may have an inconsistent indication of the presence of
+            --  discriminants, so check the type it renames.
+
+            if Is_Generic_Actual_Type (T1)
+              and then not Has_Discriminants (Etype (T1))
+              and then not Has_Discriminants (T2)
+            then
+               return True;
+
+            elsif In_Instance then
                if Is_Private_Type (T2)
                  and then Present (Full_View (T2))
                  and then Has_Discriminants (Full_View (T2))
index 4b00be0f3fcdaea9101d9e5ef218e3354ae9d85d..09f80949c4c5341daef37f2cf28f497c0f75f167 100644 (file)
@@ -9290,6 +9290,37 @@ package body Sem_Util is
       end if;
    end Inherit_Default_Init_Cond_Procedure;
 
+   ----------------------------
+   -- Inherit_Rep_Item_Chain --
+   ----------------------------
+
+   procedure Inherit_Rep_Item_Chain (Typ : Entity_Id; From_Typ : Entity_Id) is
+      From_Item : constant Node_Id := First_Rep_Item (From_Typ);
+      Item      : Node_Id;
+
+   begin
+      --  Reach the end of the destination type's chain (if any). The traversal
+      --  ensures that we do not go past the last item.
+
+      Item := First_Rep_Item (Typ);
+      while Present (Item) and then Present (Next_Rep_Item (Item)) loop
+         Item := Next_Rep_Item (Item);
+      end loop;
+
+      --  When the destination type has a rep item chain, the chain of the
+      --  source type is appended to it.
+
+      if Present (Item) then
+         Set_Next_Rep_Item (Item, From_Item);
+
+      --  Otherwise the destination type directly inherits the rep item chain
+      --  of the source type.
+
+      else
+         Set_First_Rep_Item (Typ, From_Item);
+      end if;
+   end Inherit_Rep_Item_Chain;
+
    ---------------------------------
    -- Insert_Explicit_Dereference --
    ---------------------------------
index 2892916c75708b4687f7d7b2dea3f810035c9378..4ddbe615762dfd34a6ad0555002488c4e8d4f9bb 100644 (file)
@@ -1083,6 +1083,10 @@ package Sem_Util is
    --  Inherit the default initial condition procedure from the parent type of
    --  derived type Typ.
 
+   procedure Inherit_Rep_Item_Chain (Typ : Entity_Id; From_Typ : Entity_Id);
+   --  Inherit the rep item chain of type From_Typ without clobbering any
+   --  existing rep items on Typ's chain. Typ is the destination type.
+
    procedure Insert_Explicit_Dereference (N : Node_Id);
    --  In a context that requires a composite or subprogram type and where a
    --  prefix is an access type, rewrite the access type node N (which is the
This page took 0.147554 seconds and 5 git commands to generate.