From bc3c2eca1aa80b667f9e80773919755669d03e82 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Mon, 4 Aug 2014 15:09:07 +0200 Subject: [PATCH] [multiple changes] 2014-08-04 Robert Dewar * 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 * 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 * cal.c: Remove old VMS/nucleus code. Remove obsolete vxworks code. * fe.h: Minor reformatting. 2014-08-04 Rainer Orth * cstreams.c: (_LARGEFILE_SOURCE): Guard definition. 2014-08-04 Robert Dewar * par-ch13.adb (Get_Aspect_Specifications): Improve error recovery, fixing a -gnatQ bomb. From-SVN: r213586 --- gcc/ada/ChangeLog | 31 +++++++++++++++++++++++++++++++ gcc/ada/adaint.c | 13 +++++++++++++ gcc/ada/cal.c | 33 --------------------------------- gcc/ada/cstreams.c | 2 ++ gcc/ada/einfo.adb | 23 +++++++++++++++++++++++ gcc/ada/einfo.ads | 9 ++++++++- gcc/ada/exp_ch3.adb | 21 ++++----------------- gcc/ada/fe.h | 2 +- gcc/ada/par-ch13.adb | 26 +++++++++++++++----------- gcc/ada/sem_eval.adb | 13 ++++--------- gcc/ada/sem_warn.adb | 6 +----- 11 files changed, 102 insertions(+), 77 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 4cc36d8..9db1ccb 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,34 @@ +2014-08-04 Robert Dewar + + * 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 + + * 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 + + * cal.c: Remove old VMS/nucleus code. Remove obsolete vxworks + code. + * fe.h: Minor reformatting. + +2014-08-04 Rainer Orth + + * cstreams.c: (_LARGEFILE_SOURCE): Guard definition. + +2014-08-04 Robert Dewar + + * par-ch13.adb (Get_Aspect_Specifications): Improve error + recovery, fixing a -gnatQ bomb. + 2014-08-04 Yannick Moy * sem_ch3.adb (Analyze_Object_Declaration): In GNATprove mode, diff --git a/gcc/ada/adaint.c b/gcc/ada/adaint.c index 8a18418..02bce45 100644 --- a/gcc/ada/adaint.c +++ b/gcc/ada/adaint.c @@ -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]; diff --git a/gcc/ada/cal.c b/gcc/ada/cal.c index a657286..2f913a9 100644 --- a/gcc/ada/cal.c +++ b/gcc/ada/cal.c @@ -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 @@ -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 -#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); -} diff --git a/gcc/ada/cstreams.c b/gcc/ada/cstreams.c index 23f7480..f7652e3 100644 --- a/gcc/ada/cstreams.c +++ b/gcc/ada/cstreams.c @@ -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 */ diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index d4a5260..c3b0f99 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -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 -- -------------------- diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index fb737e1..d75becc 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -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; diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 476b42e..bd4886d 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -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) diff --git a/gcc/ada/fe.h b/gcc/ada/fe.h index 2eb591a..fcd2f15 100644 --- a/gcc/ada/fe.h +++ b/gcc/ada/fe.h @@ -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; diff --git a/gcc/ada/par-ch13.adb b/gcc/ada/par-ch13.adb index 44193d6..2265bbf 100644 --- a/gcc/ada/par-ch13.adb +++ b/gcc/ada/par-ch13.adb @@ -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 diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb index 2fb5d37..e49c51c 100644 --- a/gcc/ada/sem_eval.adb +++ b/gcc/ada/sem_eval.adb @@ -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)); diff --git a/gcc/ada/sem_warn.adb b/gcc/ada/sem_warn.adb index e8c8f0b..7bdda64 100644 --- a/gcc/ada/sem_warn.adb +++ b/gcc/ada/sem_warn.adb @@ -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))); -- 2.7.4