+2011-08-02 Robert Dewar <dewar@adacore.com>
+
+ * a-direct.adb, sinfo.ads, exp_ch9.adb, scng.adb, sem_util.adb,
+ sem_util.ads, restrict.ads, par-prag.adb: Minor reformatting and/or
+ code reorganization.
+
+2011-08-02 Robert Dewar <dewar@adacore.com>
+
+ * debug.adb: Debug flag d.P to suppress length comparison optimization
+ * exp_ch4.adb (Optimize_Length_Comparison): New routine to optimize
+ comparison of Length by comparing First/Last instead.
+
+2011-08-02 Matthew Heaney <heaney@adacore.com>
+
+ * a-cobove.ads: Code clean up.
+
2011-08-02 Vincent Celier <celier@adacore.com>
* adaint.c (file_names_case_sensitive_cache): New static int.
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2011, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
function "=" (L, R : Elements_Array) return Boolean is abstract;
type Vector (Capacity : Count_Type) is tagged record
- Elements : Elements_Array (1 .. Capacity);
+ Elements : Elements_Array (1 .. Capacity) := (others => <>);
Last : Extended_Index := No_Index;
Busy : Natural := 0;
Lock : Natural := 0;
with Ada.Unchecked_Deallocation;
with Ada.Characters.Handling; use Ada.Characters.Handling;
-with System.CRTL; use System.CRTL;
-with System.OS_Constants;
-with System.OS_Lib; use System.OS_Lib;
-with System.Regexp; use System.Regexp;
-with System.File_IO; use System.File_IO;
-with System;
+with System.CRTL; use System.CRTL;
+with System.OS_Constants; use System.OS_Constants;
+with System.OS_Lib; use System.OS_Lib;
+with System.Regexp; use System.Regexp;
+with System.File_IO; use System.File_IO;
+with System; use System;
package body Ada.Directories is
Filename_Max : constant Integer := 1024;
-- 1024 is the value of FILENAME_MAX in stdio.h
- type Dir_Type_Value is new System.Address;
+ type Dir_Type_Value is new Address;
-- This is the low-level address directory structure as returned by the C
-- opendir routine.
- No_Dir : constant Dir_Type_Value := Dir_Type_Value (System.Null_Address);
+ No_Dir : constant Dir_Type_Value := Dir_Type_Value (Null_Address);
Dir_Separator : constant Character;
pragma Import (C, Dir_Separator, "__gnat_dir_separator");
end;
end if;
- -- The implementation uses System.OS_Lib.Copy_File
+ -- Do actual copy using System.OS_Lib.Copy_File
Copy_File (Source_Name, Target_Name, Success, Mode, Preserve);
Path_Len : Natural := Max_Path;
Buffer : String (1 .. 1 + Max_Path + 1);
- procedure Local_Get_Current_Dir
- (Dir : System.Address;
- Length : System.Address);
+ procedure Local_Get_Current_Dir (Dir : Address; Length : Address);
pragma Import (C, Local_Get_Current_Dir, "__gnat_get_current_dir");
begin
raise Name_Error with "file """ & Name & """ does not exist";
else
- -- The implementation uses System.OS_Lib.Delete_File
+ -- Do actual deletion using System.OS_Lib.Delete_File
Delete_File (Name, Success);
File_Name : constant String := Simple_Name (Dir_Ent);
begin
- if System.OS_Lib.Is_Directory (File_Name) then
+ if OS_Lib.Is_Directory (File_Name) then
if File_Name /= "." and then File_Name /= ".." then
Delete_Tree (File_Name);
end if;
Kind : File_Kind := Ordinary_File;
-- Initialized to avoid a compilation warning
- Filename_Addr : System.Address;
+ Filename_Addr : Address;
Filename_Len : aliased Integer;
Buffer : array (0 .. Filename_Max + 12) of Character;
-- field for the filename.
function readdir_gnat
- (Directory : System.Address;
- Buffer : System.Address;
- Last : not null access Integer) return System.Address;
+ (Directory : Address;
+ Buffer : Address;
+ Last : not null access Integer) return Address;
pragma Import (C, readdir_gnat, "__gnat_readdir");
- use System;
-
begin
-- Search.Value.Is_Valid is always True when Fetch_Next_Entry is called
loop
Filename_Addr :=
readdir_gnat
- (System.Address (Search.Value.Dir),
+ (Address (Search.Value.Dir),
Buffer'Address,
Filename_Len'Access);
-- If no matching entry is found, set Is_Valid to False
- if Filename_Addr = System.Null_Address then
+ if Filename_Addr = Null_Address then
Search.Value.Is_Valid := False;
exit;
end if;
-----------------
function File_Exists (Name : String) return Boolean is
- function C_File_Exists (A : System.Address) return Integer;
+ function C_File_Exists (A : Address) return Integer;
pragma Import (C, C_File_Exists, "__gnat_file_exists");
C_Name : String (1 .. Name'Length + 1);
declare
-- We need to resolve links because of A.16(47), since we must not
- -- return alternative names for files
+ -- return alternative names for files.
+
Value : constant String := Normalize_Pathname (Name);
subtype Result is String (1 .. Value'Length);
+
begin
return Result (Value);
end;
& """ designates a file that already exists";
else
- -- The implementation uses System.OS_Lib.Rename_File
+ -- Do actual rename using System.OS_Lib.Rename_File
Rename_File (Old_Name, New_Name, Success);
if not Success then
+
-- AI05-0231-1: Name_Error should be raised in case a directory
-- component of New_Name does not exist (as in New_Name =>
-- "/no-such-dir/new-filename"). ENOENT indicates that. ENOENT
-- also indicate that the Old_Name does not exist, but we already
-- checked for that above. All other errors are Use_Error.
- if Errno = System.OS_Constants.ENOENT then
+ if Errno = ENOENT then
raise Name_Error with
"file """ & Containing_Directory (New_Name) & """ not found";
Cut_End := Path'Last;
Check_For_Standard_Dirs : declare
- BN : constant String := Path (Cut_Start .. Cut_End);
+ BN : constant String := Path (Cut_Start .. Cut_End);
+
Has_Drive_Letter : constant Boolean :=
- System.OS_Lib.Path_Separator /= ':';
+ OS_Lib.Path_Separator /= ':';
-- If Path separator is not ':' then we are on a DOS based OS
-- where this character is used as a drive letter separator.
function Size (Name : String) return File_Size is
C_Name : String (1 .. Name'Length + 1);
- function C_Size (Name : System.Address) return Long_Integer;
+ function C_Size (Name : Address) return Long_Integer;
pragma Import (C, C_Size, "__gnat_named_file_length");
begin
-- d.M
-- d.N
-- d.O Dump internal SCO tables
- -- d.P
+ -- d.P Previous (non-optimized) handling of length comparisons
-- d.Q
-- d.R
-- d.S Force Optimize_Alignment (Space)
-- the ALI file, the internal SCO tables (SCO_Table/SCO_Unit_Table)
-- are dumped for debugging purposes.
+ -- d.P Previous non-optimized handling of length comparisons. Setting this
+ -- flag inhibits the effect of Optimize_Length_Comparison in Exp_Ch4.
+ -- This is there in case we find a situation where the optimization
+ -- malfunctions, to provide a work around.
+
-- d.S Force Optimize_Alignment (Space) mode as the default
-- d.T Force Optimize_Alignment (Time) mode as the default
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- constrained type (the caller has ensured this by using
-- Convert_To_Actual_Subtype if necessary).
+ procedure Optimize_Length_Comparison (N : Node_Id);
+ -- Given an expression, if it is of the form X'Length op N (or the other
+ -- way round), where N is known at compile time to be 0 or 1, and X is a
+ -- simple entity, and op is a comparison operator, optimizes it into a
+ -- comparison of First and Last.
+
procedure Rewrite_Comparison (N : Node_Id);
-- If N is the node for a comparison whose outcome can be determined at
-- compile time, then the node N can be rewritten with True or False. If
if Inside_A_Return_Statement (N)
and then
(Ekind (PtrT) = E_Anonymous_Access_Type
- or else
- (Ekind (PtrT) = E_Access_Type
- and then No (Associated_Final_Chain (PtrT))))
+ or else
+ (Ekind (PtrT) = E_Access_Type
+ and then No (Associated_Final_Chain (PtrT))))
then
declare
Decl : Node_Id;
Expand_Vax_Comparison (N);
return;
end if;
+
+ Optimize_Length_Comparison (N);
end Expand_N_Op_Eq;
-----------------------
Expand_Vax_Comparison (N);
return;
end if;
+
+ Optimize_Length_Comparison (N);
end Expand_N_Op_Ge;
--------------------
Expand_Vax_Comparison (N);
return;
end if;
+
+ Optimize_Length_Comparison (N);
end Expand_N_Op_Gt;
--------------------
Expand_Vax_Comparison (N);
return;
end if;
+
+ Optimize_Length_Comparison (N);
end Expand_N_Op_Le;
--------------------
Expand_Vax_Comparison (N);
return;
end if;
+
+ Optimize_Length_Comparison (N);
end Expand_N_Op_Lt;
-----------------------
Analyze_And_Resolve (N, Standard_Boolean);
end;
end if;
+
+ Optimize_Length_Comparison (N);
end Expand_N_Op_Ne;
---------------------
return Func_Body;
end Make_Boolean_Array_Op;
+ --------------------------------
+ -- Optimize_Length_Comparison --
+ --------------------------------
+
+ procedure Optimize_Length_Comparison (N : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
+ Typ : constant Entity_Id := Etype (N);
+ Result : Node_Id;
+
+ Left : Node_Id;
+ Right : Node_Id;
+ -- First and Last attribute reference nodes, which end up as left and
+ -- right operands of the optimized result.
+
+ Is_Zero : Boolean;
+ -- True for comparison operand of zero
+
+ Comp : Node_Id;
+ -- Comparison operand, set only if Is_Zero is false
+
+ Ent : Entity_Id;
+ -- Entity whose length is being compared
+
+ Index : Node_Id;
+ -- Integer_Literal node for length attribute expression, or Empty
+ -- if there is no such expression present.
+
+ Ityp : Entity_Id;
+ -- Type of array index to which 'Length is applied
+
+ Op : Node_Kind := Nkind (N);
+ -- Kind of comparison operator, gets flipped if operands backwards
+
+ function Is_Optimizable (N : Node_Id) return Boolean;
+ -- Tests N to see if it is an optimizable comparison value (defined
+ -- as constant zero or one, or something else where the value is known
+ -- to be in range of 32-bits, and where the corresponding Length value
+ -- is also known to be 32-bits. If result is true, sets Is_Zero, Ityp,
+ -- and Comp accordingly.
+
+ function Is_Entity_Length (N : Node_Id) return Boolean;
+ -- Tests if N is a length attribute applied to a simple entity. If so,
+ -- returns True, and sets Ent to the entity, and Index to the integer
+ -- literal provided as an attribute expression, or to Empty if none.
+ -- Also returns True if the expression is a generated type conversion
+ -- whose expression is of the desired form. This latter case arises
+ -- when Apply_Universal_Integer_Attribute_Check installs a conversion
+ -- to check for being in range, which is not needed in this context.
+ -- Returns False if neither condition holds.
+
+ function Prepare_64 (N : Node_Id) return Node_Id;
+ -- Given a discrete expression, returns a Long_Long_Integer typed
+ -- expression representing the underlying value of the expression.
+ -- This is done with an unchecked conversion to the result type. We
+ -- use unchecked conversion to handle the enumeration type case.
+
+ ----------------------
+ -- Is_Entity_Length --
+ ----------------------
+
+ function Is_Entity_Length (N : Node_Id) return Boolean is
+ begin
+ if Nkind (N) = N_Attribute_Reference
+ and then Attribute_Name (N) = Name_Length
+ and then Is_Entity_Name (Prefix (N))
+ then
+ Ent := Entity (Prefix (N));
+
+ if Present (Expressions (N)) then
+ Index := First (Expressions (N));
+ else
+ Index := Empty;
+ end if;
+
+ return True;
+
+ elsif Nkind (N) = N_Type_Conversion
+ and then not Comes_From_Source (N)
+ then
+ return Is_Entity_Length (Expression (N));
+
+ else
+ return False;
+ end if;
+ end Is_Entity_Length;
+
+ --------------------
+ -- Is_Optimizable --
+ --------------------
+
+ function Is_Optimizable (N : Node_Id) return Boolean is
+ Val : Uint;
+ OK : Boolean;
+ Lo : Uint;
+ Hi : Uint;
+ Indx : Node_Id;
+
+ begin
+ if Compile_Time_Known_Value (N) then
+ Val := Expr_Value (N);
+
+ if Val = Uint_0 then
+ Is_Zero := True;
+ Comp := Empty;
+ return True;
+
+ elsif Val = Uint_1 then
+ Is_Zero := False;
+ Comp := Empty;
+ return True;
+ end if;
+ end if;
+
+ -- Here we have to make sure of being within 32-bits
+
+ Determine_Range (N, OK, Lo, Hi, Assume_Valid => True);
+
+ if not OK
+ or else Lo < UI_From_Int (Int'First)
+ or else Hi > UI_From_Int (Int'Last)
+ then
+ return False;
+ end if;
+
+ -- Comparison value was within 32-bits, so now we must check the
+ -- index value to make sure it is also within 32-bits.
+
+ Indx := First_Index (Etype (Ent));
+
+ if Present (Index) then
+ for J in 2 .. UI_To_Int (Intval (Index)) loop
+ Next_Index (Indx);
+ end loop;
+ end if;
+
+ Ityp := Etype (Indx);
+
+ if Esize (Ityp) > 32 then
+ return False;
+ end if;
+
+ Is_Zero := False;
+ Comp := N;
+ return True;
+ end Is_Optimizable;
+
+ ----------------
+ -- Prepare_64 --
+ ----------------
+
+ function Prepare_64 (N : Node_Id) return Node_Id is
+ begin
+ return Unchecked_Convert_To (Standard_Long_Long_Integer, N);
+ end Prepare_64;
+
+ -- Start of processing for Optimize_Length_Comparison
+
+ begin
+ -- Nothing to do if not a comparison
+
+ if Op not in N_Op_Compare then
+ return;
+ end if;
+
+ -- Nothing to do if special -gnatd.P debug flag set
+
+ if Debug_Flag_Dot_PP then
+ return;
+ end if;
+
+ -- Ent'Length op 0/1
+
+ if Is_Entity_Length (Left_Opnd (N))
+ and then Is_Optimizable (Right_Opnd (N))
+ then
+ null;
+
+ -- 0/1 op Ent'Length
+
+ elsif Is_Entity_Length (Right_Opnd (N))
+ and then Is_Optimizable (Left_Opnd (N))
+ then
+ -- Flip comparison to opposite sense
+
+ case Op is
+ when N_Op_Lt => Op := N_Op_Gt;
+ when N_Op_Le => Op := N_Op_Ge;
+ when N_Op_Gt => Op := N_Op_Lt;
+ when N_Op_Ge => Op := N_Op_Le;
+ when others => null;
+ end case;
+
+ -- Else optimization not possible
+
+ else
+ return;
+ end if;
+
+ -- Fall through if we will do the optimization
+
+ -- Cases to handle:
+
+ -- X'Length = 0 => X'First > X'Last
+ -- X'Length = 1 => X'First = X'Last
+ -- X'Length = n => X'First + (n - 1) = X'Last
+
+ -- X'Length /= 0 => X'First <= X'Last
+ -- X'Length /= 1 => X'First /= X'Last
+ -- X'Length /= n => X'First + (n - 1) /= X'Last
+
+ -- X'Length >= 0 => always true, warn
+ -- X'Length >= 1 => X'First <= X'Last
+ -- X'Length >= n => X'First + (n - 1) <= X'Last
+
+ -- X'Length > 0 => X'First <= X'Last
+ -- X'Length > 1 => X'First < X'Last
+ -- X'Length > n => X'First + (n - 1) < X'Last
+
+ -- X'Length <= 0 => X'First > X'Last (warn, could be =)
+ -- X'Length <= 1 => X'First >= X'Last
+ -- X'Length <= n => X'First + (n - 1) >= X'Last
+
+ -- X'Length < 0 => always false (warn)
+ -- X'Length < 1 => X'First > X'Last
+ -- X'Length < n => X'First + (n - 1) > X'Last
+
+ -- Note: for the cases of n (not constant 0,1), we require that the
+ -- corresponding index type be integer or shorter (i.e. not 64-bit),
+ -- and the same for the comparison value. Then we do the comparison
+ -- using 64-bit arithmetic (actually long long integer), so that we
+ -- cannot have overflow intefering with the result.
+
+ -- First deal with warning cases
+
+ if Is_Zero then
+ case Op is
+
+ -- X'Length >= 0
+
+ when N_Op_Ge =>
+ Rewrite (N,
+ Convert_To (Typ, New_Occurrence_Of (Standard_True, Loc)));
+ Analyze_And_Resolve (N, Typ);
+ Warn_On_Known_Condition (N);
+ return;
+
+ -- X'Length < 0
+
+ when N_Op_Lt =>
+ Rewrite (N,
+ Convert_To (Typ, New_Occurrence_Of (Standard_False, Loc)));
+ Analyze_And_Resolve (N, Typ);
+ Warn_On_Known_Condition (N);
+ return;
+
+ when N_Op_Le =>
+ if Constant_Condition_Warnings
+ and then Comes_From_Source (Original_Node (N))
+ then
+ Error_Msg_N ("could replace by ""'=""?", N);
+ end if;
+
+ Op := N_Op_Eq;
+
+ when others =>
+ null;
+ end case;
+ end if;
+
+ -- Build the First reference we will use
+
+ Left :=
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Ent, Loc),
+ Attribute_Name => Name_First);
+
+ if Present (Index) then
+ Set_Expressions (Left, New_List (New_Copy (Index)));
+ end if;
+
+ -- If general value case, then do the addition of (n - 1), and
+ -- also add the needed conversions to type Long_Long_Integer.
+
+ if Present (Comp) then
+ Left :=
+ Make_Op_Add (Loc,
+ Left_Opnd => Prepare_64 (Left),
+ Right_Opnd =>
+ Make_Op_Subtract (Loc,
+ Left_Opnd => Prepare_64 (Comp),
+ Right_Opnd => Make_Integer_Literal (Loc, 1)));
+ end if;
+
+ -- Build the Last reference we will use
+
+ Right :=
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Ent, Loc),
+ Attribute_Name => Name_Last);
+
+ if Present (Index) then
+ Set_Expressions (Right, New_List (New_Copy (Index)));
+ end if;
+
+ -- If general operand, convert Last reference to Long_Long_Integer
+
+ if Present (Comp) then
+ Right := Prepare_64 (Right);
+ end if;
+
+ -- Check for cases to optimize
+
+ -- X'Length = 0 => X'First > X'Last
+ -- X'Length < 1 => X'First > X'Last
+ -- X'Length < n => X'First + (n - 1) > X'Last
+
+ if (Is_Zero and then Op = N_Op_Eq)
+ or else (not Is_Zero and then Op = N_Op_Lt)
+ then
+ Result :=
+ Make_Op_Gt (Loc,
+ Left_Opnd => Left,
+ Right_Opnd => Right);
+
+ -- X'Length = 1 => X'First = X'Last
+ -- X'Length = n => X'First + (n - 1) = X'Last
+
+ elsif not Is_Zero and then Op = N_Op_Eq then
+ Result :=
+ Make_Op_Eq (Loc,
+ Left_Opnd => Left,
+ Right_Opnd => Right);
+
+ -- X'Length /= 0 => X'First <= X'Last
+ -- X'Length > 0 => X'First <= X'Last
+
+ elsif Is_Zero and (Op = N_Op_Ne or else Op = N_Op_Gt) then
+ Result :=
+ Make_Op_Le (Loc,
+ Left_Opnd => Left,
+ Right_Opnd => Right);
+
+ -- X'Length /= 1 => X'First /= X'Last
+ -- X'Length /= n => X'First + (n - 1) /= X'Last
+
+ elsif not Is_Zero and then Op = N_Op_Ne then
+ Result :=
+ Make_Op_Ne (Loc,
+ Left_Opnd => Left,
+ Right_Opnd => Right);
+
+ -- X'Length >= 1 => X'First <= X'Last
+ -- X'Length >= n => X'First + (n - 1) <= X'Last
+
+ elsif not Is_Zero and then Op = N_Op_Ge then
+ Result :=
+ Make_Op_Le (Loc,
+ Left_Opnd => Left,
+ Right_Opnd => Right);
+
+ -- X'Length > 1 => X'First < X'Last
+ -- X'Length > n => X'First + (n = 1) < X'Last
+
+ elsif not Is_Zero and then Op = N_Op_Gt then
+ Result :=
+ Make_Op_Lt (Loc,
+ Left_Opnd => Left,
+ Right_Opnd => Right);
+
+ -- X'Length <= 1 => X'First >= X'Last
+ -- X'Length <= n => X'First + (n - 1) >= X'Last
+
+ elsif not Is_Zero and then Op = N_Op_Le then
+ Result :=
+ Make_Op_Ge (Loc,
+ Left_Opnd => Left,
+ Right_Opnd => Right);
+
+ -- Should not happen at this stage
+
+ else
+ raise Program_Error;
+ end if;
+
+ -- Rewrite and finish up
+
+ Rewrite (N, Result);
+ Analyze_And_Resolve (N, Typ);
+ return;
+ end Optimize_Length_Comparison;
+
------------------------
-- Rewrite_Comparison --
------------------------
end if;
-- If the type of the dispatching object is an access type then return
- -- an explicit dereference
+ -- an explicit dereference.
if Is_Access_Type (Etype (Object)) then
Object := Make_Explicit_Dereference (Sloc (N), Object);
procedure Process_Restrictions_Or_Restriction_Warnings;
-- Common processing for Restrictions and Restriction_Warnings pragmas.
- -- This routine processes the cases of No_Obsolescent_Features and SPARK,
- -- which are the only restriction that have syntactic effects. In the case
- -- of SPARK, it controls whether the scanner generates a token
- -- Tok_SPARK_Hide for HIDE directives formatted as Ada comments. No general
- -- error checking is done, since this will be done in Sem_Prag. The other
- -- case processed is pragma Restrictions No_Dependence, since otherwise
- -- this is done too late.
+ -- For the most part, restrictions need not be processed at parse time,
+ -- since they only affect semantic processing. This routine handles the
+ -- exceptions as follows
+ --
+ -- No_Obsolescent_Features must be processed at parse time, since there
+ -- are some obsolescent features (e.g. character replacements) which are
+ -- handled at parse time.
+ --
+ -- SPARK must be processed at parse time, since this restriction controls
+ -- whether the scanner recognizes a spark HIDE directive formatted as an
+ -- Ada comment (and generates a Tok_SPARK_Hide token for the directive).
+ --
+ -- No_Dependence must be processed at parse time, since otherwise it gets
+ -- handled too late.
+ --
+ -- Note that we don't need to do full error checking for badly formed cases
+ -- of restrictions, since these will be caught during semantic analysis.
----------
-- Arg1 --
Set_Restriction (No_Obsolescent_Features, Pragma_Node);
Restriction_Warnings (No_Obsolescent_Features) :=
Prag_Id = Pragma_Restriction_Warnings;
+
when SPARK =>
Set_Restriction (SPARK, Pragma_Node);
Restriction_Warnings (SPARK) :=
Prag_Id = Pragma_Restriction_Warnings;
+
when others =>
null;
end case;
-- SPARK Restriction Control --
-------------------------------
- -- SPARK HIDE directives allow turning off SPARK restriction for a
- -- specified region of code, and the following tables are the data
- -- structures used to keep track of these regions.
+ -- SPARK HIDE directives allow the effect of the SPARK restriction to be
+ -- turned off for a specified region of code, and the following tables are
+ -- the data structures used to keep track of these regions.
-- The table contains pairs of source locations, the first being the start
-- location for hidden region, and the second being the end location.
return;
end if;
- -- Generate a token Tok_SPARK_Hide for a SPARK HIDE directive
- -- only if the SPARK restriction is set for this unit.
+ -- If the SPARK restriction is set for this unit, then generate
+ -- a token Tok_SPARK_Hide for a SPARK HIDE directive.
if Restriction_Check_Required (SPARK)
and then Source (Start_Of_Comment) = '#'
procedure Mark_Non_ALFA_Subprogram_Unconditional is
Cur_Subp : constant Entity_Id := Current_Subprogram;
+
begin
if Present (Cur_Subp)
and then (Is_Subprogram (Cur_Subp)
-- then mark the subprogram as not in ALFA. Otherwise, mark the
-- subprogram body as not in ALFA.
+ -- This comment just says what is done, but not why ??? and it
+ -- just repeats what is in the spec ???
+
if In_Pre_Post_Expression then
Set_Is_In_ALFA (Cur_Subp, False);
else
procedure Mark_Non_ALFA_Subprogram;
-- If Current_Subprogram is not Empty, mark either its specification or its
- -- body as not being in ALFA. If called during the analysis of a
- -- precondition or postcondition, as indicated by the flag
+ -- body as not being in ALFA. If this procedure is called during the
+ -- analysis of a precondition or postcondition, as indicated by the flag
-- In_Pre_Post_Expression, mark the specification as not being in ALFA.
-- Otherwise, mark the body as not being in ALFA.
+ --
+ -- I would really like to see more comments on this peculiar processing
+ -- for precondition/postcondition, the comment above says what is done
+ -- but not why???
function Defining_Entity (N : Node_Id) return Entity_Id;
-- Given a declaration N, returns the associated defining entity. If the
-- this is required, see Exp_Ch11.Remove_Handler_Entries.
-- Has_Dynamic_Length_Check (Flag10-Sem)
- -- This flag is present on all expression nodes. It is set to indicate
+ -- This flag is present in all expression nodes. It is set to indicate
-- that one of the routines in unit Checks has generated a length check
-- action which has been inserted at the flagged node. This is used to
-- avoid the generation of duplicate checks.
-- expression nodes. It is set to indicate that one of the routines in
-- unit Checks has generated a range check action which has been inserted
-- at the flagged node. This is used to avoid the generation of duplicate
- -- checks.
+ -- checks. Why does this occur on N_Subtype_Declaration nodes, what does
+ -- it mean in that context???
-- Has_Local_Raise (Flag8-Sem)
-- Present in exception handler nodes. Set if the handler can be entered
OSDN Git Service
