+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
&& 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;
}
-- 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.
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,
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;
-- 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 --
-----------------------------------------------------
-- 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;
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
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;
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;
-- "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
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.
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,
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;
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
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;
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)
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;
-- --
-- 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- --
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;
-- --
-- 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- --
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
return 0;
#else
/* Pagezero for arm. */
- return addr < 4096;
+ return addr >= 4096;
#endif
}
exit;
end if;
+ when N_Quantified_Expression =>
+ Right := Original_Node (Condition (Right));
+
-- For all other items, quit the loop
when others =>
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;
-----------------------------------
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;
----------------------------
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;
----------------------------------
-- 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.
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;
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
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;
-- 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))
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 --
---------------------------------
-- 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
projects / gcc.git / commitdiff