+2011-08-01 Robert Dewar <dewar@adacore.com>
+
+ * atree.ads: Minor comment fix.
+ * a-stwifi.adb, a-stzfix.adb, a-strfix.adb, a-ztexio.ads, a-textio.ads,
+ a-witeio.ads, sem_prag.adb: Minor reformatting.
+
+2011-08-01 Doug Rupp <rupp@adacore.com>
+
+ * env.c (__gnat_setenv) [VMS]: Force 32bit on item list structure
+ pointers. Use descrip.h header file for convenience. Add some
+ comments.
+
+2011-08-01 Robert Dewar <dewar@adacore.com>
+
+ * freeze.adb (Freeze_Entity): Call Check_Aspect_At_Freeze_Point
+ (Freeze_All): Call Check_Aspect_At_End_Of_Declarations
+ * sem_ch13.ads, sem_ch13.adb (Check_Aspect_At_Freeze_Point):
+ New procedure.
+ (Check_Aspect_At_End_Of_Declarations): New procedure
+ (Analye_Aspect_Specification): Minor changes for above procedures
+ * sinfo.ads, sinfo.adb (Is_Delayed_Aspect): Now set in aspect
+ specification node as well.
+
+2011-08-01 Pascal Obry <obry@adacore.com>
+
+ * adaint.c (_gnat_stat): GetFilesAttributesEx() would fail on special
+ Windows files. Use GetFilesAttributes() in this case to check for file
+ existence instead of returning with an error code.
+
2011-08-01 Vincent Celier <celier@adacore.com>
* a-stzfix.adb, a-stwifi.adb (Replace_Slice): Fixed computation when
Integer'Max (0, Low - Source'First);
-- Length of prefix of Source copied to result
- Back_Len : constant Integer :=
- Integer'Max (0, Source'Last - High);
+ Back_Len : constant Integer :=
+ Integer'Max (0, Source'Last - High);
-- Length of suffix of Source copied to result
Result_Length : constant Integer :=
Result : String (1 .. Result_Length);
begin
- Result (1 .. Front_Len) :=
- Source (Source'First .. Low - 1);
- Result (Front_Len + 1 .. Front_Len + By'Length) :=
- By;
+ Result (1 .. Front_Len) := Source (Source'First .. Low - 1);
+ Result (Front_Len + 1 .. Front_Len + By'Length) := By;
Result (Front_Len + By'Length + 1 .. Result'Length) :=
Source (High + 1 .. Source'Last);
-
return Result;
end;
if High >= Low then
declare
Front_Len : constant Integer :=
- Integer'Max (0, Low - Source'First);
+ Integer'Max (0, Low - Source'First);
-- Length of prefix of Source copied to result
- Back_Len : constant Integer :=
- Integer'Max (0, Source'Last - High);
+ Back_Len : constant Integer :=
+ Integer'Max (0, Source'Last - High);
-- Length of suffix of Source copied to result
Result_Length : constant Integer :=
- Front_Len + By'Length + Back_Len;
+ Front_Len + By'Length + Back_Len;
-- Length of result
- Result : Wide_String (1 .. Result_Length);
+ Result : Wide_String (1 .. Result_Length);
begin
- Result (1 .. Front_Len) :=
- Source (Source'First .. Low - 1);
- Result (Front_Len + 1 .. Front_Len + By'Length) :=
- By;
+ Result (1 .. Front_Len) := Source (Source'First .. Low - 1);
+ Result (Front_Len + 1 .. Front_Len + By'Length) := By;
Result (Front_Len + By'Length + 1 .. Result'Length) :=
Source (High + 1 .. Source'Last);
-
return Result;
end;
Integer'Max (0, Low - Source'First);
-- Length of prefix of Source copied to result
- Back_Len : constant Integer :=
- Integer'Max (0, Source'Last - High);
+ Back_Len : constant Integer :=
+ Integer'Max (0, Source'Last - High);
-- Length of suffix of Source copied to result
Result_Length : constant Integer :=
Result : Wide_Wide_String (1 .. Result_Length);
begin
- Result (1 .. Front_Len) :=
- Source (Source'First .. Low - 1);
- Result (Front_Len + 1 .. Front_Len + By'Length) :=
- By;
+ Result (1 .. Front_Len) := Source (Source'First .. Low - 1);
+ Result (Front_Len + 1 .. Front_Len + By'Length) := By;
Result (Front_Len + By'Length + 1 .. Result'Length) :=
Source (High + 1 .. Source'Last);
-
return Result;
end;
-- Line and page length
subtype Field is Integer range 0 .. 255;
- -- Note: if for any reason, there is a need to increase this value,
- -- then it will be necessary to change the corresponding value in
- -- System.Img_Real in file s-imgrea.adb.
+ -- Note: if for any reason, there is a need to increase this value, then it
+ -- will be necessary to change the corresponding value in System.Img_Real
+ -- in file s-imgrea.adb.
subtype Number_Base is Integer range 2 .. 16;
-- Line and page length
subtype Field is Integer range 0 .. 255;
- -- Note: if for any reason, there is a need to increase this value,
- -- then it will be necessary to change the corresponding value in
- -- System.Img_Real in file s-imgrea.adb.
+ -- Note: if for any reason, there is a need to increase this value, then it
+ -- will be necessary to change the corresponding value in System.Img_Real
+ -- in file s-imgrea.adb.
subtype Number_Base is Integer range 2 .. 16;
-- Line and page length
subtype Field is Integer range 0 .. 255;
- -- Note: if for any reason, there is a need to increase this value,
- -- then it will be necessary to change the corresponding value in
- -- System.Img_Real in file s-imgrea.adb.
+ -- Note: if for any reason, there is a need to increase this value, then it
+ -- will be necessary to change the corresponding value in System.Img_Real
+ -- in file s-imgrea.adb.
subtype Number_Base is Integer range 2 .. 16;
TCHAR wname [GNAT_MAX_PATH_LEN + 2];
int name_len;
BOOL res;
+ DWORD error;
S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2);
name_len = _tcslen (wname);
res = GetFileAttributesEx (wname, GetFileExInfoStandard, &fad);
- if (res == FALSE)
- switch (GetLastError()) {
+ if (res == FALSE) {
+ error = GetLastError();
+
+ /* Check file existence using GetFileAttributes() which does not fail on
+ special Windows files like con:, aux:, nul: etc... */
+
+ if (GetFileAttributes(wname) != INVALID_FILE_ATTRIBUTES) {
+ /* Just pretend that it is a regular and readable file */
+ statbuf->st_mode = S_IFREG | S_IREAD | S_IWRITE;
+ return 0;
+ }
+
+ switch (error) {
case ERROR_ACCESS_DENIED:
case ERROR_SHARING_VIOLATION:
case ERROR_LOCK_VIOLATION:
default:
return ENOENT;
}
+ }
f2t (&fad.ftCreationTime, &statbuf->st_ctime);
f2t (&fad.ftLastWriteTime, &statbuf->st_mtime);
-- with copying aspect specifications where this is required.
function New_Copy (Source : Node_Id) return Node_Id;
- -- This function allocates a completely new node, and then initializes
- -- it by copying the contents of the source node into it. The contents
- -- of the source node is not affected. The target node is always marked
- -- as not being in a list (even if the source is a list member). The
- -- new node will have an extension if the source has an extension.
- -- New_Copy (Empty) returns Empty and New_Copy (Error) returns Error.
- -- Note that, unlike New_Copy_Tree, New_Copy does not recursively copy any
- -- descendents, so in general parent pointers are not set correctly for
- -- the descendents of the copied node. Both normal and extended nodes
- -- (entities) may be copied using New_Copy.
+ -- This function allocates a completely new node, and then initializes it
+ -- by copying the contents of the source node into it. The contents of the
+ -- source node is not affected. The target node is always marked as not
+ -- being in a list (even if the source is a list member). The new node will
+ -- have an extension if the source has an extension. New_Copy (Empty)
+ -- returns Empty and New_Copy (Error) returns Error. Note that, unlike
+ -- Copy_Separate_Tree, New_Copy does not recursively copy any descendents,
+ -- so in general parent pointers are not set correctly for the descendents
+ -- of the copied node. Both normal and extended nodes (entities) may be
+ -- copied using New_Copy.
function Relocate_Node (Source : Node_Id) return Node_Id;
-- Source is a non-entity node that is to be relocated. A new node is
#include <time.h>
#ifdef VMS
#include <unixio.h>
+#include <vms/descrip.h>
#endif
#if defined (__MINGW32__)
static char *to_host_path_spec (char *);
-struct descriptor_s
-{
- unsigned short len, mbz;
- __char_ptr32 adr;
-};
-
typedef struct _ile3
{
unsigned short len, code;
__char_ptr32 adr;
- unsigned short *retlen_adr;
+ __char_ptr32 retlen_adr;
} ile_s;
#endif
__gnat_setenv (char *name, char *value)
{
#if defined (VMS)
- struct descriptor_s name_desc;
+ struct dsc$descriptor_s name_desc;
/* Put in JOB table for now, so that the project stuff at least works. */
- struct descriptor_s table_desc = {7, 0, "LNM$JOB"};
+ $DESCRIPTOR (table_desc, "LNM$JOB");
char *host_pathspec = value;
char *copy_pathspec;
int num_dirs_in_pathspec = 1;
char *ptr;
long status;
- name_desc.len = strlen (name);
- name_desc.mbz = 0;
- name_desc.adr = name;
+ name_desc.dsc$w_length = strlen (name);
+ name_desc.dsc$b_dtype = DSC$K_DTYPE_T;
+ name_desc.dsc$b_class = DSC$K_CLASS_S;
+ name_desc.dsc$a_pointer = name; /* ??? Danger, not 64bit safe. */
if (*host_pathspec == 0)
/* deassign */
{
int i, status;
+ /* Alloca is guaranteed to be 32bit. */
ile_s *ile_array = alloca (sizeof (ile_s) * (num_dirs_in_pathspec + 1));
char *copy_pathspec = alloca (strlen (host_pathspec) + 1);
char *curr, *next;
if not Is_Frozen (E) then
Flist := Freeze_Entity (E, After);
Process_Flist;
+
+ -- If already frozen, and there are delayed aspects, this is where
+ -- we do the visibility check for these aspects (see Sem_Ch13 spec
+ -- for a description of how we handle aspect visibility).
+
+ elsif Has_Delayed_Aspects (E) then
+ declare
+ Ritem : Node_Id;
+
+ begin
+ Ritem := First_Rep_Item (E);
+ while Present (Ritem) loop
+ if Nkind (Ritem) = N_Aspect_Specification
+ and then Is_Delayed_Aspect (Ritem)
+ then
+ Check_Aspect_At_End_Of_Declarations (Ritem);
+ end if;
+
+ Ritem := Next_Rep_Item (Ritem);
+ end loop;
+ end;
end if;
-- If an incomplete type is still not frozen, this may be a
while Present (Ritem) loop
if Nkind (Ritem) = N_Aspect_Specification
and then Entity (Ritem) = E
+ and then Is_Delayed_Aspect (Ritem)
then
Aitem := Aspect_Rep_Item (Ritem);
- pragma Assert (Is_Delayed_Aspect (Aitem));
Set_Parent (Aitem, Ritem);
-- Deal with Boolean case, if no expression, True, otherwise
-- Analyze the pragma after possibly setting Aspect_Cancel
Analyze (Aitem);
+
+ -- Do visibility analysis for aspect at freeze point
+
+ Check_Aspect_At_Freeze_Point (Ritem);
end if;
Next_Rep_Item (Ritem);
-- one of two things happens:
-- If we are required to delay the evaluation of this aspect to the
- -- freeze point, we preanalyze the relevant argument, and then attach
- -- the corresponding pragma/attribute definition clause to the aspect
- -- specification node, which is then placed in the Rep Item chain.
- -- In this case we mark the entity with the Has_Delayed_Aspects flag,
- -- and we evaluate the rep item at the freeze point.
+ -- freeze point, we attach the corresponding pragma/attribute definition
+ -- clause to the aspect specification node, which is then placed in the
+ -- Rep Item chain. In this case we mark the entity by setting the flag
+ -- Has_Delayed_Aspects and we evaluate the rep item at the freeze point.
-- If no delay is required, we just insert the pragma or attribute
-- after the declaration, and it will get processed by the normal
Next (Anod);
end loop;
+ -- Copy expression for later processing by the procedures
+ -- Check_Aspect_At_[Freeze_Point | End_Of_Declarations]
+
+ Set_Entity (Id, New_Copy_Tree (Expr));
+
-- Processing based on specific aspect
case A_Id is
else
Delay_Required := True;
+ Set_Is_Delayed_Aspect (Aspect);
end if;
-- Aspects corresponding to attribute definition clauses
-- Here a delay is required
Delay_Required := True;
+ Set_Is_Delayed_Aspect (Aspect);
-- Aspects corresponding to pragmas with two arguments, where
-- the first argument is a local name referring to the entity,
end if;
Set_From_Aspect_Specification (Aitem, True);
+ Set_Is_Delayed_Aspect (Aspect);
-- For Pre/Post cases, insert immediately after the entity
-- declaration, since that is the required pragma placement.
end if;
Set_From_Aspect_Specification (Aitem, True);
+ Set_Is_Delayed_Aspect (Aspect);
-- For Invariant case, insert immediately after the entity
-- declaration. We do not have to worry about delay issues
-- have a place to build the predicate function).
Ensure_Freeze_Node (E);
+ Set_Is_Delayed_Aspect (Aspect);
-- For Predicate case, insert immediately after the entity
-- declaration. We do not have to worry about delay issues
return;
end Build_Static_Predicate;
+ -----------------------------------------
+ -- Check_Aspect_At_End_Of_Declarations --
+ -----------------------------------------
+
+ procedure Check_Aspect_At_End_Of_Declarations (ASN : Node_Id) is
+ Ent : constant Entity_Id := Entity (ASN);
+ Ident : constant Node_Id := Identifier (ASN);
+
+ Freeze_Expr : constant Node_Id := Expression (ASN);
+ -- Preanalyzed expression from call to Check_Aspect_At_Freeze_Point
+
+ End_Decl_Expr : constant Node_Id := Entity (Ident);
+ -- Expression to be analyzed at end of declarations
+
+ T : constant Entity_Id := Etype (Freeze_Expr);
+ -- Type required for preanalyze call
+
+ A_Id : constant Aspect_Id := Get_Aspect_Id (Chars (Ident));
+
+ Err : Boolean;
+ -- Set False if error
+
+ -- On entry to this procedure, Entity (Ident) contains a copy of the
+ -- original expression from the aspect, saved for this purpose, and
+ -- but Expression (Ident) is a preanalyzed copy of the expression,
+ -- preanalyzed just after the freeze point.
+
+ begin
+ -- Case of stream attributes, just have to compare entities
+
+ if A_Id = Aspect_Input or else
+ A_Id = Aspect_Output or else
+ A_Id = Aspect_Read or else
+ A_Id = Aspect_Write
+ then
+ Analyze (End_Decl_Expr);
+ Err := Entity (End_Decl_Expr) /= Entity (Freeze_Expr);
+
+ -- All other cases
+
+ else
+ Preanalyze_Spec_Expression (End_Decl_Expr, T);
+ Err := not Fully_Conformant_Expressions (End_Decl_Expr, Freeze_Expr);
+ end if;
+
+ -- Output error message if error
+
+ if Err then
+ Error_Msg_NE
+ ("visibility of aspect for& changes after freeze point",
+ ASN, Ent);
+ Error_Msg_NE
+ ("?info: & is frozen here, aspects evaluated at this point",
+ Freeze_Node (Ent), Ent);
+ end if;
+ end Check_Aspect_At_End_Of_Declarations;
+
+ ----------------------------------
+ -- Check_Aspect_At_Freeze_Point --
+ ----------------------------------
+
+ procedure Check_Aspect_At_Freeze_Point (ASN : Node_Id) is
+ Ident : constant Node_Id := Identifier (ASN);
+ -- Identifier (use Entity field to save expression)
+
+ T : Entity_Id;
+ -- Type required for preanalyze call
+
+ A_Id : constant Aspect_Id := Get_Aspect_Id (Chars (Ident));
+
+ begin
+ -- On entry to this procedure, Entity (Ident) contains a copy of the
+ -- original expression from the aspect, saved for this purpose.
+
+ -- On exit from this procedure Entity (Ident) is unchanged, still
+ -- containing that copy, but Expression (Ident) is a preanalyzed copy
+ -- of the expression, preanalyzed just after the freeze point.
+
+ -- Make a copy of the expression to be preanalyed
+
+ Set_Expression (ASN, New_Copy_Tree (Entity (Ident)));
+
+ -- Find type for preanalyze call
+
+ case A_Id is
+
+ -- No_Aspect should be impossible
+
+ when No_Aspect =>
+ raise Program_Error;
+
+ -- Aspects taking an optional boolean argument. Note that we will
+ -- never be called with an empty expression, because such aspects
+ -- never need to be delayed anyway.
+
+ when Boolean_Aspects =>
+ pragma Assert (Present (Expression (ASN)));
+ T := Standard_Boolean;
+
+ -- Aspects corresponding to attribute definition clauses
+
+ when Aspect_Address =>
+ T := RTE (RE_Address);
+
+ when Aspect_Bit_Order =>
+ T := RTE (RE_Bit_Order);
+
+ when Aspect_External_Tag =>
+ T := Standard_String;
+
+ when Aspect_Storage_Pool =>
+ T := Class_Wide_Type (RTE (RE_Root_Storage_Pool));
+
+ when
+ Aspect_Alignment |
+ Aspect_Component_Size |
+ Aspect_Machine_Radix |
+ Aspect_Object_Size |
+ Aspect_Size |
+ Aspect_Storage_Size |
+ Aspect_Stream_Size |
+ Aspect_Value_Size =>
+ T := Any_Integer;
+
+ -- Stream attribute. Special case, the expression is just an entity
+ -- that does not need any resolution, so just analyze.
+
+ when Aspect_Input |
+ Aspect_Output |
+ Aspect_Read |
+ Aspect_Write =>
+ Analyze (Expression (ASN));
+ return;
+
+ -- Suppress/Unsupress/Warnings should never be delayed
+
+ when Aspect_Suppress |
+ Aspect_Unsuppress |
+ Aspect_Warnings =>
+ raise Program_Error;
+
+ -- Pre/Post/Invariant/Predicate take boolean expressions
+
+ when Aspect_Pre |
+ Aspect_Post |
+ Aspect_Invariant |
+ Aspect_Predicate =>
+ T := Standard_Boolean;
+ end case;
+
+ -- Do the preanalyze call
+
+ Preanalyze_Spec_Expression (Expression (ASN), T);
+ end Check_Aspect_At_Freeze_Point;
+
-----------------------------------
-- Check_Constant_Address_Clause --
-----------------------------------
Table_Increment => 200,
Table_Name => "Independence_Checks");
+ -----------------------------------
+ -- Handling of Aspect Visibility --
+ -----------------------------------
+
+ -- The visibility of aspects is tricky. First, the visibility is delayed
+ -- to the freeze point. This is not too complicated, what we do is simply
+ -- to leave the aspect "laying in wait" for the freeze point, and at that
+ -- point materialize and analye the corresponding attribute definition
+ -- clause or pragma. There is some special processing for preconditions
+ -- and postonditions, where the pragmas themselves deal with the required
+ -- delay, but basically the approach is the same, delay analysis of the
+ -- expression to the freeze point.
+
+ -- Much harder is the requirement for diagnosing cases in which an early
+ -- freeze causes a change in visibility. Consider:
+
+ -- package AspectVis is
+ -- R_Size : constant Integer := 32;
+ --
+ -- package Inner is
+ -- type R is new Integer with
+ -- Size => R_Size;
+ -- F : R; -- freezes
+ -- R_Size : constant Integer := 64;
+ -- S : constant Integer := R'Size; -- 32 not 64
+ -- end Inner;
+ -- end AspectVis;
+
+ -- Here the 32 not 64 shows what would be expected if this program were
+ -- legal, since the evaluation of R_Size has to be done at the freeze
+ -- point and gets the outer definition not the inner one.
+
+ -- But the language rule requires this program to be diagnosed as illegal
+ -- because the visibility changes between the freeze point and the end of
+ -- the declarative region.
+
+ -- To meet this requirement, we first note that the Expression field of the
+ -- N_Aspect_Specification node holds the raw unanalyzed expression, which
+ -- will get used in processing the aspect. At the time of analyzing the
+ -- N_Aspect_Specification node, we create a complete copy of the expression
+ -- and store it in the entity field of the Identifier (an odd usage, but
+ -- the identifier is not used except to identify the aspect, so its Entity
+ -- field is otherwise unused, and we are short of room in the node).
+
+ -- This copy stays unanalyzed up to the freeze point, where we analyze the
+ -- resulting pragma or attribute definition clause, except that in the
+ -- case of invariants and predicates, we mark occurrences of the subtype
+ -- name as having the entity of the subprogram parameter, so that they
+ -- will not cause trouble in the following steps.
+
+ -- Then at the freeze point, we create another copy of this unanalyzed
+ -- expression. By this time we no longer need the Expression field for
+ -- other purposes, so we can store it there. Now we have two copies of
+ -- the original unanalyzed expression. One of them gets preanalyzed at
+ -- the freeze point to capture the visibility at the freeze point.
+
+ -- Now when we hit the freeze all at the end of the declarative part, if
+ -- we come across a frozen entity with delayed aspects, we still have one
+ -- copy of the unanalyzed expression available in the node, and we again
+ -- do a preanalysis using that copy and the visibility at the end of the
+ -- declarative part. Now we have two preanalyzed expression (preanalysis
+ -- is good enough, since we are only interested in referenced entities).
+ -- One captures the visibility at the freeze point, the other captures the
+ -- visibility at the end of the declarative part. We see if the entities
+ -- in these two expressions are the same, by seeing if the two expressions
+ -- are fully conformant, and if not, issue appropriate error messages.
+
+ -- Quite an awkward procedure, but this is an awkard requirement!
+
+ procedure Check_Aspect_At_Freeze_Point (ASN : Node_Id);
+ -- Performs the processing described above at the freeze point, ASN is the
+ -- N_Aspect_Specification node for the aspect.
+
+ procedure Check_Aspect_At_End_Of_Declarations (ASN : Node_Id);
+ -- Performs the processing described above at the freeze all point, and
+ -- issues appropriate error messages if the visibility has indeed changed.
+ -- Again, ASN is the N_Aspect_Specification node for the aspect.
end Sem_Ch13;
---------------
-- pragma Predicate
- -- ([Entity =>] type_LOCAL_NAME,
- -- [Check =>] EXPRESSION);
+ -- ([Entity =>] type_LOCAL_NAME,
+ -- [Check =>] EXPRESSION);
when Pragma_Predicate => Predicate : declare
Type_Id : Node_Id;
(N : Node_Id) return Boolean is
begin
pragma Assert (False
+ or else NT (N).Nkind = N_Aspect_Specification
or else NT (N).Nkind = N_Attribute_Definition_Clause
or else NT (N).Nkind = N_Pragma);
return Flag14 (N);
(N : Node_Id; Val : Boolean := True) is
begin
pragma Assert (False
+ or else NT (N).Nkind = N_Aspect_Specification
or else NT (N).Nkind = N_Attribute_Definition_Clause
or else NT (N).Nkind = N_Pragma);
Set_Flag14 (N, Val);
-- Is_Delayed_Aspect (Flag14-Sem)
-- Present in N_Pragma and N_Attribute_Definition_Clause nodes which
-- come from aspect specifications, where the evaluation of the aspect
- -- must be delayed to the freeze point.
+ -- must be delayed to the freeze point. This flag is also set True in
+ -- the corresponding N_Aspect_Specification node.
-- Is_Controlling_Actual (Flag16-Sem)
-- This flag is set on in an expression that is a controlling argument in
-- Next_Rep_Item (Node5-Sem)
-- Split_PPC (Flag17) Set if split pre/post attribute
-- Is_Boolean_Aspect (Flag16-Sem)
+ -- Is_Delayed_Aspect (Flag14-Sem)
-- Note: Aspect_Specification is an Ada 2012 feature
+ -- Note: The Identifier serves to identify the aspect involved (it
+ -- is the aspect whose name corresponds to the Chars field). This
+ -- means that the other fields of this identifier are unused, and
+ -- in particular we use the Entity field of this identifier to save
+ -- a copy of the expression for visibility analysis, see spec of
+ -- Sem_Ch13 for full details of this usage.
+
-- Note: When a Pre or Post aspect specification is processed, it is
-- broken into AND THEN sections. The left most section has Split_PPC
-- set to False, indicating that it is the original specification (e.g.
projects / gcc.git / commitdiff