+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,
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];
/* 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>
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);
-}
/* 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 */
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 --
--------------------
-- 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,
-- 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)
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;
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,
-- 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
-- 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
-- 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)
#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;
Aspects : List_Id;
OK : Boolean;
+ Opt : Boolean;
+ -- True if current aspect takes an optional argument
+
begin
Aspects := Empty_List;
else
Scan; -- past identifier
+ Opt := Aspect_Argument (A_Id) = Optional_Expression
+ or else
+ Aspect_Argument (A_Id) = Optional_Name;
-- Check for 'Class present
-- 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
-- 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));
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)));
projects / gcc.git / commitdiff