+2009-04-15 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * a-calend.adb: Add new constant Nanos_In_Four_Years.
+ (Formatting_Operations.Time_Of): Change the way four year chunks of
+ nanoseconds are added to the intermediate result.
+
+2009-04-15 Nicolas Setton <setton@adacore.com>
+
+ * sysdep.c: Add __APPLE__ in the list of systems where get_immediate
+ does not need to wait for a carriage return.
+
+2009-04-15 Tristan Gingold <gingold@adacore.com>
+
+ * bindgen.adb: Do not generate adafinal if No_Finalization restriction
+ is set.
+
+2009-04-15 Ed Schonberg <schonberg@adacore.com>
+
+ * freeze.adb (Freeze_Entity): improve error message for improper use of
+ incomplete types.
+ Diagnose additional illegal uses of incomplete types in formal parts.
+ appearing in formal parts.
+
+ * sem_ch6.adb (Process_Formals, Analyze_Return_Type): ditto.
+
+2009-04-15 Robert Dewar <dewar@adacore.com>
+
+ * exp_ch4.adb (Expand_N_Allocator): Install test for object too large.
+
2009-04-15 Nicolas Roche <roche@adacore.com>
* adaint.c: Add function __gnat_lwp_self that retrieves the LWP of the
Ada_Min_Year : constant Year_Number := Year_Number'First;
Secs_In_Four_Years : constant := (3 * 365 + 366) * Secs_In_Day;
Secs_In_Non_Leap_Year : constant := 365 * Secs_In_Day;
+ Nanos_In_Four_Years : constant := Secs_In_Four_Years * Nano;
-- Lower and upper bound of Ada time. The zero (0) value of type Time is
-- positioned at year 2150. Note that the lower and upper bound account
-- the input date.
Count := (Year - Year_Number'First) / 4;
- Res_N := Res_N + Time_Rep (Count) * Secs_In_Four_Years * Nano;
+ for Four_Year_Segments in 1 .. Count loop
+ Res_N := Res_N + Nanos_In_Four_Years;
+ end loop;
-- Note that non-leap centennial years are automatically considered
-- leap in the operation above. An adjustment of several days is
"""__gnat_ada_main_program_name"");");
end if;
- WBI ("");
- WBI (" procedure " & Ada_Final_Name.all & ";");
- WBI (" pragma Export (C, " & Ada_Final_Name.all & ", """ &
- Ada_Final_Name.all & """);");
+ if not Cumulative_Restrictions.Set (No_Finalization) then
+ WBI ("");
+ WBI (" procedure " & Ada_Final_Name.all & ";");
+ WBI (" pragma Export (C, " & Ada_Final_Name.all & ", """ &
+ Ada_Final_Name.all & """);");
+ end if;
+
WBI ("");
WBI (" procedure " & Ada_Init_Name.all & ";");
WBI (" pragma Export (C, " & Ada_Init_Name.all & ", """ &
Gen_Adainit_Ada;
- Gen_Adafinal_Ada;
+ -- Generate the adafinal routine unless there is no finalization to do.
+
+ if not Cumulative_Restrictions.Set (No_Finalization) then
+ Gen_Adafinal_Ada;
+ end if;
if Bind_Main_Program and then VM_Target = No_VM then
-- constrain. Such occurrences can be rewritten as aliased objects
-- and their unrestricted access used instead of the coextension.
+ function Size_In_Storage_Elements (E : Entity_Id) return Node_Id;
+ -- Given a type E, returns a node representing the code to compute the
+ -- size in storage elements for the given type. This is not as trivial
+ -- as one might expect, as explained in the body.
+
---------------------------------------
-- Complete_Coextension_Finalization --
---------------------------------------
-- Retrieve the declaration of the body
- Decl := Parent (Parent (
- Corresponding_Body (Parent (Parent (S)))));
+ Decl :=
+ Parent
+ (Parent
+ (Corresponding_Body (Parent (Parent (S)))));
exit;
end if;
Analyze_And_Resolve (N, PtrT);
end Rewrite_Coextension;
+ ------------------------------
+ -- Size_In_Storage_Elements --
+ ------------------------------
+
+ function Size_In_Storage_Elements (E : Entity_Id) return Node_Id is
+ begin
+ -- Logically this just returns E'Max_Size_In_Storage_Elements.
+ -- However, the reason for the existence of this function is
+ -- to construct a test for sizes too large, which means near the
+ -- 32-bit limit on a 32-bit machine, and precisely the trouble
+ -- is that we get overflows when sizes are greater than 2**31.
+
+ -- So what we end up doing is using this expression for non-array
+ -- types, where it is not quite right, but should be good enough
+ -- most of the time. But for non-packed arrays, instead we compute
+ -- the expression:
+
+ -- number-of-elements * component_type'Max_Size_In_Storage_Elements
+
+ -- which avoids this problem. All this is a big bogus, but it does
+ -- mean we catch common cases of trying to allocate arrays that
+ -- are too large, and which in the absence of a check results in
+ -- undetected chaos ???
+
+ if Is_Array_Type (E) and then Is_Constrained (E) then
+ declare
+ Len : Node_Id;
+ Res : Node_Id;
+
+ begin
+ for J in 1 .. Number_Dimensions (E) loop
+ Len :=
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (E, Loc),
+ Attribute_Name => Name_Length,
+ Expressions => New_List (
+ Make_Integer_Literal (Loc, J)));
+
+ if J = 1 then
+ Res := Len;
+
+ else
+ Res :=
+ Make_Op_Multiply (Loc,
+ Left_Opnd => Res,
+ Right_Opnd => Len);
+ end if;
+ end loop;
+
+ return
+ Make_Op_Multiply (Loc,
+ Left_Opnd => Len,
+ Right_Opnd =>
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Component_Type (E), Loc),
+ Attribute_Name => Name_Max_Size_In_Storage_Elements));
+ end;
+
+ -- Here for other than non-bit-packed array
+
+ else
+ return
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (E, Loc),
+ Attribute_Name => Name_Max_Size_In_Storage_Elements);
+ end if;
+ end Size_In_Storage_Elements;
+
-- Start of processing for Expand_N_Allocator
begin
Complete_Coextension_Finalization;
end if;
+ -- Check for size too large, we do this because the back end misses
+ -- proper checks here and can generate rubbish allocation calls when
+ -- we are near the limit. We only do this for the 32-bit address case
+ -- since that is from a practical point of view where we see a problem.
+
+ if System_Address_Size = 32
+ and then not Storage_Checks_Suppressed (PtrT)
+ and then not Storage_Checks_Suppressed (Dtyp)
+ and then not Storage_Checks_Suppressed (Etyp)
+ then
+ -- The check we want to generate should look like
+
+ -- if Etyp'Max_Size_In_Storage_Elements > 3.5 gigabytes then
+ -- raise Storage_Error;
+ -- end if;
+
+ -- where 3.5 gigabytes is a constant large enough to accomodate
+ -- any reasonable request for
+
+ Insert_Action (N,
+ Make_Raise_Storage_Error (Loc,
+ Condition =>
+ Make_Op_Gt (Loc,
+ Left_Opnd => Size_In_Storage_Elements (Etyp),
+ Right_Opnd =>
+ Make_Integer_Literal (Loc,
+ Intval => Uint_7 * (Uint_2 ** 29))),
+ Reason => SE_Object_Too_Large));
+ end if;
+
-- Handle case of qualified expression (other than optimization above)
if Nkind (Expression (N)) = N_Qualified_Expression then
("?foreign convention function& should not " &
"return unconstrained array!", E);
- -- Ada 2005 (AI-326): Check wrong use of tagged
+ -- Ada 2005 (AI-326): Check wrong use of
-- incomplete type
- -- type T is tagged;
+ -- type T; -- tagged or just incomplete.
-- function F (X : Boolean) return T; -- ERROR
-- The type must be declared in the current scope for the
-- when the construct that mentions it is frozen.
elsif Ekind (Etype (E)) = E_Incomplete_Type
- and then Is_Tagged_Type (Etype (E))
and then No (Full_View (Etype (E)))
and then not Is_Value_Type (Etype (E))
then
- Error_Msg_N
- ("(Ada 2005): invalid use of tagged incomplete type",
- E);
+ Error_Msg_NE
+ ("invalid use of incomplete type&", E, Etype (E));
end if;
end if;
end;
-- For access subprogram, freeze types of all formals, the return
-- type was already frozen, since it is the Etype of the function.
+ -- Formal types can be tagged Taft amendment types, but otherwise
+ -- they cannot be incomplete;
elsif Ekind (E) = E_Subprogram_Type then
Formal := First_Formal (E);
+
while Present (Formal) loop
+ if Ekind (Etype (Formal)) = E_Incomplete_Type
+ and then No (Full_View (Etype (Formal)))
+ and then not Is_Value_Type (Etype (Formal))
+ then
+ if Is_Tagged_Type (Etype (Formal)) then
+ null;
+ else
+ Error_Msg_NE
+ ("invalid use of incomplete type&", E, Etype (Formal));
+ end if;
+ end if;
+
Freeze_And_Append (Etype (Formal), Loc, Result);
Next_Formal (Formal);
end loop;
-- Ada 2005 (AI-326): Check wrong use of tag incomplete type
- -- type T is tagged;
+ -- type T; -- tagged or untagged, may be from limited view;
-- type Acc is access function (X : T) return T; -- ERROR
if Ekind (Etype (E)) = E_Incomplete_Type
- and then Is_Tagged_Type (Etype (E))
and then No (Full_View (Etype (E)))
and then not Is_Value_Type (Etype (E))
then
- Error_Msg_N
- ("(Ada 2005): invalid use of tagged incomplete type", E);
+ Error_Msg_NE
+ ("invalid use of incomplete type&", E, Etype (E));
end if;
-- For access to a protected subprogram, freeze the equivalent type
end if;
if Ekind (Etyp) = E_Incomplete_Type
- and then Is_Tagged_Type (Etyp)
and then No (Full_View (Etyp))
and then not Is_Value_Type (Etype (E))
then
- Error_Msg_N
- ("(Ada 2005): invalid use of tagged incomplete type", E);
+ Error_Msg_NE
+ ("invalid use of incomplete type&", E, Etyp);
end if;
end;
and then
Ekind (Root_Type (Typ)) = E_Incomplete_Type)
then
- Error_Msg_N
- ("invalid use of incomplete type", Result_Definition (N));
+ Error_Msg_NE
+ ("invalid use of incomplete type&", Designator, Typ);
end if;
end if;
elsif not Nkind_In (Parent (T), N_Access_Function_Definition,
N_Access_Procedure_Definition)
then
- Error_Msg_N ("invalid use of incomplete type", Param_Spec);
-
- -- An incomplete type that is not tagged is allowed in an
- -- access-to-subprogram type only if it is a local declaration
- -- with a forthcoming completion (3.10.1 (9.2/2)).
+ Error_Msg_NE
+ ("invalid use of incomplete type&",
+ Param_Spec, Formal_Type);
- elsif Scope (Formal_Type) /= Scope (Current_Scope) then
- Error_Msg_N
- ("invalid use of limited view of type", Param_Spec);
+ -- Further checks on the legality of incomplete types
+ -- in formal parts must be delayed until the freeze point
+ -- of the enclosing subprogram or access to subprogram.
end if;
elsif Ekind (Formal_Type) = E_Void then
|| defined (__MACHTEN__) || defined (__hpux__) || defined (_AIX) \
|| (defined (__svr4__) && defined (i386)) || defined (__Lynx__) \
|| defined (__CYGWIN__) || defined (__FreeBSD__) || defined (__OpenBSD__) \
- || defined (__GLIBC__)
+ || defined (__GLIBC__) || defined (__APPLE__)
#ifdef __MINGW32__
#if OLD_MINGW
|| defined (__CYGWIN32__) || defined (__MACHTEN__) || defined (__hpux__) \
|| defined (_AIX) || (defined (__svr4__) && defined (i386)) \
|| defined (__Lynx__) || defined (__FreeBSD__) || defined (__OpenBSD__) \
- || defined (__GLIBC__)
+ || defined (__GLIBC__) || defined (__APPLE__)
char c;
int nread;
int good_one = 0;
|| defined (__osf__) || defined (__MACHTEN__) || defined (__hpux__) \
|| defined (_AIX) || (defined (__svr4__) && defined (i386)) \
|| defined (__Lynx__) || defined (__FreeBSD__) || defined (__OpenBSD__) \
- || defined (__GLIBC__)
+ || defined (__GLIBC__) || defined (__APPLE__)
eof_ch = termios_rec.c_cc[VEOF];
/* If waiting (i.e. Get_Immediate (Char)), set MIN = 1 and wait for
projects / thirdparty / gcc.git / commitdiff
