+2013-04-11 Doug Rupp <rupp@adacore.com>
+
+ * gnatlink.adb: Fold program basename to lower case on VMS for
+ consistency.
+
+2013-04-11 Matthew Heaney <heaney@adacore.com>
+
+ * a-rbtgbo.adb (Generic_Equal): Initialize Result variable before
+ entering loop.
+
+2013-04-11 Arnaud Charlet <charlet@adacore.com>
+
+ * xgnatugn.adb: Remove dead code (handling of @ifset/@ifclear).
+
+2013-04-11 Arnaud Charlet <charlet@adacore.com>
+
+ * gnat_ugn.texi: Remove some use of ifset in menus. Not strictly
+ needed, and seems to confuse some versions of makeinfo.
+
+2013-04-11 Javier Miranda <miranda@adacore.com>
+
+ * einfo.adb (Is_Thunk): Remove assertion.
+ (Set_Is_Thunk): Add assertion.
+ * einfo.ads (Is_Thunk): Complete documentation.
+ * exp_ch11.adb (Expand_N_Handled_Sequence_Of_Statements): Code cleanup.
+ * exp_ch3.ad[sb] (Is_Variable_Size_Array): Moved to sem_util
+ (Is_Variable_Size_Record): Moved to sem_util
+ * exp_ch6.adb (Expand_Call): Code cleanup.
+ (Expand_N_Extended_Return_Statement): Code cleanup.
+ (Expand_Simple_Function_Return): Code cleanup.
+ * exp_disp.adb Remove dependency on exp_ch3
+ (Expand_Interface_Thunk): Add minimum decoration needed to set
+ attribute Is_Thunk.
+ * sem_ch3.ad[sb] (Is_Constant_Bound): moved to sem_util
+ * sem_util.ad[sb] (Is_Constant_Bound): Moved from
+ sem_ch3 (Is_Variable_Size_Array): Moved from exp_ch3
+ (Is_Variable_Size_Record): Moved from exp_ch3
+
2013-04-11 Javier Miranda <miranda@adacore.com>
* exp_ch11.adb (Expand_N_Handled_Sequence_Of_Statements): Do
L_Node := Left.First;
R_Node := Right.First;
+ Result := True;
while L_Node /= 0 loop
if not Is_Equal (Left.Nodes (L_Node), Right.Nodes (R_Node)) then
Result := False;
function Is_Thunk (Id : E) return B is
begin
- pragma Assert (Is_Subprogram (Id));
return Flag225 (Id);
end Is_Thunk;
procedure Set_Is_Thunk (Id : E; V : B := True) is
begin
+ pragma Assert (Is_Subprogram (Id));
Set_Flag225 (Id, V);
end Set_Is_Thunk;
-- Applies to all entities. True for task types and subtypes
-- Is_Thunk (Flag225)
--- Defined in all entities for subprograms (functions, procedures, and
--- operators). True for subprograms that are thunks, that is small
--- subprograms built by the expander for tagged types that cover
--- interface types. At run-time thunks displace the pointer to the object
--- (pointer named "this" in the C++ terminology) from a secondary
--- dispatch table to the primary dispatch table associated with a given
--- tagged type. Set by Expand_Interface_Thunk and used by Expand_Call to
--- handle extra actuals associated with accessibility level.
+-- Applies to all entities. True for subprograms that are thunks: that is
+-- small subprograms built by the expander for tagged types that cover
+-- interface types. As part of the runtime call to an interface, thunks
+-- displace the pointer to the object (pointer named "this" in the C++
+-- terminology) from a secondary dispatch table to the primary dispatch
+-- table associated with a given tagged type; if the thunk is a function
+-- that returns an object which covers an interface type then the thunk
+-- displaces the pointer to the object from the primary dispatch table to
+-- the secondary dispatch table associated with the interface type. Set
+-- by Expand_Interface_Thunk and used by Expand_Call to handle extra
+-- actuals associated with accessibility level.
-- Is_Trivial_Subprogram (Flag235)
-- Defined in all entities. Set in subprograms where either the body
-- No cleanup action needed in thunks associated with interfaces
-- because they only displace the pointer to the object.
- and then not (Is_Subprogram (Current_Scope)
- and then Is_Thunk (Current_Scope))
+ and then not Is_Thunk (Current_Scope)
then
Expand_Cleanup_Actions (Parent (N));
else
function Is_User_Defined_Equality (Prim : Node_Id) return Boolean;
-- Returns true if Prim is a user defined equality function
- function Is_Variable_Size_Array (E : Entity_Id) return Boolean;
- -- Returns true if E has variable size components
-
function Make_Eq_Body
(Typ : Entity_Id;
Eq_Name : Name_Id) return Node_Id;
and then Base_Type (Etype (Prim)) = Standard_Boolean;
end Is_User_Defined_Equality;
- ----------------------------
- -- Is_Variable_Size_Array --
- ----------------------------
-
- function Is_Variable_Size_Array (E : Entity_Id) return Boolean is
- Idx : Node_Id;
-
- begin
- pragma Assert (Is_Array_Type (E));
-
- -- Check if some index is initialized with a non-constant value
-
- Idx := First_Index (E);
- while Present (Idx) loop
- if Nkind (Idx) = N_Range then
- if not Is_Constant_Bound (Low_Bound (Idx))
- or else not Is_Constant_Bound (High_Bound (Idx))
- then
- return True;
- end if;
- end if;
-
- Idx := Next_Index (Idx);
- end loop;
-
- return False;
- end Is_Variable_Size_Array;
-
- -----------------------------
- -- Is_Variable_Size_Record --
- -----------------------------
-
- function Is_Variable_Size_Record (E : Entity_Id) return Boolean is
- Comp : Entity_Id;
- Comp_Typ : Entity_Id;
-
- begin
- pragma Assert (Is_Record_Type (E));
-
- Comp := First_Entity (E);
- while Present (Comp) loop
- Comp_Typ := Etype (Comp);
-
- -- Recursive call if the record type has discriminants
-
- if Is_Record_Type (Comp_Typ)
- and then Has_Discriminants (Comp_Typ)
- and then Is_Variable_Size_Record (Comp_Typ)
- then
- return True;
-
- elsif Is_Array_Type (Comp_Typ)
- and then Is_Variable_Size_Array (Comp_Typ)
- then
- return True;
- end if;
-
- Next_Entity (Comp);
- end loop;
-
- return False;
- end Is_Variable_Size_Record;
-
----------------------------------------
-- Make_Controlling_Function_Wrappers --
----------------------------------------
-- then tags components located at variable positions of Target are
-- initialized.
- function Is_Variable_Size_Record (E : Entity_Id) return Boolean;
- -- Returns true if E has variable size components (move to sem_util???)
-
function Needs_Simple_Initialization
(T : Entity_Id;
Consider_IS : Boolean := True) return Boolean;
-- Ada 2005 (AI-251): Thunks must propagate the extra actuals of
-- accessibility levels.
- if Ekind (Current_Scope) in Subprogram_Kind
- and then Is_Thunk (Current_Scope)
- then
+ if Is_Thunk (Current_Scope) then
declare
Parm_Ent : Entity_Id;
-- the pointer to the object) they are always handled by means of
-- simple return statements.
- pragma Assert (not Is_Subprogram (Current_Scope)
- or else not Is_Thunk (Current_Scope));
+ pragma Assert (not Is_Thunk (Current_Scope));
if Nkind (Ret_Obj_Decl) = N_Object_Declaration then
Exp := Expression (Ret_Obj_Decl);
-- handled by means of simple return statements. This leaves their
-- expansion simple and clean.
- and then not (Is_Subprogram (Current_Scope)
- and then Is_Thunk (Current_Scope))
+ and then not Is_Thunk (Current_Scope)
then
declare
Return_Object_Entity : constant Entity_Id :=
-- the object is returned by reference and the maximum functionality
-- required is just to displace the pointer.
- elsif Is_Subprogram (Current_Scope)
- and then Is_Thunk (Current_Scope)
+ elsif Is_Thunk (Current_Scope)
and then Is_Interface (Exptyp)
then
null;
with Elists; use Elists;
with Errout; use Errout;
with Exp_Atag; use Exp_Atag;
-with Exp_Ch3; use Exp_Ch3;
with Exp_Ch6; use Exp_Ch6;
with Exp_CG; use Exp_CG;
with Exp_Dbug; use Exp_Dbug;
end loop;
Thunk_Id := Make_Temporary (Loc, 'T');
+ Set_Ekind (Thunk_Id, Ekind (Prim));
Set_Is_Thunk (Thunk_Id);
Set_Convention (Thunk_Id, Convention (Prim));
* Conditional Compilation::
* Inline Assembler::
* Compatibility and Porting Guide::
-@ifset unw
* Microsoft Windows Topics::
* Mac OS Topics::
-@end ifset
* GNU Free Documentation License::
* Index::
* Transitioning to 64-Bit GNAT for OpenVMS::
@end ifset
-@ifset unw
Microsoft Windows Topics
@ifclear FSFEDITION
Mac OS Topics
* Codesigning the Debugger::
-@end ifset
* Index::
@end menu
@end ifset
@c ************************************************
-@ifset unw
@node Microsoft Windows Topics
@appendix Microsoft Windows Topics
@cindex Windows NT
name chosen above, and <gnat_install_prefix> should be replaced by
the location where you installed GNAT.
-@end ifset
-
@c **********************************
@c * GNU Free Documentation License *
@c **********************************
Binder_Ali_File : String_Access;
Binder_Obj_File : String_Access;
+ Base_Command_Name : String_Access;
+
Tname : Temp_File_Name;
Tname_FD : File_Descriptor := Invalid_FD;
-- Temporary file used by linker to pass list of object files on
procedure Process_Binder_File (Name : String);
-- Reads the binder file and extracts linker arguments
+ function To_Lower (A : Character) return Character;
+ -- Fold a character to lower case;
+
+ procedure To_Lower (A : in out String);
+ -- Fold a string to lower case;
+
procedure Usage;
-- Display usage
procedure Error_Msg (Message : String) is
begin
- Write_Str (Base_Name (Command_Name));
+ Write_Str (Base_Command_Name.all);
Write_Str (": ");
Write_Str (Message);
Write_Eol;
Status := fclose (Fd);
end Process_Binder_File;
+ --------------
+ -- To_Lower --
+ --------------
+
+ function To_Lower (A : Character) return Character is
+ A_Val : constant Natural := Character'Pos (A);
+
+ begin
+ if A in 'A' .. 'Z'
+ or else A_Val in 16#C0# .. 16#D6#
+ or else A_Val in 16#D8# .. 16#DE#
+ then
+ return Character'Val (A_Val + 16#20#);
+ else
+ return A;
+ end if;
+ end To_Lower;
+
+ procedure To_Lower (A : in out String) is
+ begin
+ for J in A'Range loop
+ A (J) := To_Lower (A (J));
+ end loop;
+ end To_Lower;
+
-----------
-- Usage --
-----------
procedure Usage is
begin
Write_Str ("Usage: ");
- Write_Str (Base_Name (Command_Name));
+ Write_Str (Base_Command_Name.all);
Write_Str (" switches mainprog.ali [non-Ada-objects] [linker-options]");
Write_Eol;
Write_Eol;
end;
end if;
+ Base_Command_Name := new String'(Base_Name (Command_Name));
+
+ -- Fold to lower case "GNATLINK" on VMS to be consistent with output
+ -- from other GNAT utilities.
+
+ if Hostparm.OpenVMS then
+ To_Lower (Base_Command_Name.all);
+ end if;
+
Process_Args;
if Argument_Count = 0
-- Assume this is a cross tool if the executable name is not gnatlink
- if Base_Name (Command_Name) = "gnatlink"
+ if Base_Command_Name.all = "gnatlink"
and then Output_File_Name.all = "test"
then
Error_Msg ("warning: executable name """ & Output_File_Name.all
end Inherit_Components;
-----------------------
- -- Is_Constant_Bound --
- -----------------------
-
- function Is_Constant_Bound (Exp : Node_Id) return Boolean is
- begin
- if Compile_Time_Known_Value (Exp) then
- return True;
-
- elsif Is_Entity_Name (Exp)
- and then Present (Entity (Exp))
- then
- return Is_Constant_Object (Entity (Exp))
- or else Ekind (Entity (Exp)) = E_Enumeration_Literal;
-
- elsif Nkind (Exp) in N_Binary_Op then
- return Is_Constant_Bound (Left_Opnd (Exp))
- and then Is_Constant_Bound (Right_Opnd (Exp))
- and then Scope (Entity (Exp)) = Standard_Standard;
-
- else
- return False;
- end if;
- end Is_Constant_Bound;
-
- -----------------------
-- Is_Null_Extension --
-----------------------
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2013, 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- --
-- Given a discriminant somewhere in the Typ_For_Constraint tree and a
-- Constraint, return the value of that discriminant.
- function Is_Constant_Bound (Exp : Node_Id) return Boolean;
- -- Exp is the expression for an array bound. Determines whether the
- -- bound is a compile-time known value, or a constant entity, or an
- -- enumeration literal, or an expression composed of constant-bound
- -- subexpressions which are evaluated by means of standard operators.
-
function Is_Null_Extension (T : Entity_Id) return Boolean;
-- Returns True if the tagged type T has an N_Full_Type_Declaration that
-- is a null extension, meaning that it has an extension part without any
or else Is_Task_Interface (T));
end Is_Concurrent_Interface;
+ -----------------------
+ -- Is_Constant_Bound --
+ -----------------------
+
+ function Is_Constant_Bound (Exp : Node_Id) return Boolean is
+ begin
+ if Compile_Time_Known_Value (Exp) then
+ return True;
+
+ elsif Is_Entity_Name (Exp)
+ and then Present (Entity (Exp))
+ then
+ return Is_Constant_Object (Entity (Exp))
+ or else Ekind (Entity (Exp)) = E_Enumeration_Literal;
+
+ elsif Nkind (Exp) in N_Binary_Op then
+ return Is_Constant_Bound (Left_Opnd (Exp))
+ and then Is_Constant_Bound (Right_Opnd (Exp))
+ and then Scope (Entity (Exp)) = Standard_Standard;
+
+ else
+ return False;
+ end if;
+ end Is_Constant_Bound;
+
--------------------------------------
-- Is_Controlling_Limited_Procedure --
--------------------------------------
and then Get_Name_String (Chars (T)) = "valuetype";
end Is_Value_Type;
+ ----------------------------
+ -- Is_Variable_Size_Array --
+ ----------------------------
+
+ function Is_Variable_Size_Array (E : Entity_Id) return Boolean is
+ Idx : Node_Id;
+
+ begin
+ pragma Assert (Is_Array_Type (E));
+
+ -- Check if some index is initialized with a non-constant value
+
+ Idx := First_Index (E);
+ while Present (Idx) loop
+ if Nkind (Idx) = N_Range then
+ if not Is_Constant_Bound (Low_Bound (Idx))
+ or else not Is_Constant_Bound (High_Bound (Idx))
+ then
+ return True;
+ end if;
+ end if;
+
+ Idx := Next_Index (Idx);
+ end loop;
+
+ return False;
+ end Is_Variable_Size_Array;
+
+ -----------------------------
+ -- Is_Variable_Size_Record --
+ -----------------------------
+
+ function Is_Variable_Size_Record (E : Entity_Id) return Boolean is
+ Comp : Entity_Id;
+ Comp_Typ : Entity_Id;
+
+ begin
+ pragma Assert (Is_Record_Type (E));
+
+ Comp := First_Entity (E);
+ while Present (Comp) loop
+ Comp_Typ := Etype (Comp);
+
+ -- Recursive call if the record type has discriminants
+
+ if Is_Record_Type (Comp_Typ)
+ and then Has_Discriminants (Comp_Typ)
+ and then Is_Variable_Size_Record (Comp_Typ)
+ then
+ return True;
+
+ elsif Is_Array_Type (Comp_Typ)
+ and then Is_Variable_Size_Array (Comp_Typ)
+ then
+ return True;
+ end if;
+
+ Next_Entity (Comp);
+ end loop;
+
+ return False;
+ end Is_Variable_Size_Record;
+
---------------------
-- Is_VMS_Operator --
---------------------
-- True if T is a bounded string type. Used to make sure "=" composes
-- properly for bounded string types.
+ function Is_Constant_Bound (Exp : Node_Id) return Boolean;
+ -- Exp is the expression for an array bound. Determines whether the
+ -- bound is a compile-time known value, or a constant entity, or an
+ -- enumeration literal, or an expression composed of constant-bound
+ -- subexpressions which are evaluated by means of standard operators.
+
function Is_Controlling_Limited_Procedure
(Proc_Nam : Entity_Id) return Boolean;
-- Ada 2005 (AI-345): Determine whether Proc_Nam is a primitive procedure
-- object that is accessed directly, as opposed to the other CIL objects
-- that are accessed through managed pointers.
+ function Is_Variable_Size_Array (E : Entity_Id) return Boolean;
+ -- Returns true if E has variable size components
+
+ function Is_Variable_Size_Record (E : Entity_Id) return Boolean;
+ -- Returns true if E has variable size components
+
function Is_VMS_Operator (Op : Entity_Id) return Boolean;
-- Determine whether an operator is one of the intrinsics defined
-- in the DEC system extension.
(Input : Input_File;
At_Character : Natural;
Message : String);
- procedure Warning
- (Input : Input_File;
- Message : String);
- -- Like Error, but just print a warning message
Dictionary_File : aliased Input_File;
procedure Read_Dictionary_File;
-- Conditional commands for edition are passed through unchanged
subtype Target_Type is Flag_Type range UNW .. VMS;
- subtype Edition_Type is Flag_Type range FSFEDITION .. GPLEDITION;
Target : Target_Type;
-- The Target variable is initialized using the command line
-- This subprogram takes a line and rewrites it according to Target.
-- It relies on information in Source_File to generate error messages.
- type Conditional is (Set, Clear);
- procedure Push_Conditional (Cond : Conditional; Flag : Flag_Type);
- procedure Pop_Conditional (Cond : Conditional);
- -- These subprograms deal with conditional processing (@ifset/@ifclear).
- -- They rely on information in Source_File to generate error messages.
-
- function VMS_Context_Determined return Boolean;
- -- Returns true if, in the current conditional preprocessing context, we
- -- always have a VMS or a non-VMS version, regardless of the value of
- -- Target.
-
- function In_VMS_Section return Boolean;
- -- Returns True if in an "@ifset vms" section
-
- procedure Check_No_Pending_Conditional;
- -- Checks that all preprocessing directives have been properly matched by
- -- their @end counterpart. If this is not the case, print an error
- -- message.
-
- -- The following definitions implement a stack to track the conditional
- -- preprocessing context.
-
- type Conditional_Context is record
- Starting_Line : Positive;
- Cond : Conditional;
- Flag : Flag_Type;
- end record;
-
- Conditional_Stack_Depth : constant := 3;
-
- Conditional_Stack :
- array (1 .. Conditional_Stack_Depth) of Conditional_Context;
-
- Conditional_TOS : Natural := 0;
- -- Pointer to the Top Of Stack for Conditional_Stack
-
-----------
-- Usage --
-----------
-------------
procedure Warning
- (Input : Input_File;
- Message : String)
- is
- begin
- if Warnings_Enabled then
- Warning (Input, 0, Message);
- end if;
- end Warning;
-
- procedure Warning
(Input : Input_File;
At_Character : Natural;
Message : String)
Maybe_Rewrite_Extension;
when VMS_Alternative =>
- if VMS_Context_Determined then
- if (not In_VMS_Section)
- or else
- Line (Token.VMS.First .. Token.VMS.Last) /=
- Line (Token.Non_VMS.First .. Token.Non_VMS.Last)
- then
- Warning (Source_File, Token.First,
- "VMS alternative already determined "
- & "by conditionals");
- end if;
- end if;
if Target = VMS then
Append (Rewritten_Line, Line (Token.VMS.First
.. Token.VMS.Last));
-------------------------
procedure Process_Source_File is
- Ifset : constant String := "@ifset ";
- Ifclear : constant String := "@ifclear ";
- Endsetclear : constant String := "@end ";
- -- Strings to be recognized for conditional processing
-
begin
while not End_Of_File (Source_File.Data) loop
declare
-- syntax of all lines, and not only those which are actually
-- included in the output.
- Have_Conditional : Boolean := False;
- -- True if we have encountered a conditional preprocessing
- -- directive.
-
- Cond : Conditional;
- -- The kind of the directive
-
- Flag : Flag_Type;
- -- Its flag
-
begin
- -- If the line starts with @ifset or @ifclear, we try to convert
- -- the following flag to one of our flag types. If we fail,
- -- Have_Conditional remains False.
-
- if Line'Length >= Ifset'Length
- and then Line (1 .. Ifset'Length) = Ifset
- then
- Cond := Set;
-
- declare
- Arg : constant String :=
- Trim (Line (Ifset'Length + 1 .. Line'Last), Both);
-
- begin
- Flag := Flag_Type'Value (Arg);
- Have_Conditional := True;
-
- case Flag is
- when Target_Type =>
- if Translate (Target_Type'Image (Flag),
- Lower_Case_Map)
- /= Arg
- then
- Error (Source_File, "flag has to be lowercase");
- end if;
-
- -- Set unw/vms flag in the output file so that
- -- @ifset/@ifclear will work as expected.
-
- if First_Time then
- Put_Line (Output_File, "@set " & Argument (1));
- First_Time := False;
- end if;
-
- when Edition_Type =>
- null;
- end case;
- exception
- when Constraint_Error =>
- Error (Source_File, "unknown flag for '@ifset'");
- end;
-
- elsif Line'Length >= Ifclear'Length
- and then Line (1 .. Ifclear'Length) = Ifclear
+ if First_Time
+ and then Line'Length > 3 and then Line (1 .. 3) = "@if"
then
- Cond := Clear;
-
- declare
- Arg : constant String :=
- Trim (Line (Ifclear'Length + 1 .. Line'Last), Both);
-
- begin
- Flag := Flag_Type'Value (Arg);
- Have_Conditional := True;
-
- case Flag is
- when Target_Type =>
- if Translate (Target_Type'Image (Flag),
- Lower_Case_Map)
- /= Arg
- then
- Error (Source_File, "flag has to be lowercase");
- end if;
-
- -- Set unw/vms flag in the output file so that
- -- @ifset/@ifclear will work as expected.
-
- if First_Time then
- Put_Line (Output_File, "@set " & Argument (1));
- First_Time := False;
- end if;
-
- when Edition_Type =>
- null;
- end case;
- exception
- when Constraint_Error =>
- Error (Source_File, "unknown flag for '@ifclear'");
- end;
+ Put_Line (Output_File, "@set " & Argument (1));
+ First_Time := False;
end if;
- if Have_Conditional then
- -- We create a new conditional context and suppress the
- -- directive in the output.
-
- Push_Conditional (Cond, Flag);
-
- elsif Line'Length >= Endsetclear'Length
- and then Line (1 .. Endsetclear'Length) = Endsetclear
- then
- -- The '@end ifset'/'@end ifclear' case is handled here. We
- -- have to pop the conditional context.
-
- declare
- First, Last : Natural;
-
- begin
- Find_Token (Source => Line (Endsetclear'Length + 1
- .. Line'Length),
- Set => Letter_Set,
- Test => Inside,
- First => First,
- Last => Last);
-
- if Last = 0 then
- Error (Source_File, "'@end' without argument");
- else
- if Line (First .. Last) = "ifset" then
- Have_Conditional := True;
- Cond := Set;
- elsif Line (First .. Last) = "ifclear" then
- Have_Conditional := True;
- Cond := Clear;
- end if;
-
- if Have_Conditional then
- Pop_Conditional (Cond);
-
- if Conditional_TOS > 0 then
- Flag := Conditional_Stack (Conditional_TOS).Flag;
- end if;
- end if;
-
- -- We fall through to the ordinary case for other @end
- -- directives.
-
- end if; -- @end without argument
- end;
- end if; -- Have_Conditional
-
Put_Line (Output_File, Rewritten);
end;
end loop;
-
- Check_No_Pending_Conditional;
end Process_Source_File;
---------------------------
return S (Get (Ug_Words, Word));
end Get_Replacement_Word;
- ----------------------
- -- Push_Conditional --
- ----------------------
-
- procedure Push_Conditional (Cond : Conditional; Flag : Flag_Type) is
- begin
- if Flag in Target_Type then
-
- -- Check if the current directive is pointless because of a previous,
- -- enclosing directive.
-
- for J in 1 .. Conditional_TOS loop
- if Conditional_Stack (J).Flag = Flag then
- Warning
- (Source_File, "directive without effect because of line"
- & Integer'Image (Conditional_Stack (J).Starting_Line));
- end if;
- end loop;
- end if;
-
- Conditional_TOS := Conditional_TOS + 1;
- Conditional_Stack (Conditional_TOS) :=
- (Starting_Line => Source_File.Line,
- Cond => Cond,
- Flag => Flag);
- end Push_Conditional;
-
- ---------------------
- -- Pop_Conditional --
- ---------------------
-
- procedure Pop_Conditional (Cond : Conditional) is
- begin
- if Conditional_TOS > 0 then
- case Cond is
- when Set =>
- if Conditional_Stack (Conditional_TOS).Cond /= Set then
- Error (Source_File,
- "'@end ifset' does not match '@ifclear' at line"
- & Integer'Image (Conditional_Stack
- (Conditional_TOS).Starting_Line));
- end if;
-
- when Clear =>
- if Conditional_Stack (Conditional_TOS).Cond /= Clear then
- Error (Source_File,
- "'@end ifclear' does not match '@ifset' at line"
- & Integer'Image (Conditional_Stack
- (Conditional_TOS).Starting_Line));
- end if;
- end case;
-
- Conditional_TOS := Conditional_TOS - 1;
-
- else
- case Cond is
- when Set =>
- Error (Source_File,
- "'@end ifset' without corresponding '@ifset'");
-
- when Clear =>
- Error (Source_File,
- "'@end ifclear' without corresponding '@ifclear'");
- end case;
- end if;
- end Pop_Conditional;
-
- ----------------------------
- -- VMS_Context_Determined --
- ----------------------------
-
- function VMS_Context_Determined return Boolean is
- begin
- for J in 1 .. Conditional_TOS loop
- if Conditional_Stack (J).Flag = VMS then
- return True;
- end if;
- end loop;
-
- return False;
- end VMS_Context_Determined;
-
- --------------------
- -- In_VMS_Section --
- --------------------
-
- function In_VMS_Section return Boolean is
- begin
- for J in 1 .. Conditional_TOS loop
- if Conditional_Stack (J).Flag = VMS then
- return Conditional_Stack (J).Cond = Set;
- end if;
- end loop;
-
- return False;
- end In_VMS_Section;
-
- ----------------------------------
- -- Check_No_Pending_Conditional --
- ----------------------------------
-
- procedure Check_No_Pending_Conditional is
- begin
- for J in 1 .. Conditional_TOS loop
- case Conditional_Stack (J).Cond is
- when Set =>
- Error (Source_File, "Missing '@end ifset' for '@ifset' at line"
- & Integer'Image (Conditional_Stack (J).Starting_Line));
-
- when Clear =>
- Error (Source_File,
- "Missing '@end ifclear' for '@ifclear' at line"
- & Integer'Image (Conditional_Stack (J).Starting_Line));
- end case;
- end loop;
- end Check_No_Pending_Conditional;
-
-- Start of processing for Xgnatugn
Valid_Command_Line : Boolean;
projects / platform / upstream / gcc.git / commitdiff