Commit bc3c2eca by Arnaud Charlet

[multiple changes]

2014-08-04  Robert Dewar  <dewar@adacore.com>

	* einfo.ads, einfo.adb (Is_Standard_String_Type): New function.
	* exp_ch3.adb (Build_Array_Init_Proc): Use
	Is_Standard_String_Type.
	(Expand_Freeze_Array_Type): ditto.
	(Get_Simple_Init_Val): ditto.
	(Needs_Simple_Initialization): ditto.
	* sem_eval.adb (Eval_String_Literal): Use Is_Standard_String_Type.
	* sem_warn.adb (Is_Suspicious_Type): Use Is_Standard_String_Type.

2014-08-04  Pascal Obry  <obry@adacore.com>

	* adaint.c (__gnat_try_lock): Use _tcscpy and _tcscat instead of
	_stprintf which insert garbage into the wfull_path buffer.

2014-08-04  Arnaud Charlet  <charlet@adacore.com>

	* cal.c: Remove old VMS/nucleus code. Remove obsolete vxworks
	code.
	* fe.h: Minor reformatting.

2014-08-04  Rainer Orth  <ro@CeBiTec.Uni-Bielefeld.DE>

	* cstreams.c: (_LARGEFILE_SOURCE): Guard definition.

2014-08-04  Robert Dewar  <dewar@adacore.com>

	* par-ch13.adb (Get_Aspect_Specifications): Improve error
	recovery, fixing a -gnatQ bomb.

From-SVN: r213586
parent 3daa26d0
2014-08-04 Robert Dewar <dewar@adacore.com>
* einfo.ads, einfo.adb (Is_Standard_String_Type): New function.
* exp_ch3.adb (Build_Array_Init_Proc): Use
Is_Standard_String_Type.
(Expand_Freeze_Array_Type): ditto.
(Get_Simple_Init_Val): ditto.
(Needs_Simple_Initialization): ditto.
* sem_eval.adb (Eval_String_Literal): Use Is_Standard_String_Type.
* sem_warn.adb (Is_Suspicious_Type): Use Is_Standard_String_Type.
2014-08-04 Pascal Obry <obry@adacore.com>
* adaint.c (__gnat_try_lock): Use _tcscpy and _tcscat instead of
_stprintf which insert garbage into the wfull_path buffer.
2014-08-04 Arnaud Charlet <charlet@adacore.com>
* cal.c: Remove old VMS/nucleus code. Remove obsolete vxworks
code.
* fe.h: Minor reformatting.
2014-08-04 Rainer Orth <ro@CeBiTec.Uni-Bielefeld.DE>
* cstreams.c: (_LARGEFILE_SOURCE): Guard definition.
2014-08-04 Robert Dewar <dewar@adacore.com>
* par-ch13.adb (Get_Aspect_Specifications): Improve error
recovery, fixing a -gnatQ bomb.
2014-08-04 Yannick Moy <moy@adacore.com> 2014-08-04 Yannick Moy <moy@adacore.com>
* sem_ch3.adb (Analyze_Object_Declaration): In GNATprove mode, * sem_ch3.adb (Analyze_Object_Declaration): In GNATprove mode,
......
...@@ -459,7 +459,20 @@ __gnat_try_lock (char *dir, char *file) ...@@ -459,7 +459,20 @@ __gnat_try_lock (char *dir, char *file)
S2WSC (wdir, dir, GNAT_MAX_PATH_LEN); S2WSC (wdir, dir, GNAT_MAX_PATH_LEN);
S2WSC (wfile, file, GNAT_MAX_PATH_LEN); S2WSC (wfile, file, GNAT_MAX_PATH_LEN);
/* ??? the code below crash on MingW64 for obscure reasons, a ticket
has been opened here:
https://sourceforge.net/p/mingw-w64/bugs/414/
As a workaround an equivalent set of code has been put in place below.
_stprintf (wfull_path, _T("%s%c%s"), wdir, _T(DIR_SEPARATOR), wfile); _stprintf (wfull_path, _T("%s%c%s"), wdir, _T(DIR_SEPARATOR), wfile);
*/
_tcscpy (wfull_path, wdir);
_tcscat (wfull_path, L"\\");
_tcscat (wfull_path, wfile);
fd = _topen (wfull_path, O_CREAT | O_EXCL, 0600); fd = _topen (wfull_path, O_CREAT | O_EXCL, 0600);
#else #else
char full_path[256]; char full_path[256];
......
...@@ -35,22 +35,6 @@ ...@@ -35,22 +35,6 @@
/* struct timeval fields type are not normalized (they are generally */ /* struct timeval fields type are not normalized (they are generally */
/* defined as int or long values). */ /* defined as int or long values). */
#if defined(VMS) || defined(__nucleus__)
/* this is temporary code to avoid build failure under VMS */
void
__gnat_timeval_to_duration (void *t, long *sec, long *usec)
{
}
void
__gnat_duration_to_timeval (long sec, long usec, void *t)
{
}
#else
#if defined (__vxworks) #if defined (__vxworks)
#ifdef __RTP__ #ifdef __RTP__
#include <time.h> #include <time.h>
...@@ -90,20 +74,3 @@ __gnat_duration_to_timeval (long sec, long usec, struct timeval *t) ...@@ -90,20 +74,3 @@ __gnat_duration_to_timeval (long sec, long usec, struct timeval *t)
t->tv_sec = sec; t->tv_sec = sec;
t->tv_usec = usec; t->tv_usec = usec;
} }
#endif
#ifdef __alpha_vxworks
#include "vxWorks.h"
#elif defined (__vxworks)
#include <types/vxTypesOld.h>
#endif
/* Return the value of the "time" C library function. We always return
a long and do it this way to avoid problems with not knowing
what time_t is on the target. */
long
gnat_time (void)
{
return time (0);
}
...@@ -31,7 +31,9 @@ ...@@ -31,7 +31,9 @@
/* Routines required for implementing routines in Interfaces.C.Streams. */ /* Routines required for implementing routines in Interfaces.C.Streams. */
#ifndef _LARGEFILE_SOURCE
#define _LARGEFILE_SOURCE #define _LARGEFILE_SOURCE
#endif
#define _FILE_OFFSET_BITS 64 #define _FILE_OFFSET_BITS 64
/* the define above will make off_t a 64bit type on GNU/Linux */ /* the define above will make off_t a 64bit type on GNU/Linux */
......
...@@ -7264,6 +7264,29 @@ package body Einfo is ...@@ -7264,6 +7264,29 @@ package body Einfo is
end if; end if;
end Is_Standard_Character_Type; end Is_Standard_Character_Type;
-----------------------------
-- Is_Standard_String_Type --
-----------------------------
function Is_Standard_String_Type (Id : E) return B is
begin
if Is_Type (Id) then
declare
R : constant Entity_Id := Root_Type (Id);
begin
return
R = Standard_String
or else
R = Standard_Wide_String
or else
R = Standard_Wide_Wide_String;
end;
else
return False;
end if;
end Is_Standard_String_Type;
-------------------- --------------------
-- Is_String_Type -- -- Is_String_Type --
-------------------- --------------------
......
...@@ -2940,9 +2940,14 @@ package Einfo is ...@@ -2940,9 +2940,14 @@ package Einfo is
-- Is_Standard_Character_Type (synthesized) -- Is_Standard_Character_Type (synthesized)
-- Applies to all entities, true for types and subtypes whose root type -- Applies to all entities, true for types and subtypes whose root type
-- is one of the standard character types (Character, Wide_Character, -- is one of the standard character types (Character, Wide_Character, or
-- Wide_Wide_Character). -- Wide_Wide_Character).
-- Is_Standard_String_Type (synthesized)
-- Applies to all entities, true for types and subtypes whose root
-- type is one of the standard string types (String, Wide_String, or
-- Wide_Wide_String).
-- Is_Statically_Allocated (Flag28) -- Is_Statically_Allocated (Flag28)
-- Defined in all entities. This can only be set for exception, -- Defined in all entities. This can only be set for exception,
-- variable, constant, and type/subtype entities. If the flag is set, -- variable, constant, and type/subtype entities. If the flag is set,
...@@ -5233,6 +5238,7 @@ package Einfo is ...@@ -5233,6 +5238,7 @@ package Einfo is
-- Has_Foreign_Convention (synth) -- Has_Foreign_Convention (synth)
-- Is_Dynamic_Scope (synth) -- Is_Dynamic_Scope (synth)
-- Is_Standard_Character_Type (synth) -- Is_Standard_Character_Type (synth)
-- Is_Standard_String_Type (synth)
-- Underlying_Type (synth) -- Underlying_Type (synth)
-- all classification attributes (synth) -- all classification attributes (synth)
...@@ -7002,6 +7008,7 @@ package Einfo is ...@@ -7002,6 +7008,7 @@ package Einfo is
function Is_Protected_Interface (Id : E) return B; function Is_Protected_Interface (Id : E) return B;
function Is_Protected_Record_Type (Id : E) return B; function Is_Protected_Record_Type (Id : E) return B;
function Is_Standard_Character_Type (Id : E) return B; function Is_Standard_Character_Type (Id : E) return B;
function Is_Standard_String_Type (Id : E) return B;
function Is_String_Type (Id : E) return B; function Is_String_Type (Id : E) return B;
function Is_Synchronized_Interface (Id : E) return B; function Is_Synchronized_Interface (Id : E) return B;
function Is_Task_Interface (Id : E) return B; function Is_Task_Interface (Id : E) return B;
......
...@@ -713,9 +713,7 @@ package body Exp_Ch3 is ...@@ -713,9 +713,7 @@ package body Exp_Ch3 is
if Has_Default_Init if Has_Default_Init
or else (not Restriction_Active (No_Initialize_Scalars) or else (not Restriction_Active (No_Initialize_Scalars)
and then Is_Public (A_Type) and then Is_Public (A_Type)
and then Root_Type (A_Type) /= Standard_String and then not Is_Standard_String_Type (A_Type))
and then Root_Type (A_Type) /= Standard_Wide_String
and then Root_Type (A_Type) /= Standard_Wide_Wide_String)
then then
Proc_Id := Proc_Id :=
Make_Defining_Identifier (Loc, Make_Defining_Identifier (Loc,
...@@ -6257,10 +6255,7 @@ package body Exp_Ch3 is ...@@ -6257,10 +6255,7 @@ package body Exp_Ch3 is
-- initialize scalars mode, and these types are treated specially -- initialize scalars mode, and these types are treated specially
-- and do not need initialization procedures. -- and do not need initialization procedures.
elsif Root_Type (Base) = Standard_String elsif Is_Standard_String_Type (Base) then
or else Root_Type (Base) = Standard_Wide_String
or else Root_Type (Base) = Standard_Wide_Wide_String
then
null; null;
-- Otherwise we have to build an init proc for the subtype -- Otherwise we have to build an init proc for the subtype
...@@ -8001,12 +7996,7 @@ package body Exp_Ch3 is ...@@ -8001,12 +7996,7 @@ package body Exp_Ch3 is
-- String or Wide_[Wide]_String (must have Initialize_Scalars set) -- String or Wide_[Wide]_String (must have Initialize_Scalars set)
elsif Root_Type (T) = Standard_String elsif Is_Standard_String_Type (T) then
or else
Root_Type (T) = Standard_Wide_String
or else
Root_Type (T) = Standard_Wide_Wide_String
then
pragma Assert (Init_Or_Norm_Scalars); pragma Assert (Init_Or_Norm_Scalars);
return return
...@@ -9714,10 +9704,7 @@ package body Exp_Ch3 is ...@@ -9714,10 +9704,7 @@ package body Exp_Ch3 is
-- filled with appropriate initializing values before they are used). -- filled with appropriate initializing values before they are used).
elsif Consider_IS_NS elsif Consider_IS_NS
and then and then Is_Standard_String_Type (T)
(Root_Type (T) = Standard_String or else
Root_Type (T) = Standard_Wide_String or else
Root_Type (T) = Standard_Wide_Wide_String)
and then and then
(not Is_Itype (T) (not Is_Itype (T)
or else Nkind (Associated_Node_For_Itype (T)) /= N_Aggregate) or else Nkind (Associated_Node_For_Itype (T)) /= N_Aggregate)
......
...@@ -174,7 +174,7 @@ extern Boolean In_Same_Source_Unit (Node_Id, Node_Id); ...@@ -174,7 +174,7 @@ extern Boolean In_Same_Source_Unit (Node_Id, Node_Id);
#define Exception_Mechanism opt__exception_mechanism #define Exception_Mechanism opt__exception_mechanism
#define Float_Format opt__float_format #define Float_Format opt__float_format
#define Generate_SCO_Instance_Table opt__generate_sco_instance_table #define Generate_SCO_Instance_Table opt__generate_sco_instance_table
#define GNAT_Mode opt__gnat_mode #define GNAT_Mode opt__gnat_mode
#define List_Representation_Info opt__list_representation_info #define List_Representation_Info opt__list_representation_info
typedef enum {Setjmp_Longjmp, Back_End_Exceptions} Exception_Mechanism_Type; typedef enum {Setjmp_Longjmp, Back_End_Exceptions} Exception_Mechanism_Type;
......
...@@ -154,6 +154,9 @@ package body Ch13 is ...@@ -154,6 +154,9 @@ package body Ch13 is
Aspects : List_Id; Aspects : List_Id;
OK : Boolean; OK : Boolean;
Opt : Boolean;
-- True if current aspect takes an optional argument
begin begin
Aspects := Empty_List; Aspects := Empty_List;
...@@ -248,6 +251,9 @@ package body Ch13 is ...@@ -248,6 +251,9 @@ package body Ch13 is
else else
Scan; -- past identifier Scan; -- past identifier
Opt := Aspect_Argument (A_Id) = Optional_Expression
or else
Aspect_Argument (A_Id) = Optional_Name;
-- Check for 'Class present -- Check for 'Class present
...@@ -285,23 +291,21 @@ package body Ch13 is ...@@ -285,23 +291,21 @@ package body Ch13 is
-- definitions are not considered. -- definitions are not considered.
if Token = Tok_Comma or else Token = Tok_Semicolon then if Token = Tok_Comma or else Token = Tok_Semicolon then
if Aspect_Argument (A_Id) /= Optional_Expression if not Opt then
and then Aspect_Argument (A_Id) /= Optional_Name
then
Error_Msg_Node_1 := Identifier (Aspect); Error_Msg_Node_1 := Identifier (Aspect);
Error_Msg_AP ("aspect& requires an aspect definition"); Error_Msg_AP ("aspect& requires an aspect definition");
OK := False; OK := False;
end if; end if;
-- Check for a missing arrow when the aspect has a definition -- Here we do not have a comma or a semicolon, we are done if we
-- do not have an arrow and the aspect does not need an argument
elsif not Semicolon and then Token /= Tok_Arrow then elsif Opt and then Token /= Tok_Arrow then
if Aspect_Argument (A_Id) /= Optional_Expression null;
and then Aspect_Argument (A_Id) /= Optional_Name
then -- Here we have either an arrow, or an aspect that definitely
T_Arrow; -- needs an aspect definition, and we will look for one even if
Resync_To_Semicolon; -- no arrow is preseant.
end if;
-- Otherwise we have an aspect definition -- Otherwise we have an aspect definition
......
...@@ -3661,16 +3661,11 @@ package body Sem_Eval is ...@@ -3661,16 +3661,11 @@ package body Sem_Eval is
-- Test for illegal Ada 95 cases. A string literal is illegal in Ada 95 -- Test for illegal Ada 95 cases. A string literal is illegal in Ada 95
-- if its bounds are outside the index base type and this index type is -- if its bounds are outside the index base type and this index type is
-- static. This can happen in only two ways. Either the string literal -- static. This can happen in only two ways. Either the string literal
-- is too long, or it is null, and the lower bound is type'First. In -- is too long, or it is null, and the lower bound is type'First. Either
-- either case it is the upper bound that is out of range of the index -- way it is the upper bound that is out of range of the index type.
-- type.
if Ada_Version >= Ada_95 then if Ada_Version >= Ada_95 then
if Root_Type (Bas) = Standard_String if Is_Standard_String_Type (Bas) then
or else
Root_Type (Bas) = Standard_Wide_String
or else
Root_Type (Bas) = Standard_Wide_Wide_String
then
Xtp := Standard_Positive; Xtp := Standard_Positive;
else else
Xtp := Etype (First_Index (Bas)); Xtp := Etype (First_Index (Bas));
......
...@@ -3650,11 +3650,7 @@ package body Sem_Warn is ...@@ -3650,11 +3650,7 @@ package body Sem_Warn is
if Is_Array_Type (Typ) if Is_Array_Type (Typ)
and then not Is_Constrained (Typ) and then not Is_Constrained (Typ)
and then Number_Dimensions (Typ) = 1 and then Number_Dimensions (Typ) = 1
and then (Root_Type (Typ) = Standard_String and then Is_Standard_String_Type (Typ)
or else
Root_Type (Typ) = Standard_Wide_String
or else
Root_Type (Typ) = Standard_Wide_Wide_String)
and then not Has_Warnings_Off (Typ) and then not Has_Warnings_Off (Typ)
then then
LB := Type_Low_Bound (Etype (First_Index (Typ))); LB := Type_Low_Bound (Etype (First_Index (Typ)));
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment