[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
This commit is contained in:
Arnaud Charlet
parent
3daa26d0e9
commit
bc3c2eca1a
11 changed files with 102 additions and 77 deletions
|
|
@ -1,3 +1,34 @@
|
|||
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>
|
||||
|
||||
* sem_ch3.adb (Analyze_Object_Declaration): In GNATprove mode,
|
||||
|
|
|
|||
|
|
@ -459,7 +459,20 @@ __gnat_try_lock (char *dir, char *file)
|
|||
S2WSC (wdir, dir, 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);
|
||||
*/
|
||||
|
||||
_tcscpy (wfull_path, wdir);
|
||||
_tcscat (wfull_path, L"\\");
|
||||
_tcscat (wfull_path, wfile);
|
||||
|
||||
fd = _topen (wfull_path, O_CREAT | O_EXCL, 0600);
|
||||
#else
|
||||
char full_path[256];
|
||||
|
|
|
|||
|
|
@ -35,22 +35,6 @@
|
|||
/* struct timeval fields type are not normalized (they are generally */
|
||||
/* 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)
|
||||
#ifdef __RTP__
|
||||
#include <time.h>
|
||||
|
|
@ -90,20 +74,3 @@ __gnat_duration_to_timeval (long sec, long usec, struct timeval *t)
|
|||
t->tv_sec = sec;
|
||||
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 @@
|
|||
|
||||
/* Routines required for implementing routines in Interfaces.C.Streams. */
|
||||
|
||||
#ifndef _LARGEFILE_SOURCE
|
||||
#define _LARGEFILE_SOURCE
|
||||
#endif
|
||||
#define _FILE_OFFSET_BITS 64
|
||||
/* the define above will make off_t a 64bit type on GNU/Linux */
|
||||
|
||||
|
|
|
|||
|
|
@ -7264,6 +7264,29 @@ package body Einfo is
|
|||
end if;
|
||||
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 --
|
||||
--------------------
|
||||
|
|
|
|||
|
|
@ -2940,9 +2940,14 @@ package Einfo is
|
|||
|
||||
-- Is_Standard_Character_Type (synthesized)
|
||||
-- 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).
|
||||
|
||||
-- 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)
|
||||
-- Defined in all entities. This can only be set for exception,
|
||||
-- variable, constant, and type/subtype entities. If the flag is set,
|
||||
|
|
@ -5233,6 +5238,7 @@ package Einfo is
|
|||
-- Has_Foreign_Convention (synth)
|
||||
-- Is_Dynamic_Scope (synth)
|
||||
-- Is_Standard_Character_Type (synth)
|
||||
-- Is_Standard_String_Type (synth)
|
||||
-- Underlying_Type (synth)
|
||||
-- all classification attributes (synth)
|
||||
|
||||
|
|
@ -7002,6 +7008,7 @@ package Einfo is
|
|||
function Is_Protected_Interface (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_String_Type (Id : E) return B;
|
||||
function Is_String_Type (Id : E) return B;
|
||||
function Is_Synchronized_Interface (Id : E) return B;
|
||||
function Is_Task_Interface (Id : E) return B;
|
||||
|
|
|
|||
|
|
@ -713,9 +713,7 @@ package body Exp_Ch3 is
|
|||
if Has_Default_Init
|
||||
or else (not Restriction_Active (No_Initialize_Scalars)
|
||||
and then Is_Public (A_Type)
|
||||
and then Root_Type (A_Type) /= Standard_String
|
||||
and then Root_Type (A_Type) /= Standard_Wide_String
|
||||
and then Root_Type (A_Type) /= Standard_Wide_Wide_String)
|
||||
and then not Is_Standard_String_Type (A_Type))
|
||||
then
|
||||
Proc_Id :=
|
||||
Make_Defining_Identifier (Loc,
|
||||
|
|
@ -6257,10 +6255,7 @@ package body Exp_Ch3 is
|
|||
-- initialize scalars mode, and these types are treated specially
|
||||
-- and do not need initialization procedures.
|
||||
|
||||
elsif Root_Type (Base) = Standard_String
|
||||
or else Root_Type (Base) = Standard_Wide_String
|
||||
or else Root_Type (Base) = Standard_Wide_Wide_String
|
||||
then
|
||||
elsif Is_Standard_String_Type (Base) then
|
||||
null;
|
||||
|
||||
-- Otherwise we have to build an init proc for the subtype
|
||||
|
|
@ -8001,12 +7996,7 @@ package body Exp_Ch3 is
|
|||
|
||||
-- String or Wide_[Wide]_String (must have Initialize_Scalars set)
|
||||
|
||||
elsif Root_Type (T) = Standard_String
|
||||
or else
|
||||
Root_Type (T) = Standard_Wide_String
|
||||
or else
|
||||
Root_Type (T) = Standard_Wide_Wide_String
|
||||
then
|
||||
elsif Is_Standard_String_Type (T) then
|
||||
pragma Assert (Init_Or_Norm_Scalars);
|
||||
|
||||
return
|
||||
|
|
@ -9714,10 +9704,7 @@ package body Exp_Ch3 is
|
|||
-- filled with appropriate initializing values before they are used).
|
||||
|
||||
elsif Consider_IS_NS
|
||||
and then
|
||||
(Root_Type (T) = Standard_String or else
|
||||
Root_Type (T) = Standard_Wide_String or else
|
||||
Root_Type (T) = Standard_Wide_Wide_String)
|
||||
and then Is_Standard_String_Type (T)
|
||||
and then
|
||||
(not Is_Itype (T)
|
||||
or else Nkind (Associated_Node_For_Itype (T)) /= N_Aggregate)
|
||||
|
|
|
|||
|
|
@ -174,7 +174,7 @@ extern Boolean In_Same_Source_Unit (Node_Id, Node_Id);
|
|||
#define Exception_Mechanism opt__exception_mechanism
|
||||
#define Float_Format opt__float_format
|
||||
#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
|
||||
|
||||
typedef enum {Setjmp_Longjmp, Back_End_Exceptions} Exception_Mechanism_Type;
|
||||
|
|
|
|||
|
|
@ -154,6 +154,9 @@ package body Ch13 is
|
|||
Aspects : List_Id;
|
||||
OK : Boolean;
|
||||
|
||||
Opt : Boolean;
|
||||
-- True if current aspect takes an optional argument
|
||||
|
||||
begin
|
||||
Aspects := Empty_List;
|
||||
|
||||
|
|
@ -248,6 +251,9 @@ package body Ch13 is
|
|||
|
||||
else
|
||||
Scan; -- past identifier
|
||||
Opt := Aspect_Argument (A_Id) = Optional_Expression
|
||||
or else
|
||||
Aspect_Argument (A_Id) = Optional_Name;
|
||||
|
||||
-- Check for 'Class present
|
||||
|
||||
|
|
@ -285,23 +291,21 @@ package body Ch13 is
|
|||
-- definitions are not considered.
|
||||
|
||||
if Token = Tok_Comma or else Token = Tok_Semicolon then
|
||||
if Aspect_Argument (A_Id) /= Optional_Expression
|
||||
and then Aspect_Argument (A_Id) /= Optional_Name
|
||||
then
|
||||
if not Opt then
|
||||
Error_Msg_Node_1 := Identifier (Aspect);
|
||||
Error_Msg_AP ("aspect& requires an aspect definition");
|
||||
OK := False;
|
||||
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
|
||||
if Aspect_Argument (A_Id) /= Optional_Expression
|
||||
and then Aspect_Argument (A_Id) /= Optional_Name
|
||||
then
|
||||
T_Arrow;
|
||||
Resync_To_Semicolon;
|
||||
end if;
|
||||
elsif Opt and then Token /= Tok_Arrow then
|
||||
null;
|
||||
|
||||
-- Here we have either an arrow, or an aspect that definitely
|
||||
-- needs an aspect definition, and we will look for one even if
|
||||
-- no arrow is preseant.
|
||||
|
||||
-- Otherwise we have an aspect definition
|
||||
|
||||
|
|
|
|||
|
|
@ -3661,16 +3661,11 @@ package body Sem_Eval is
|
|||
-- 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
|
||||
-- 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
|
||||
-- either case it is the upper bound that is out of range of the index
|
||||
-- type.
|
||||
-- is too long, or it is null, and the lower bound is type'First. Either
|
||||
-- way it is the upper bound that is out of range of the index type.
|
||||
|
||||
if Ada_Version >= Ada_95 then
|
||||
if Root_Type (Bas) = Standard_String
|
||||
or else
|
||||
Root_Type (Bas) = Standard_Wide_String
|
||||
or else
|
||||
Root_Type (Bas) = Standard_Wide_Wide_String
|
||||
then
|
||||
if Is_Standard_String_Type (Bas) then
|
||||
Xtp := Standard_Positive;
|
||||
else
|
||||
Xtp := Etype (First_Index (Bas));
|
||||
|
|
|
|||
|
|
@ -3650,11 +3650,7 @@ package body Sem_Warn is
|
|||
if Is_Array_Type (Typ)
|
||||
and then not Is_Constrained (Typ)
|
||||
and then Number_Dimensions (Typ) = 1
|
||||
and then (Root_Type (Typ) = Standard_String
|
||||
or else
|
||||
Root_Type (Typ) = Standard_Wide_String
|
||||
or else
|
||||
Root_Type (Typ) = Standard_Wide_Wide_String)
|
||||
and then Is_Standard_String_Type (Typ)
|
||||
and then not Has_Warnings_Off (Typ)
|
||||
then
|
||||
LB := Type_Low_Bound (Etype (First_Index (Typ)));
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue