This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
committed: Ada updates
- From: Arnaud Charlet <charlet at ACT-Europe dot FR>
- To: gcc-patches at gcc dot gnu dot org
- Date: Fri, 14 Nov 2003 11:37:00 +0100
- Subject: committed: Ada updates
Various clean ups.
Implementation of -gnatS compiler switch to replace gnatpsta
Implementation of new Ada construct (limited aggregates)
run time clean ups and improvements.
error handling improvements and fixes.
Tested on x86-linux
--
2003-11-13 Vincent Celier <celier@gnat.com>
* 5bml-tgt.adb (Build_Dynamic_Library): Use
Osint.Include_Dir_Default_Prefix instead of
Sdefault.Include_Dir_Default_Name.
* gnatlbr.adb: Update Copyright notice
(Gnatlbr): : Use Osint.Include_Dir_Default_Prefix instead of
Sdefault.Include_Dir_Default_Name and Osint.Object_Dir_Default_Prefix
instead of Sdefault.Object_Dir_Default_Name
* gnatlink.adb:
(Process_Binder_File): Never suppress the option following -Xlinker
* mdll-utl.adb:
(Gcc): Use Osint.Object_Dir_Default_Prefix instead of
Sdefault.Object_Dir_Default_Name.
* osint.ads, osint.adb:
(Include_Dir_Default_Prefix, Object_Dir_Default_Prefix): New functions
Minor reformatting.
* vms_conv.ads: Minor reformating
Remove GNAT STANDARD and GNAT PSTA
* vms_conv.adb:
Allow GNAT MAKE to have several files on the command line.
(Init_Object_Dirs): Use Osint.Object_Dir_Default_Prefix instead of
Sdefault.Object_Dir_Default_Name.
Minor Reformating
Remove data for GNAT STANDARD
* vms_data.ads:
Add new compiler qualifier /PRINT_STANDARD (-gnatS)
Remove data for GNAT STANDARD
Remove options and documentation for -gnatwb/-gnatwB: these warning
options no longer exist.
2003-11-13 Ed Falis <falis@gnat.com>
* 5zthrini.adb: (Init_RTS): Made visible
* 5zthrini.adb:
(Register): Removed unnecessary call to taskVarGet that checked whether
an ATSD was already set as a task var for the argument thread.
* s-thread.adb:
Updated comment to reflect that this is a VxWorks version
Added context clause for System.Threads.Initialization
Added call to System.Threads.Initialization.Init_RTS
2003-11-13 Jerome Guitton <guitton@act-europe.fr>
* 5zthrini.adb:
(Init_RTS): New procedure, for the initialization of the run-time lib.
* s-thread.adb:
Remove dependancy on System.Init, so that this file can be used in the
AE653 sequential run-time lib.
2003-11-13 Robert Dewar <dewar@gnat.com>
* bindgen.adb: Minor reformatting
2003-11-13 Ed Schonberg <schonberg@gnat.com>
* checks.adb:
(Apply_Discriminant_Check): Do no apply check if target type is derived
from source type with no applicable constraint.
* lib-writ.adb:
(Ensure_System_Dependency): Do not apply the style checks that may have
been specified for the main unit.
* sem_ch8.adb:
(Find_Selected_Component): Further improvement in error message, with
RM reference.
* sem_res.adb:
(Resolve): Handle properly the case of an illegal overloaded protected
procedure.
2003-11-13 Javier Miranda <miranda@gnat.com>
* exp_aggr.adb:
(Has_Default_Init_Comps): New function to check the presence of
default initialization in an aggregate.
(Build_Record_Aggr_Code): Recursively expand the ancestor in case of
extension aggregate of a limited record. In addition, a new formal
was added to do not initialize the record controller (if any) during
this recursive expansion of ancestors.
(Init_Controller): Add support for limited record components.
(Expand_Record_Aggregate): In case of default initialized components
convert the aggregate into a set of assignments.
* par-ch4.adb (P_Aggregate_Or_Paren_Expr): Update the comment
describing the new syntax.
Nothing else needed to be done because this subprogram delegates part of
its work to P_Precord_Or_Array_Component_Association.
(P_Record_Or_Array_Component_Association): Give support to the new
syntax for default initialization of components.
* sem_aggr.adb:
(Resolve_Aggregate): Relax the strictness of the frontend in case of
limited aggregates.
(Resolve_Record_Aggregate): Give support to default initialized
components.
(Get_Value): In case of default initialized components, duplicate
the corresponding default expression (from the record type
declaration). In case of default initialization in the *others*
choice, do not check that all components have the same type.
(Resolve_Extension_Aggregate): Give support to limited extension
aggregates.
* sem_ch3.adb:
(Check_Initialization): Relax the strictness of the front-end in case
of aggregate and extension aggregates. This test is now done in
Get_Value in a per-component manner.
* sem_ch4.adb (Analyze_Allocator): Don't post an error if the
expression corresponds to a limited aggregate. This test is now done
in Get_Value.
* sinfo.ads, sinfo.adb (N_Component_Association): Addition of
Box_Present flag.
* sprint.adb (Sprint_Node_Actual): Modified to print an mbox if
present in an N_Component_Association node
2003-11-13 Thomas Quinot <quinot@act-europe.fr>
* sem_ch9.adb (Analyze_Accept_Statement): A procedure hides a
type-conformant entry only if they are homographs.
2003-11-13 GNAT Script <nobody@gnat.com>
* Make-lang.in: Makefile automatically updated
--
Index: 5bml-tgt.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/5bml-tgt.adb,v
retrieving revision 1.1
diff -u -r1.1 5bml-tgt.adb
--- 5bml-tgt.adb 21 Oct 2003 13:41:51 -0000 1.1
+++ 5bml-tgt.adb 13 Nov 2003 22:38:20 -0000
@@ -35,10 +35,10 @@
with MLib.Fil;
with MLib.Utl;
with Namet; use Namet;
+with Osint; use Osint;
with Opt;
with Output; use Output;
with Prj.Com;
-with Sdefault;
package body MLib.Tgt is
@@ -175,9 +175,9 @@
Last : Natural;
begin
- Open (File, In_File,
- Sdefault.Include_Dir_Default_Name.all &
- "/s-osinte.ads");
+ Open
+ (File, In_File,
+ Include_Dir_Default_Prefix & "/s-osinte.ads");
while not End_Of_File (File) loop
Get_Line (File, Line, Last);
Index: 5zthrini.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/5zthrini.adb,v
retrieving revision 1.2
diff -u -r1.2 5zthrini.adb
--- 5zthrini.adb 10 Nov 2003 17:29:58 -0000 1.2
+++ 5zthrini.adb 13 Nov 2003 22:38:20 -0000
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2003 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- --
@@ -36,8 +36,8 @@
with System.Secondary_Stack;
with System.Storage_Elements;
+with System.Soft_Links;
with Interfaces.C;
-with Unchecked_Conversion;
package body System.Threads.Initialization is
@@ -45,6 +45,8 @@
package SSS renames System.Secondary_Stack;
+ package SSL renames System.Soft_Links;
+
procedure Initialize_Task_Hooks;
-- Register the appropriate hooks (Register and Reset_TSD) to the
-- underlying OS, so that they will be called when a task is created
@@ -61,6 +63,19 @@
-- Separate, as these hooks are different for AE653 and VxWorks 5.5.
--------------
+ -- Init_RTS --
+ --------------
+
+ procedure Init_RTS is
+ begin
+ SSL.Get_Jmpbuf_Address := Get_Jmpbuf_Address'Access;
+ SSL.Get_Sec_Stack_Addr := Get_Sec_Stack_Addr'Access;
+ SSL.Get_Current_Excep := Get_Current_Excep'Access;
+ SSL.Set_Jmpbuf_Address := Set_Jmpbuf_Address'Access;
+ SSL.Set_Sec_Stack_Addr := Set_Sec_Stack_Addr'Access;
+ end Init_RTS;
+
+ --------------
-- Register --
--------------
@@ -76,9 +91,7 @@
-- (depending on configRecord.c, allocation could be disabled).
-- Otherwise, everything could have been done in Thread_Body_Enter.
- if OSI.taskIdVerify (T) = OSI.ERROR
- or else OSI.taskVarGet (T, Current_ATSD'Access) /= OSI.ERROR
- then
+ if OSI.taskIdVerify (T) = OSI.ERROR then
return OSI.ERROR;
end if;
@@ -102,6 +115,7 @@
begin
Initialize_Task_Hooks;
+ Init_RTS;
-- Register the environment task
declare
Index: bindgen.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/bindgen.adb,v
retrieving revision 1.15
diff -u -r1.15 bindgen.adb
--- bindgen.adb 10 Nov 2003 17:29:58 -0000 1.15
+++ bindgen.adb 13 Nov 2003 22:38:21 -0000
@@ -1895,6 +1895,7 @@
procedure Gen_Output_File (Filename : String) is
Is_Public_Version : constant Boolean := Get_Gnat_Build_Type = Public;
+
begin
-- Acquire settings for Interrupt_State pragmas
Index: checks.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/checks.adb,v
retrieving revision 1.12
diff -u -r1.12 checks.adb
--- checks.adb 21 Oct 2003 13:41:58 -0000 1.12
+++ checks.adb 13 Nov 2003 22:38:21 -0000
@@ -1183,6 +1183,26 @@
if No (DconS) then
return;
end if;
+
+ -- A further optimization: if T_Typ is derived from S_Typ
+ -- without imposing a constraint, no check is needed.
+
+ if Nkind (Original_Node (Parent (T_Typ))) =
+ N_Full_Type_Declaration
+ then
+ declare
+ Type_Def : Node_Id :=
+ Type_Definition
+ (Original_Node (Parent (T_Typ)));
+ begin
+ if Nkind (Type_Def) = N_Derived_Type_Definition
+ and then Is_Entity_Name (Subtype_Indication (Type_Def))
+ and then Entity (Subtype_Indication (Type_Def)) = S_Typ
+ then
+ return;
+ end if;
+ end;
+ end if;
end if;
DconT := First_Elmt (Discriminant_Constraint (T_Typ));
Index: exp_aggr.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_aggr.adb,v
retrieving revision 1.7
diff -u -r1.7 exp_aggr.adb
--- exp_aggr.adb 21 Oct 2003 13:41:59 -0000 1.7
+++ exp_aggr.adb 13 Nov 2003 22:38:21 -0000
@@ -70,6 +70,10 @@
-- statement of variant part will usually be small and probably in near
-- sorted order.
+ function Has_Default_Init_Comps (N : Node_Id) return Boolean;
+ -- N is an aggregate (record or array). Checks the presence of
+ -- default initialization (<>) in any component.
+
------------------------------------------------------
-- Local subprograms for Record Aggregate Expansion --
------------------------------------------------------
@@ -97,12 +101,13 @@
-- assignments component per component.
function Build_Record_Aggr_Code
- (N : Node_Id;
- Typ : Entity_Id;
- Target : Node_Id;
- Flist : Node_Id := Empty;
- Obj : Entity_Id := Empty)
- return List_Id;
+ (N : Node_Id;
+ Typ : Entity_Id;
+ Target : Node_Id;
+ Flist : Node_Id := Empty;
+ Obj : Entity_Id := Empty;
+ Is_Limited_Ancestor_Expansion : Boolean := False)
+ return List_Id;
-- N is an N_Aggregate or a N_Extension_Aggregate. Typ is the type
-- of the aggregate. Target is an expression containing the
-- location on which the component by component assignments will
@@ -113,6 +118,8 @@
-- object declaration and dynamic allocation cases, it contains
-- an entity that allows to know if the value being created needs to be
-- attached to the final list in case of pragma finalize_Storage_Only.
+ -- Is_Limited_Ancestor_Expansion indicates that the function has been
+ -- called recursively to expand the limited ancestor to avoid copying it.
function Has_Mutable_Components (Typ : Entity_Id) return Boolean;
-- Return true if one of the component is of a discriminated type with
@@ -1269,12 +1276,13 @@
----------------------------
function Build_Record_Aggr_Code
- (N : Node_Id;
- Typ : Entity_Id;
- Target : Node_Id;
- Flist : Node_Id := Empty;
- Obj : Entity_Id := Empty)
- return List_Id
+ (N : Node_Id;
+ Typ : Entity_Id;
+ Target : Node_Id;
+ Flist : Node_Id := Empty;
+ Obj : Entity_Id := Empty;
+ Is_Limited_Ancestor_Expansion : Boolean := False)
+ return List_Id
is
Loc : constant Source_Ptr := Sloc (N);
L : constant List_Id := New_List;
@@ -1540,20 +1548,50 @@
Selector_Name => Make_Identifier (Loc, Name_uController));
Set_Assignment_OK (Ref);
- if Init_Pr then
- Append_List_To (L,
- Build_Initialization_Call (Loc,
- Id_Ref => Ref,
- Typ => RTE (RE_Record_Controller),
- In_Init_Proc => Within_Init_Proc));
- end if;
+ -- Give support to default initialization of limited types and
+ -- components
- Append_To (L,
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Reference_To (Find_Prim_Op (RTE (RE_Record_Controller),
- Name_Initialize), Loc),
- Parameter_Associations => New_List (New_Copy_Tree (Ref))));
+ if (Nkind (Target) = N_Identifier
+ and then Is_Limited_Type (Etype (Target)))
+ or else (Nkind (Target) = N_Selected_Component
+ and then Is_Limited_Type (Etype (Selector_Name (Target))))
+ or else (Nkind (Target) = N_Unchecked_Type_Conversion
+ and then Is_Limited_Type (Etype (Target)))
+ then
+
+ if Init_Pr then
+ Append_List_To (L,
+ Build_Initialization_Call (Loc,
+ Id_Ref => Ref,
+ Typ => RTE (RE_Limited_Record_Controller),
+ In_Init_Proc => Within_Init_Proc));
+ end if;
+
+ Append_To (L,
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Reference_To
+ (Find_Prim_Op (RTE (RE_Limited_Record_Controller),
+ Name_Initialize), Loc),
+ Parameter_Associations => New_List (New_Copy_Tree (Ref))));
+
+ else
+ if Init_Pr then
+ Append_List_To (L,
+ Build_Initialization_Call (Loc,
+ Id_Ref => Ref,
+ Typ => RTE (RE_Record_Controller),
+ In_Init_Proc => Within_Init_Proc));
+ end if;
+
+ Append_To (L,
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Reference_To (Find_Prim_Op (RTE (RE_Record_Controller),
+ Name_Initialize), Loc),
+ Parameter_Associations => New_List (New_Copy_Tree (Ref))));
+
+ end if;
Append_To (L,
Make_Attach_Call (
@@ -1648,6 +1686,21 @@
Check_Ancestor_Discriminants (Entity (A));
end if;
+ -- If the ancestor part is a limited type, a recursive call
+ -- expands the ancestor.
+
+ elsif Is_Limited_Type (Etype (A)) then
+ Ancestor_Is_Expression := True;
+
+ Append_List_To (Start_L,
+ Build_Record_Aggr_Code (
+ N => Expression (A),
+ Typ => Etype (Expression (A)),
+ Target => Target,
+ Flist => Flist,
+ Obj => Obj,
+ Is_Limited_Ancestor_Expansion => True));
+
-- If the ancestor part is an expression "E", we generate
-- T(tmp) := E;
@@ -1767,6 +1820,22 @@
while Present (Comp) loop
Selector := Entity (First (Choices (Comp)));
+ -- Default initialization of a limited component
+
+ if Box_Present (Comp)
+ and then Is_Limited_Type (Etype (Selector))
+ then
+ Append_List_To (L,
+ Build_Initialization_Call (Loc,
+ Id_Ref => Make_Selected_Component (Loc,
+ Prefix => New_Copy_Tree (Target),
+ Selector_Name => New_Occurrence_Of (Selector,
+ Loc)),
+ Typ => Etype (Selector)));
+
+ goto Next_Comp;
+ end if;
+
-- ???
if Ekind (Selector) /= E_Discriminant
@@ -1900,6 +1969,8 @@
end;
end if;
+ <<Next_Comp>>
+
Next (Comp);
end loop;
@@ -1997,7 +2068,9 @@
-- In the Has_Controlled component case, all the intermediate
-- controllers must be initialized
- if Has_Controlled_Component (Typ) then
+ if Has_Controlled_Component (Typ)
+ and not Is_Limited_Ancestor_Expansion
+ then
declare
Inner_Typ : Entity_Id;
Outer_Typ : Entity_Id;
@@ -4082,6 +4155,9 @@
then
Convert_To_Assignments (N, Typ);
+ elsif Has_Default_Init_Comps (N) then
+ Convert_To_Assignments (N, Typ);
+
elsif Has_Delayed_Nested_Aggregate_Or_Tagged_Comps then
Convert_To_Assignments (N, Typ);
@@ -4401,6 +4477,31 @@
end if;
end if;
end Expand_Record_Aggregate;
+
+ ----------------------------
+ -- Has_Default_Init_Comps --
+ ----------------------------
+
+ function Has_Default_Init_Comps (N : Node_Id) return Boolean is
+ Comps : constant List_Id := Component_Associations (N);
+ C : Node_Id;
+ begin
+ pragma Assert (Nkind (N) = N_Aggregate
+ or else Nkind (N) = N_Extension_Aggregate);
+ if No (Comps) then
+ return False;
+ end if;
+
+ C := First (Comps);
+ while Present (C) loop
+ if Box_Present (C) then
+ return True;
+ end if;
+
+ Next (C);
+ end loop;
+ return False;
+ end Has_Default_Init_Comps;
--------------------------
-- Is_Delayed_Aggregate --
Index: gnatlbr.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/gnatlbr.adb,v
retrieving revision 1.7
diff -u -r1.7 gnatlbr.adb
--- gnatlbr.adb 21 Oct 2003 13:42:08 -0000 1.7
+++ gnatlbr.adb 13 Nov 2003 22:38:21 -0000
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1997-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1997-2003 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- --
@@ -47,7 +47,6 @@
with Gnatvsn; use Gnatvsn;
with Interfaces.C_Streams; use Interfaces.C_Streams;
with Osint; use Osint;
-with Sdefault; use Sdefault;
with System;
procedure GnatLbr is
@@ -192,7 +191,7 @@
-- there are two.
--
Include_Dirs := 0;
- Include_Dir_Name := String_Access (Include_Dir_Default_Name);
+ Include_Dir_Name := new String'(Include_Dir_Default_Prefix);
Get_Next_Dir_In_Path_Init (String_Access (Include_Dir_Name));
loop
@@ -208,7 +207,7 @@
end loop;
Object_Dirs := 0;
- Object_Dir_Name := String_Access (Object_Dir_Default_Name);
+ Object_Dir_Name := new String'(Object_Dir_Default_Prefix);
Get_Next_Dir_In_Path_Init (String_Access (Object_Dir_Name));
loop
Index: gnatlink.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/gnatlink.adb,v
retrieving revision 1.9
diff -u -r1.9 gnatlink.adb
--- gnatlink.adb 24 Oct 2003 14:39:55 -0000 1.9
+++ gnatlink.adb 13 Nov 2003 22:38:21 -0000
@@ -619,6 +619,10 @@
GNAT_Shared : Boolean := False;
-- Save state of -shared option.
+ Xlinker_Was_Previous : Boolean := False;
+ -- Indicate that "-Xlinker" was the option preceding the current
+ -- option. If True, then the current option is never suppressed.
+
-- Rollback data
-- These data items are used to store current binder file context.
@@ -936,8 +940,17 @@
-- Process switches and options
if Next_Line (Nfirst .. Nlast) /= End_Info then
+ Xlinker_Was_Previous := False;
+
loop
- if Next_Line (Nfirst .. Nlast) = "-static" then
+ if Xlinker_Was_Previous
+ or else Next_Line (Nfirst .. Nlast) = "-Xlinker"
+ then
+ Linker_Options.Increment_Last;
+ Linker_Options.Table (Linker_Options.Last) :=
+ new String'(Next_Line (Nfirst .. Nlast));
+
+ elsif Next_Line (Nfirst .. Nlast) = "-static" then
GNAT_Static := True;
elsif Next_Line (Nfirst .. Nlast) = "-shared" then
@@ -946,9 +959,7 @@
-- Add binder options only if not already set on the command
-- line. This rule is a way to control the linker options order.
- elsif not Is_Option_Present (Next_Line (Nfirst .. Nlast))
- or else Next_Line (Nfirst .. Nlast) = "-Xlinker"
- then
+ elsif not Is_Option_Present (Next_Line (Nfirst .. Nlast)) then
if Nlast > Nfirst + 2 and then
Next_Line (Nfirst .. Nfirst + 1) = "-L"
then
@@ -1124,6 +1135,8 @@
new String'(Next_Line (Nfirst .. Nlast));
end if;
end if;
+
+ Xlinker_Was_Previous := Next_Line (Nfirst .. Nlast) = "-Xlinker";
Get_Next_Line;
exit when Next_Line (Nfirst .. Nlast) = End_Info;
Index: lib-writ.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/lib-writ.adb,v
retrieving revision 1.8
diff -u -r1.8 lib-writ.adb
--- lib-writ.adb 30 Oct 2003 11:50:12 -0000 1.8
+++ lib-writ.adb 13 Nov 2003 22:38:21 -0000
@@ -91,6 +91,8 @@
System_Fname : File_Name_Type;
-- File name for system spec if needed for dummy entry
+ Save_Style : constant Boolean := Style_Check;
+
begin
-- Nothing to do if we already compiled System
@@ -133,9 +135,12 @@
Error_Location => No_Location);
-- Parse system.ads so that the checksum is set right
+ -- Style checks are not applied.
+ Style_Check := False;
Initialize_Scanner (Units.Last, System_Source_File_Index);
Discard_List (Par (Configuration_Pragmas => False));
+ Style_Check := Save_Style;
end Ensure_System_Dependency;
---------------
Index: mdll-utl.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/mdll-utl.adb,v
retrieving revision 1.4
diff -u -r1.4 mdll-utl.adb
--- mdll-utl.adb 21 Oct 2003 13:42:09 -0000 1.4
+++ mdll-utl.adb 13 Nov 2003 22:38:21 -0000
@@ -30,7 +30,7 @@
with Ada.Exceptions;
with GNAT.Directory_Operations;
-with Sdefault;
+with Osint;
package body MDLL.Utl is
@@ -155,7 +155,7 @@
Base_File : String := "";
Build_Lib : Boolean := False)
is
- use Sdefault;
+ use Osint;
Arguments : OS_Lib.Argument_List
(1 .. 5 + Files'Length + Options'Length);
@@ -167,7 +167,7 @@
Out_V : aliased String := Output_File;
Bas_Opt : aliased String := "-Wl,--base-file," & Base_File;
Lib_Opt : aliased String := "-mdll";
- Lib_Dir : aliased String := "-L" & Object_Dir_Default_Name.all;
+ Lib_Dir : aliased String := "-L" & Object_Dir_Default_Prefix;
begin
A := A + 1;
Index: osint.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/osint.adb,v
retrieving revision 1.13
diff -u -r1.13 osint.adb
--- osint.adb 10 Nov 2003 09:42:57 -0000 1.13
+++ osint.adb 13 Nov 2003 22:38:21 -0000
@@ -41,9 +41,12 @@
package body Osint is
Running_Program : Program_Type := Unspecified;
- Program_Set : Boolean := False;
+ -- comment required here ???
- Std_Prefix : String_Ptr;
+ Program_Set : Boolean := False;
+ -- comment required here ???
+
+ Std_Prefix : String_Ptr;
-- Standard prefix, computed dynamically the first time Relocate_Path
-- is called, and cached for subsequent calls.
@@ -66,8 +69,7 @@
function Append_Suffix_To_File_Name
(Name : Name_Id;
- Suffix : String)
- return Name_Id;
+ Suffix : String) return Name_Id;
-- Appends Suffix to Name and returns the new name.
function OS_Time_To_GNAT_Time (T : OS_Time) return Time_Stamp_Type;
@@ -81,14 +83,14 @@
-- The executable must be located in a directory called "bin", or
-- under root/lib/gcc-lib/..., or under root/libexec/gcc/... Thus, if
-- the executable is stored in directory "/foo/bar/bin", this routine
- -- returns "/foo/bar/".
- -- Return "" if the location is not recognized as described above.
+ -- returns "/foo/bar/". Return "" if the location is not recognized
+ -- as described above.
function Update_Path (Path : String_Ptr) return String_Ptr;
-- Update the specified path to replace the prefix with the location
-- where GNAT is installed. See the file prefix.c in GCC for details.
- procedure Write_With_Check (A : Address; N : Integer);
+ procedure Write_With_Check (A : Address; N : Integer);
-- Writes N bytes from buffer starting at address A to file whose FD is
-- stored in Output_FD, and whose file name is stored as a File_Name_Type
-- in Output_File_Name. A check is made for disk full, and if this is
@@ -99,8 +101,7 @@
(N : File_Name_Type;
T : File_Type;
Dir : Natural;
- Name : String)
- return File_Name_Type;
+ Name : String) return File_Name_Type;
-- See if the file N whose name is Name exists in directory Dir. Dir is
-- an index into the Lib_Search_Directories table if T = Library.
-- Otherwise if T = Source, Dir is an index into the
@@ -112,8 +113,7 @@
function To_Path_String_Access
(Path_Addr : Address;
- Path_Len : Integer)
- return String_Access;
+ Path_Len : Integer) return String_Access;
-- Converts a C String to an Ada String. Are we doing this to avoid
-- withing Interfaces.C.Strings ???
@@ -218,17 +218,15 @@
Equal => "=");
function Smart_Find_File
- (N : File_Name_Type;
- T : File_Type)
- return File_Name_Type;
+ (N : File_Name_Type;
+ T : File_Type) return File_Name_Type;
-- Exactly like Find_File except that if File_Cache_Enabled is True this
-- routine looks first in the hash table to see if the full name of the
-- file is already available.
function Smart_File_Stamp
- (N : File_Name_Type;
- T : File_Type)
- return Time_Stamp_Type;
+ (N : File_Name_Type;
+ T : File_Type) return Time_Stamp_Type;
-- Takes the same parameter as the routine above (N is a file name
-- without any prefix directory information) and behaves like File_Stamp
-- except that if File_Cache_Enabled is True this routine looks first in
@@ -591,8 +589,7 @@
function Append_Suffix_To_File_Name
(Name : Name_Id;
- Suffix : String)
- return Name_Id
+ Suffix : String) return Name_Id
is
begin
Get_Name_String (Name);
@@ -785,7 +782,7 @@
return new String'("");
end Get_Install_Dir;
- -- Beginning of Executable_Prefix
+ -- Start of processing for Executable_Prefix
begin
Osint.Fill_Arg (Exec_Name'Address, 0);
@@ -799,7 +796,7 @@
end if;
end loop;
- -- If you are here, the user has typed the executable name with no
+ -- If we come here, the user has typed the executable name with no
-- directory prefix.
return Get_Install_Dir (GNAT.OS_Lib.Locate_Exec_On_Path (Exec_Name).all);
@@ -890,9 +887,8 @@
---------------
function Find_File
- (N : File_Name_Type;
- T : File_Type)
- return File_Name_Type
+ (N : File_Name_Type;
+ T : File_Type) return File_Name_Type
is
begin
Get_Name_String (N);
@@ -1089,8 +1085,7 @@
-- call to Get_Next_Dir_In_Path_Init, updated by Get_Next_Dir_In_Path.
function Get_Next_Dir_In_Path
- (Search_Path : String_Access)
- return String_Access
+ (Search_Path : String_Access) return String_Access
is
Lower_Bound : Positive := Search_Path_Pos;
Upper_Bound : Positive;
@@ -1143,8 +1138,7 @@
function Get_RTS_Search_Dir
(Search_Dir : String;
- File_Type : Search_File_Type)
- return String_Ptr
+ File_Type : Search_File_Type) return String_Ptr
is
procedure Get_Current_Dir
(Dir : System.Address;
@@ -1299,6 +1293,28 @@
end if;
end Get_RTS_Search_Dir;
+ --------------------------------
+ -- Include_Dir_Default_Prefix --
+ --------------------------------
+
+ function Include_Dir_Default_Prefix return String is
+ Include_Dir : String_Access :=
+ String_Access (Update_Path (Include_Dir_Default_Name));
+
+ begin
+ if Include_Dir = null then
+ return "";
+
+ else
+ declare
+ Result : constant String := Include_Dir.all;
+ begin
+ Free (Include_Dir);
+ return Result;
+ end;
+ end if;
+ end Include_Dir_Default_Prefix;
+
----------------
-- Initialize --
----------------
@@ -1409,8 +1425,7 @@
(N : File_Name_Type;
T : File_Type;
Dir : Natural;
- Name : String)
- return File_Name_Type
+ Name : String) return File_Name_Type
is
Dir_Name : String_Ptr;
@@ -1451,9 +1466,8 @@
-------------------------------
function Matching_Full_Source_Name
- (N : File_Name_Type;
- T : Time_Stamp_Type)
- return File_Name_Type
+ (N : File_Name_Type;
+ T : Time_Stamp_Type) return File_Name_Type
is
begin
Get_Name_String (N);
@@ -1680,6 +1694,28 @@
return Number_File_Names;
end Number_Of_Files;
+ -------------------------------
+ -- Object_Dir_Default_Prefix --
+ -------------------------------
+
+ function Object_Dir_Default_Prefix return String is
+ Object_Dir : String_Access :=
+ String_Access (Update_Path (Object_Dir_Default_Name));
+
+ begin
+ if Object_Dir = null then
+ return "";
+
+ else
+ declare
+ Result : constant String := Object_Dir.all;
+ begin
+ Free (Object_Dir);
+ return Result;
+ end;
+ end if;
+ end Object_Dir_Default_Prefix;
+
----------------------
-- Object_File_Name --
----------------------
@@ -1768,8 +1804,7 @@
function Read_Default_Search_Dirs
(Search_Dir_Prefix : String_Access;
Search_File : String_Access;
- Search_Dir_Default_Name : String_Access)
- return String_Access
+ Search_Dir_Default_Name : String_Access) return String_Access
is
Prefix_Len : constant Integer := Search_Dir_Prefix.all'Length;
Buffer : String (1 .. Prefix_Len + Search_File.all'Length + 1);
@@ -1888,8 +1923,7 @@
function Read_Library_Info
(Lib_File : File_Name_Type;
- Fatal_Err : Boolean := False)
- return Text_Buffer_Ptr
+ Fatal_Err : Boolean := False) return Text_Buffer_Ptr
is
Lib_FD : File_Descriptor;
-- The file descriptor for the current library file. A negative value
@@ -2201,9 +2235,8 @@
----------------------
function Smart_File_Stamp
- (N : File_Name_Type;
- T : File_Type)
- return Time_Stamp_Type
+ (N : File_Name_Type;
+ T : File_Type) return Time_Stamp_Type
is
Time_Stamp : Time_Stamp_Type;
@@ -2228,8 +2261,7 @@
function Smart_Find_File
(N : File_Name_Type;
- T : File_Type)
- return File_Name_Type
+ T : File_Type) return File_Name_Type
is
Full_File_Name : File_Name_Type;
@@ -2320,13 +2352,11 @@
function To_Canonical_Dir_Spec
(Host_Dir : String;
- Prefix_Style : Boolean)
- return String_Access
+ Prefix_Style : Boolean) return String_Access
is
function To_Canonical_Dir_Spec
(Host_Dir : Address;
- Prefix_Flag : Integer)
- return Address;
+ Prefix_Flag : Integer) return Address;
pragma Import (C, To_Canonical_Dir_Spec, "__gnat_to_canonical_dir_spec");
C_Host_Dir : String (1 .. Host_Dir'Length + 1);
@@ -2362,13 +2392,11 @@
function To_Canonical_File_List
(Wildcard_Host_File : String;
- Only_Dirs : Boolean)
- return String_Access_List_Access
+ Only_Dirs : Boolean) return String_Access_List_Access
is
function To_Canonical_File_List_Init
(Host_File : Address;
- Only_Dirs : Integer)
- return Integer;
+ Only_Dirs : Integer) return Integer;
pragma Import (C, To_Canonical_File_List_Init,
"__gnat_to_canonical_file_list_init");
@@ -2421,8 +2449,7 @@
----------------------------
function To_Canonical_File_Spec
- (Host_File : String)
- return String_Access
+ (Host_File : String) return String_Access
is
function To_Canonical_File_Spec (Host_File : Address) return Address;
pragma Import
@@ -2457,8 +2484,7 @@
----------------------------
function To_Canonical_Path_Spec
- (Host_Path : String)
- return String_Access
+ (Host_Path : String) return String_Access
is
function To_Canonical_Path_Spec (Host_Path : Address) return Address;
pragma Import
@@ -2492,13 +2518,11 @@
function To_Host_Dir_Spec
(Canonical_Dir : String;
- Prefix_Style : Boolean)
- return String_Access
+ Prefix_Style : Boolean) return String_Access
is
function To_Host_Dir_Spec
(Canonical_Dir : Address;
- Prefix_Flag : Integer)
- return Address;
+ Prefix_Flag : Integer) return Address;
pragma Import (C, To_Host_Dir_Spec, "__gnat_to_host_dir_spec");
C_Canonical_Dir : String (1 .. Canonical_Dir'Length + 1);
@@ -2528,8 +2552,7 @@
----------------------------
function To_Host_File_Spec
- (Canonical_File : String)
- return String_Access
+ (Canonical_File : String) return String_Access
is
function To_Host_File_Spec (Canonical_File : Address) return Address;
pragma Import (C, To_Host_File_Spec, "__gnat_to_host_file_spec");
@@ -2559,8 +2582,7 @@
function To_Path_String_Access
(Path_Addr : Address;
- Path_Len : Integer)
- return String_Access
+ Path_Len : Integer) return String_Access
is
subtype Path_String is String (1 .. Path_Len);
type Path_String_Access is access Path_String;
Index: osint.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/osint.ads,v
retrieving revision 1.9
diff -u -r1.9 osint.ads
--- osint.ads 10 Nov 2003 09:42:57 -0000 1.9
+++ osint.ads 13 Nov 2003 22:38:21 -0000
@@ -217,6 +217,14 @@
-- Search Dir Routines --
-------------------------
+ function Include_Dir_Default_Prefix return String;
+ -- Return the directory of the run-time library sources, as modified
+ -- by update_path.
+
+ function Object_Dir_Default_Prefix return String;
+ -- Return the directory of the run-time library ALI and object files, as
+ -- modified by update_path.
+
procedure Add_Default_Search_Dirs;
-- This routine adds the default search dirs indicated by the
-- environment variables and sdefault package.
Index: par-ch4.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/par-ch4.adb,v
retrieving revision 1.6
diff -u -r1.6 par-ch4.adb
--- par-ch4.adb 21 Oct 2003 13:42:10 -0000 1.6
+++ par-ch4.adb 13 Nov 2003 22:38:21 -0000
@@ -28,6 +28,8 @@
-- Turn off subprogram body ordering check. Subprograms are in order
-- by RM section rather than alphabetical
+with Hostparm; use Hostparm;
+
separate (Par)
package body Ch4 is
@@ -1116,6 +1118,7 @@
-- POSITIONAL_ARRAY_AGGREGATE ::=
-- (EXPRESSION, EXPRESSION {, EXPRESSION})
-- | (EXPRESSION {, EXPRESSION}, others => EXPRESSION)
+ -- | (EXPRESSION {, EXPRESSION}, others => <>)
-- NAMED_ARRAY_AGGREGATE ::=
-- (ARRAY_COMPONENT_ASSOCIATION {, ARRAY_COMPONENT_ASSOCIATION})
@@ -1354,6 +1357,7 @@
-- RECORD_COMPONENT_ASSOCIATION ::=
-- [COMPONENT_CHOICE_LIST =>] EXPRESSION
+ -- | COMPONENT_CHOICE_LIST => <>
-- COMPONENT_CHOICE_LIST =>
-- component_SELECTOR_NAME {| component_SELECTOR_NAME}
@@ -1361,6 +1365,7 @@
-- ARRAY_COMPONENT_ASSOCIATION ::=
-- DISCRETE_CHOICE_LIST => EXPRESSION
+ -- | DISCRETE_CHOICE_LIST => <>
-- Note: this routine only handles the named cases, including others.
-- Cases where the component choice list is not present have already
@@ -1376,7 +1381,27 @@
Set_Choices (Assoc_Node, P_Discrete_Choice_List);
Set_Sloc (Assoc_Node, Token_Ptr);
TF_Arrow;
- Set_Expression (Assoc_Node, P_Expression);
+
+ if Token = Tok_Box then
+ if not Extensions_Allowed then
+ Error_Msg_SP
+ ("Limited aggregates are an Ada0X extension");
+
+ if OpenVMS then
+ Error_Msg_SP
+ ("\unit must be compiled with " &
+ "'/'E'X'T'E'N'S'I'O'N'S'_'A'L'L'O'W'E'D qualifier");
+ else
+ Error_Msg_SP
+ ("\unit must be compiled with -gnatX switch");
+ end if;
+ end if;
+
+ Set_Box_Present (Assoc_Node);
+ Scan; -- Past box
+ else
+ Set_Expression (Assoc_Node, P_Expression);
+ end if;
return Assoc_Node;
end P_Record_Or_Array_Component_Association;
Index: sem_aggr.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_aggr.adb,v
retrieving revision 1.8
diff -u -r1.8 sem_aggr.adb
--- sem_aggr.adb 21 Oct 2003 13:42:18 -0000 1.8
+++ sem_aggr.adb 13 Nov 2003 22:38:21 -0000
@@ -866,7 +866,9 @@
Error_Msg_N ("aggregate type cannot have limited component", N);
Explain_Limited_Type (Typ, N);
- elsif Is_Limited_Type (Typ) then
+ elsif Is_Limited_Type (Typ)
+ and not Extensions_Allowed
+ then
Error_Msg_N ("aggregate type cannot be limited", N);
Explain_Limited_Type (Typ, N);
@@ -1913,7 +1915,9 @@
Error_Msg_N ("type of extension aggregate must be tagged", N);
return;
- elsif Is_Limited_Type (Typ) then
+ elsif Is_Limited_Type (Typ)
+ and not Extensions_Allowed
+ then
Error_Msg_N ("aggregate type cannot be limited", N);
Explain_Limited_Type (Typ, N);
return;
@@ -2017,7 +2021,19 @@
--
-- This variable is updated as a side effect of function Get_Value
- procedure Add_Association (Component : Entity_Id; Expr : Node_Id);
+ Mbox_Present : Boolean := False;
+ Others_Mbox : Boolean := False;
+ -- Variables used in case of default initialization to provide a
+ -- functionality similar to Others_Etype. Mbox_Present indicates
+ -- that the component takes its default initialization; Others_Mbox
+ -- indicates that at least one component takes its default initiali-
+ -- zation. Similar to Others_Etype, they are also updated as a side
+ -- effect of function Get_Value.
+
+ procedure Add_Association
+ (Component : Entity_Id;
+ Expr : Node_Id;
+ Box_Present : Boolean := False);
-- Builds a new N_Component_Association node which associates
-- Component to expression Expr and adds it to the new association
-- list New_Assoc_List being built.
@@ -2064,7 +2080,11 @@
-- Add_Association --
---------------------
- procedure Add_Association (Component : Entity_Id; Expr : Node_Id) is
+ procedure Add_Association
+ (Component : Entity_Id;
+ Expr : Node_Id;
+ Box_Present : Boolean := False)
+ is
Choice_List : constant List_Id := New_List;
New_Assoc : Node_Id;
@@ -2072,8 +2092,9 @@
Append (New_Occurrence_Of (Component, Sloc (Expr)), Choice_List);
New_Assoc :=
Make_Component_Association (Sloc (Expr),
- Choices => Choice_List,
- Expression => Expr);
+ Choices => Choice_List,
+ Expression => Expr,
+ Box_Present => Box_Present);
Append (New_Assoc, New_Assoc_List);
end Add_Association;
@@ -2174,7 +2195,37 @@
Expr : Node_Id := Empty;
Selector_Name : Node_Id;
+ procedure Check_Non_Limited_Type;
+ -- Relax check to allow the default initialization of limited types.
+ -- For example:
+ -- record
+ -- C : Lim := (..., others => <>);
+ -- end record;
+
+ procedure Check_Non_Limited_Type is
+ begin
+ if Is_Limited_Type (Etype (Compon))
+ and then Comes_From_Source (Compon)
+ and then not In_Instance_Body
+ then
+
+ if Extensions_Allowed
+ and then Present (Expression (Assoc))
+ and then Nkind (Expression (Assoc)) = N_Aggregate
+ then
+ null;
+ else
+ Error_Msg_N
+ ("initialization not allowed for limited types", N);
+ Explain_Limited_Type (Etype (Compon), Compon);
+ end if;
+
+ end if;
+ end Check_Non_Limited_Type;
+
begin
+ Mbox_Present := False;
+
if Present (From) then
Assoc := First (From);
else
@@ -2186,14 +2237,6 @@
while Present (Selector_Name) loop
if Nkind (Selector_Name) = N_Others_Choice then
if Consider_Others_Choice and then No (Expr) then
- if Present (Others_Etype) and then
- Base_Type (Others_Etype) /= Base_Type (Etype (Compon))
- then
- Error_Msg_N ("components in OTHERS choice must " &
- "have same type", Selector_Name);
- end if;
-
- Others_Etype := Etype (Compon);
-- We need to duplicate the expression for each
-- successive component covered by the others choice.
@@ -2202,10 +2245,34 @@
-- indispensable otherwise, because each one must be
-- expanded individually to preserve side-effects.
- if Expander_Active then
- return New_Copy_Tree (Expression (Assoc));
+ if Box_Present (Assoc) then
+ Others_Mbox := True;
+ Mbox_Present := True;
+
+ if Expander_Active then
+ return New_Copy_Tree (Expression (Parent (Compon)));
+ else
+ return Expression (Parent (Compon));
+ end if;
else
- return Expression (Assoc);
+
+ Check_Non_Limited_Type;
+
+ if Present (Others_Etype) and then
+ Base_Type (Others_Etype) /= Base_Type (Etype
+ (Compon))
+ then
+ Error_Msg_N ("components in OTHERS choice must " &
+ "have same type", Selector_Name);
+ end if;
+
+ Others_Etype := Etype (Compon);
+
+ if Expander_Active then
+ return New_Copy_Tree (Expression (Assoc));
+ else
+ return Expression (Assoc);
+ end if;
end if;
end if;
@@ -2216,10 +2283,27 @@
-- components are grouped together with a "|" choice.
-- For instance "filed1 | filed2 => Expr"
- if Present (Next (Selector_Name)) then
- Expr := New_Copy_Tree (Expression (Assoc));
+ if Box_Present (Assoc) then
+ Mbox_Present := True;
+
+ -- Duplicate the default expression of the component
+ -- from the record type declaration
+
+ if Present (Next (Selector_Name)) then
+ Expr := New_Copy_Tree
+ (Expression (Parent (Compon)));
+ else
+ Expr := Expression (Parent (Compon));
+ end if;
else
- Expr := Expression (Assoc);
+
+ Check_Non_Limited_Type;
+
+ if Present (Next (Selector_Name)) then
+ Expr := New_Copy_Tree (Expression (Assoc));
+ else
+ Expr := Expression (Assoc);
+ end if;
end if;
Generate_Reference (Compon, Selector_Name);
@@ -2753,7 +2837,18 @@
Component := Node (Component_Elmt);
Expr := Get_Value (Component, Component_Associations (N), True);
- if No (Expr) then
+ if Mbox_Present and then Is_Limited_Type (Etype (Component)) then
+
+ -- In case of default initialization of a limited component we
+ -- pass the limited component to the expander. The expander will
+ -- generate calls to the corresponding initialization subprograms.
+
+ Add_Association
+ (Component => Component,
+ Expr => Empty,
+ Box_Present => True);
+
+ elsif No (Expr) then
Error_Msg_NE ("no value supplied for component &!", N, Component);
else
Resolve_Aggr_Expr (Expr, Component);
@@ -2783,7 +2878,9 @@
Typech := Empty;
if Nkind (Selectr) = N_Others_Choice then
- if No (Others_Etype) then
+ if No (Others_Etype)
+ and then not Others_Mbox
+ then
Error_Msg_N
("OTHERS must represent at least one component", Selectr);
end if;
@@ -2804,8 +2901,10 @@
-- component supplied by a previous expansion.
if No (New_Assoc) then
+ if Box_Present (Parent (Selectr)) then
+ null;
- if Chars (Selectr) /= Name_uTag
+ elsif Chars (Selectr) /= Name_uTag
and then Chars (Selectr) /= Name_uParent
and then Chars (Selectr) /= Name_uController
then
@@ -2827,8 +2926,13 @@
Typech := Base_Type (Etype (Component));
elsif Typech /= Base_Type (Etype (Component)) then
- Error_Msg_N
- ("components in choice list must have same type", Selectr);
+
+ if not Box_Present (Parent (Selectr)) then
+ Error_Msg_N
+ ("components in choice list must have same type",
+ Selectr);
+ end if;
+
end if;
Next (Selectr);
Index: sem_ch3.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch3.adb,v
retrieving revision 1.20
diff -u -r1.20 sem_ch3.adb
--- sem_ch3.adb 24 Oct 2003 13:02:42 -0000 1.20
+++ sem_ch3.adb 13 Nov 2003 22:38:22 -0000
@@ -6234,9 +6234,19 @@
or else Is_Limited_Composite (T))
and then not In_Instance
then
- Error_Msg_N
- ("cannot initialize entities of limited type", Exp);
- Explain_Limited_Type (T, Exp);
+ -- Relax the strictness of the front-end in case of limited
+ -- aggregates and extension aggregates.
+
+ if Extensions_Allowed
+ and then (Nkind (Exp) = N_Aggregate
+ or else Nkind (Exp) = N_Extension_Aggregate)
+ then
+ null;
+ else
+ Error_Msg_N
+ ("cannot initialize entities of limited type", Exp);
+ Explain_Limited_Type (T, Exp);
+ end if;
end if;
end Check_Initialization;
Index: sem_ch4.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch4.adb,v
retrieving revision 1.7
diff -u -r1.7 sem_ch4.adb
--- sem_ch4.adb 21 Oct 2003 13:42:19 -0000 1.7
+++ sem_ch4.adb 13 Nov 2003 22:38:22 -0000
@@ -338,7 +338,8 @@
Check_Restriction (No_Protected_Type_Allocators, N);
end if;
- if Is_Limited_Type (Type_Id)
+ if Nkind (Expression (E)) /= N_Aggregate
+ and then Is_Limited_Type (Type_Id)
and then Comes_From_Source (N)
and then not In_Instance_Body
then
Index: sem_ch8.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch8.adb,v
retrieving revision 1.12
diff -u -r1.12 sem_ch8.adb
--- sem_ch8.adb 10 Nov 2003 17:29:59 -0000 1.12
+++ sem_ch8.adb 13 Nov 2003 22:38:22 -0000
@@ -4063,10 +4063,9 @@
if Is_Access_Type (P_Type)
and then Ekind (Designated_Type (P_Type)) = E_Incomplete_Type
then
- Error_Msg_Node_2 := Selector_Name (N);
- Error_Msg_NE (
- "\incomplete type& has no visible component&", P,
- Designated_Type (P_Type));
+ Error_Msg_N
+ ("\dereference must not be of an incomplete type " &
+ "('R'M 3.10.1)", P);
end if;
else
Index: sem_ch9.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch9.adb,v
retrieving revision 1.6
diff -u -r1.6 sem_ch9.adb
--- sem_ch9.adb 21 Oct 2003 13:42:20 -0000 1.6
+++ sem_ch9.adb 13 Nov 2003 22:38:22 -0000
@@ -294,6 +294,7 @@
while Present (E1) loop
if Ekind (E1) = E_Procedure
+ and then Chars (E1) = Chars (Entry_Nam)
and then Type_Conformant (E1, Entry_Nam)
then
Error_Msg_N ("entry name is not visible", N);
Index: sem_res.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_res.adb,v
retrieving revision 1.12
diff -u -r1.12 sem_res.adb
--- sem_res.adb 4 Nov 2003 12:51:46 -0000 1.12
+++ sem_res.adb 13 Nov 2003 22:38:22 -0000
@@ -1940,9 +1940,25 @@
if Is_Overloaded (N)
and then Nkind (N) = N_Function_Call
then
- Error_Msg_Node_2 := Typ;
- Error_Msg_NE ("no visible interpretation of&" &
- " matches expected type&", N, Name (N));
+ declare
+ Subp_Name : Node_Id;
+ begin
+ if Is_Entity_Name (Name (N)) then
+ Subp_Name := Name (N);
+
+ elsif Nkind (Name (N)) = N_Selected_Component then
+
+ -- Protected operation: retrieve operation name.
+
+ Subp_Name := Selector_Name (Name (N));
+ else
+ raise Program_Error;
+ end if;
+
+ Error_Msg_Node_2 := Typ;
+ Error_Msg_NE ("no visible interpretation of&" &
+ " matches expected type&", N, Subp_Name);
+ end;
if All_Errors_Mode then
declare
Index: sinfo.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sinfo.adb,v
retrieving revision 1.9
diff -u -r1.9 sinfo.adb
--- sinfo.adb 10 Nov 2003 17:29:59 -0000 1.9
+++ sinfo.adb 13 Nov 2003 22:38:22 -0000
@@ -297,6 +297,7 @@
(N : Node_Id) return Boolean is
begin
pragma Assert (False
+ or else NT (N).Nkind = N_Component_Association
or else NT (N).Nkind = N_Formal_Package_Declaration
or else NT (N).Nkind = N_Formal_Subprogram_Declaration);
return Flag15 (N);
@@ -2729,6 +2730,7 @@
(N : Node_Id; Val : Boolean := True) is
begin
pragma Assert (False
+ or else NT (N).Nkind = N_Component_Association
or else NT (N).Nkind = N_Formal_Package_Declaration
or else NT (N).Nkind = N_Formal_Subprogram_Declaration);
Set_Flag15 (N, Val);
Index: sinfo.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sinfo.ads,v
retrieving revision 1.13
diff -u -r1.13 sinfo.ads
--- sinfo.ads 10 Nov 2003 17:29:59 -0000 1.13
+++ sinfo.ads 13 Nov 2003 22:38:23 -0000
@@ -3008,6 +3008,7 @@
-- Choices (List1)
-- Loop_Actions (List2-Sem)
-- Expression (Node3)
+ -- Box_Present (Flag15)
-- Note: this structure is used for both record component associations
-- and array component associations, since the two cases aren't always
Index: sprint.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sprint.adb,v
retrieving revision 1.9
diff -u -r1.9 sprint.adb
--- sprint.adb 10 Nov 2003 17:30:00 -0000 1.9
+++ sprint.adb 13 Nov 2003 22:38:23 -0000
@@ -928,7 +928,11 @@
Set_Debug_Sloc;
Sprint_Bar_List (Choices (Node));
Write_Str (" => ");
- Sprint_Node (Expression (Node));
+ if Box_Present (Node) then
+ Write_Str_With_Col_Check ("<>");
+ else
+ Sprint_Node (Expression (Node));
+ end if;
when N_Component_Clause =>
Write_Indent;
Index: s-thread.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/s-thread.adb,v
retrieving revision 1.3
diff -u -r1.3 s-thread.adb
--- s-thread.adb 10 Nov 2003 17:30:00 -0000 1.3
+++ s-thread.adb 13 Nov 2003 22:38:23 -0000
@@ -31,13 +31,14 @@
-- --
------------------------------------------------------------------------------
--- This is the VxWorks/Cert version of this package
+-- This is the VxWorks version of this package
-with System.Init;
with System.Secondary_Stack;
with Unchecked_Conversion;
+with System.Threads.Initialization;
+
package body System.Threads is
package SSS renames System.Secondary_Stack;
@@ -48,6 +49,12 @@
function From_Address is
new Unchecked_Conversion (Address, ATSD_Access);
+ procedure Init_Float;
+ pragma Import (C, Init_Float, "__gnat_init_float");
+
+ procedure Install_Handler;
+ pragma Import (C, Install_Handler, "__gnat_install_handler");
+
-----------------------
-- Get_Current_Excep --
-----------------------
@@ -122,8 +129,8 @@
SSS.SS_Init (TSD.Sec_Stack_Addr, Sec_Stack_Size);
Current_ATSD := Process_ATSD_Address;
- System.Init.Install_Handler;
- System.Init.Init_Float;
+ Install_Handler;
+ Init_Float;
end Thread_Body_Enter;
----------------------------------
@@ -136,6 +143,7 @@
pragma Unreferenced (EO);
begin
-- No action for this target
+
null;
end Thread_Body_Exceptional_Exit;
@@ -146,7 +154,10 @@
procedure Thread_Body_Leave is
begin
-- No action for this target
+
null;
end Thread_Body_Leave;
+begin
+ System.Threads.Initialization.Init_RTS;
end System.Threads;
Index: vms_conv.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/vms_conv.ads,v
retrieving revision 1.1
diff -u -r1.1 vms_conv.ads
--- vms_conv.ads 21 Oct 2003 13:42:23 -0000 1.1
+++ vms_conv.ads 13 Nov 2003 22:38:23 -0000
@@ -25,7 +25,7 @@
------------------------------------------------------------------------------
-- This package is part of the GNAT driver. It contains a procedure
--- VMS_Conversion to convert the command line in VMS form to the wquivalent
+-- VMS_Conversion to convert the command line in VMS form to the equivalent
-- command line with switches for the GNAT tools that the GNAT driver will
-- invoke.
--
@@ -97,9 +97,9 @@
type Command_Type is
(Bind, Chop, Clean, Compile, Elim, Find, Krunch, Library, Link, List,
- Make, Name, Preprocess, Pretty, Shared, Standard, Stub, Xref, Undefined);
+ Make, Name, Preprocess, Pretty, Shared, Stub, Xref, Undefined);
- type Alternate_Command is (Comp, Ls, Kr, Pp, Prep, Psta);
+ type Alternate_Command is (Comp, Ls, Kr, Pp, Prep);
-- Alternate command libel for non VMS system
Corresponding_To : constant array (Alternate_Command) of Command_Type :=
@@ -107,8 +107,7 @@
Ls => List,
Kr => Krunch,
Prep => Preprocess,
- Pp => Pretty,
- Psta => Standard);
+ Pp => Pretty);
-- Mapping of alternate commands to commands
subtype Real_Command_Type is Command_Type range Bind .. Xref;
Index: vms_conv.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/vms_conv.adb,v
retrieving revision 1.1
diff -u -r1.1 vms_conv.adb
--- vms_conv.adb 21 Oct 2003 13:42:23 -0000 1.1
+++ vms_conv.adb 13 Nov 2003 22:38:23 -0000
@@ -25,8 +25,7 @@
------------------------------------------------------------------------------
with Hostparm;
-with Osint; use Osint;
-with Sdefault; use Sdefault;
+with Osint; use Osint;
with Ada.Characters.Handling; use Ada.Characters.Handling;
with Ada.Command_Line; use Ada.Command_Line;
@@ -141,7 +140,7 @@
begin
Object_Dirs := 0;
- Object_Dir_Name := String_Access (Object_Dir_Default_Name);
+ Object_Dir_Name := new String'(Object_Dir_Default_Prefix);
Get_Next_Dir_In_Path_Init (Object_Dir_Name);
loop
@@ -287,13 +286,13 @@
Make =>
(Cname => new S'("MAKE"),
- Usage => new S'("GNAT MAKE file /qualifiers (includes "
+ Usage => new S'("GNAT MAKE file(s) /qualifiers (includes "
& "COMPILE /qualifiers)"),
VMS_Only => False,
Unixcmd => new S'("gnatmake"),
Unixsws => null,
Switches => Make_Switches'Access,
- Params => new Parameter_Array'(1 => File),
+ Params => new Parameter_Array'(1 => Unlimited_Files),
Defext => " "),
Name =>
@@ -340,16 +339,6 @@
Params => new Parameter_Array'(1 => Unlimited_Files),
Defext => " "),
- Standard =>
- (Cname => new S'("STANDARD"),
- Usage => new S'("GNAT STANDARD"),
- VMS_Only => False,
- Unixcmd => new S'("gnatpsta"),
- Unixsws => null,
- Switches => Standard_Switches'Access,
- Params => new Parameter_Array'(1 .. 0 => File),
- Defext => " "),
-
Stub =>
(Cname => new S'("STUB"),
Usage => new S'("GNAT STUB file [directory]/qualifiers"),
@@ -1092,231 +1081,270 @@
Arg_Idx := Argv'First;
<<Tryagain_After_Coalesce>>
- loop
- declare
- Next_Arg_Idx : Integer;
- Arg : String_Access;
-
- begin
- Next_Arg_Idx := Get_Arg_End (Argv.all, Arg_Idx);
- Arg := new String'(Argv (Arg_Idx .. Next_Arg_Idx));
+ loop
+ declare
+ Next_Arg_Idx : Integer;
+ Arg : String_Access;
- -- The first one must be a command name
+ begin
+ Next_Arg_Idx := Get_Arg_End (Argv.all, Arg_Idx);
+ Arg := new String'(Argv (Arg_Idx .. Next_Arg_Idx));
- if Arg_Num = 1 and then Arg_Idx = Argv'First then
+ -- The first one must be a command name
- Command := Matching_Name (Arg.all, Commands);
+ if Arg_Num = 1 and then Arg_Idx = Argv'First then
- if Command = null then
- raise Error_Exit;
- end if;
+ Command := Matching_Name (Arg.all, Commands);
- The_Command := Command.Command;
+ if Command = null then
+ raise Error_Exit;
+ end if;
- -- Give usage information if only command given
+ The_Command := Command.Command;
- if Argument_Count = 1 and then Next_Arg_Idx = Argv'Last
- and then Command.Command /= VMS_Conv.Standard
- then
- Output_Version;
- New_Line;
- Put_Line
- ("List of available qualifiers and options");
- New_Line;
-
- Put (Command.Usage.all);
- Set_Col (53);
- Put_Line (Command.Unix_String.all);
-
- declare
- Sw : Item_Ptr := Command.Switches;
-
- begin
- while Sw /= null loop
- Put (" ");
- Put (Sw.Name.all);
-
- case Sw.Translation is
-
- when T_Other =>
- Set_Col (53);
- Put_Line (Sw.Unix_String.all &
- "/<other>");
-
- when T_Direct =>
- Set_Col (53);
- Put_Line (Sw.Unix_String.all);
-
- when T_Directories =>
- Put ("=(direc,direc,..direc)");
- Set_Col (53);
- Put (Sw.Unix_String.all);
- Put (" direc ");
- Put (Sw.Unix_String.all);
- Put_Line (" direc ...");
+ -- Give usage information if only command given
- when T_Directory =>
- Put ("=directory");
- Set_Col (53);
- Put (Sw.Unix_String.all);
+ if Argument_Count = 1
+ and then Next_Arg_Idx = Argv'Last
+ then
+ Output_Version;
+ New_Line;
+ Put_Line
+ ("List of available qualifiers and options");
+ New_Line;
+
+ Put (Command.Usage.all);
+ Set_Col (53);
+ Put_Line (Command.Unix_String.all);
- if Sw.Unix_String (Sw.Unix_String'Last)
- /= '='
- then
- Put (' ');
- end if;
+ declare
+ Sw : Item_Ptr := Command.Switches;
- Put_Line ("directory ");
+ begin
+ while Sw /= null loop
+ Put (" ");
+ Put (Sw.Name.all);
- when T_File | T_No_Space_File =>
- Put ("=file");
- Set_Col (53);
- Put (Sw.Unix_String.all);
+ case Sw.Translation is
- if Sw.Translation = T_File
- and then Sw.Unix_String
- (Sw.Unix_String'Last)
- /= '='
- then
- Put (' ');
- end if;
+ when T_Other =>
+ Set_Col (53);
+ Put_Line (Sw.Unix_String.all &
+ "/<other>");
- Put_Line ("file ");
+ when T_Direct =>
+ Set_Col (53);
+ Put_Line (Sw.Unix_String.all);
- when T_Numeric =>
- Put ("=nnn");
- Set_Col (53);
+ when T_Directories =>
+ Put ("=(direc,direc,..direc)");
+ Set_Col (53);
+ Put (Sw.Unix_String.all);
+ Put (" direc ");
+ Put (Sw.Unix_String.all);
+ Put_Line (" direc ...");
- if Sw.Unix_String (Sw.Unix_String'First)
- = '`'
- then
- Put (Sw.Unix_String
- (Sw.Unix_String'First + 1
- .. Sw.Unix_String'Last));
- else
- Put (Sw.Unix_String.all);
- end if;
+ when T_Directory =>
+ Put ("=directory");
+ Set_Col (53);
+ Put (Sw.Unix_String.all);
- Put_Line ("nnn");
+ if Sw.Unix_String (Sw.Unix_String'Last)
+ /= '='
+ then
+ Put (' ');
+ end if;
- when T_Alphanumplus =>
- Put ("=xyz");
- Set_Col (53);
+ Put_Line ("directory ");
- if Sw.Unix_String (Sw.Unix_String'First)
- = '`'
- then
- Put (Sw.Unix_String
- (Sw.Unix_String'First + 1
- .. Sw.Unix_String'Last));
- else
- Put (Sw.Unix_String.all);
- end if;
+ when T_File | T_No_Space_File =>
+ Put ("=file");
+ Set_Col (53);
+ Put (Sw.Unix_String.all);
+
+ if Sw.Translation = T_File
+ and then Sw.Unix_String
+ (Sw.Unix_String'Last)
+ /= '='
+ then
+ Put (' ');
+ end if;
- Put_Line ("xyz");
+ Put_Line ("file ");
- when T_String =>
- Put ("=");
- Put ('"');
- Put ("<string>");
- Put ('"');
- Set_Col (53);
+ when T_Numeric =>
+ Put ("=nnn");
+ Set_Col (53);
+ if Sw.Unix_String (Sw.Unix_String'First)
+ = '`'
+ then
+ Put (Sw.Unix_String
+ (Sw.Unix_String'First + 1
+ .. Sw.Unix_String'Last));
+ else
Put (Sw.Unix_String.all);
+ end if;
- if Sw.Unix_String (Sw.Unix_String'Last)
- /= '='
- then
- Put (' ');
- end if;
+ Put_Line ("nnn");
- Put ("<string>");
- New_Line;
+ when T_Alphanumplus =>
+ Put ("=xyz");
+ Set_Col (53);
- when T_Commands =>
- Put (" (switches for ");
- Put (Sw.Unix_String
- (Sw.Unix_String'First + 7
- .. Sw.Unix_String'Last));
- Put (')');
- Set_Col (53);
+ if Sw.Unix_String (Sw.Unix_String'First)
+ = '`'
+ then
Put (Sw.Unix_String
- (Sw.Unix_String'First
- .. Sw.Unix_String'First + 5));
- Put_Line (" switches");
-
- when T_Options =>
- declare
- Opt : Item_Ptr := Sw.Options;
-
- begin
- Put_Line ("=(option,option..)");
-
- while Opt /= null loop
- Put (" ");
- Put (Opt.Name.all);
-
- if Opt = Sw.Options then
- Put (" (D)");
- end if;
-
- Set_Col (53);
- Put_Line (Opt.Unix_String.all);
- Opt := Opt.Next;
- end loop;
- end;
+ (Sw.Unix_String'First + 1
+ .. Sw.Unix_String'Last));
+ else
+ Put (Sw.Unix_String.all);
+ end if;
- end case;
+ Put_Line ("xyz");
- Sw := Sw.Next;
- end loop;
- end;
+ when T_String =>
+ Put ("=");
+ Put ('"');
+ Put ("<string>");
+ Put ('"');
+ Set_Col (53);
- raise Normal_Exit;
- end if;
+ Put (Sw.Unix_String.all);
+
+ if Sw.Unix_String (Sw.Unix_String'Last)
+ /= '='
+ then
+ Put (' ');
+ end if;
+
+ Put ("<string>");
+ New_Line;
+
+ when T_Commands =>
+ Put (" (switches for ");
+ Put (Sw.Unix_String
+ (Sw.Unix_String'First + 7
+ .. Sw.Unix_String'Last));
+ Put (')');
+ Set_Col (53);
+ Put (Sw.Unix_String
+ (Sw.Unix_String'First
+ .. Sw.Unix_String'First + 5));
+ Put_Line (" switches");
+
+ when T_Options =>
+ declare
+ Opt : Item_Ptr := Sw.Options;
+
+ begin
+ Put_Line ("=(option,option..)");
+
+ while Opt /= null loop
+ Put (" ");
+ Put (Opt.Name.all);
+
+ if Opt = Sw.Options then
+ Put (" (D)");
+ end if;
+
+ Set_Col (53);
+ Put_Line (Opt.Unix_String.all);
+ Opt := Opt.Next;
+ end loop;
+ end;
+
+ end case;
+
+ Sw := Sw.Next;
+ end loop;
+ end;
+
+ raise Normal_Exit;
+ end if;
-- Special handling for internal debugging switch /?
- elsif Arg.all = "/?" then
- Display_Command := True;
+ elsif Arg.all = "/?" then
+ Display_Command := True;
-- Copy -switch unchanged
- elsif Arg (Arg'First) = '-' then
- Place (' ');
- Place (Arg.all);
+ elsif Arg (Arg'First) = '-' then
+ Place (' ');
+ Place (Arg.all);
-- Copy quoted switch with quotes stripped
- elsif Arg (Arg'First) = '"' then
- if Arg (Arg'Last) /= '"' then
- Put (Standard_Error, "misquoted argument: ");
- Put_Line (Standard_Error, Arg.all);
- Errors := Errors + 1;
+ elsif Arg (Arg'First) = '"' then
+ if Arg (Arg'Last) /= '"' then
+ Put (Standard_Error, "misquoted argument: ");
+ Put_Line (Standard_Error, Arg.all);
+ Errors := Errors + 1;
- else
- Place (' ');
- Place (Arg (Arg'First + 1 .. Arg'Last - 1));
- end if;
+ else
+ Place (' ');
+ Place (Arg (Arg'First + 1 .. Arg'Last - 1));
+ end if;
-- Parameter Argument
- elsif Arg (Arg'First) /= '/'
- and then Make_Commands_Active = null
- then
- Param_Count := Param_Count + 1;
+ elsif Arg (Arg'First) /= '/'
+ and then Make_Commands_Active = null
+ then
+ Param_Count := Param_Count + 1;
+
+ if Param_Count <= Command.Params'Length then
+
+ case Command.Params (Param_Count) is
+
+ when File | Optional_File =>
+ declare
+ Normal_File : constant String_Access :=
+ To_Canonical_File_Spec
+ (Arg.all);
- if Param_Count <= Command.Params'Length then
+ begin
+ Place (' ');
+ Place_Lower (Normal_File.all);
- case Command.Params (Param_Count) is
+ if Is_Extensionless (Normal_File.all)
+ and then Command.Defext /= " "
+ then
+ Place ('.');
+ Place (Command.Defext);
+ end if;
+ end;
+
+ when Unlimited_Files =>
+ declare
+ Normal_File :
+ constant String_Access :=
+ To_Canonical_File_Spec (Arg.all);
+
+ File_Is_Wild : Boolean := False;
+ File_List : String_Access_List_Access;
+
+ begin
+ for J in Arg'Range loop
+ if Arg (J) = '*'
+ or else Arg (J) = '%'
+ then
+ File_Is_Wild := True;
+ end if;
+ end loop;
- when File | Optional_File =>
- declare
- Normal_File : constant String_Access :=
- To_Canonical_File_Spec
- (Arg.all);
+ if File_Is_Wild then
+ File_List := To_Canonical_File_List
+ (Arg.all, False);
- begin
+ for J in File_List.all'Range loop
+ Place (' ');
+ Place_Lower (File_List.all (J).all);
+ end loop;
+
+ else
Place (' ');
Place_Lower (Normal_File.all);
@@ -1326,36 +1354,92 @@
Place ('.');
Place (Command.Defext);
end if;
- end;
+ end if;
- when Unlimited_Files =>
- declare
- Normal_File :
- constant String_Access :=
- To_Canonical_File_Spec (Arg.all);
+ Param_Count := Param_Count - 1;
+ end;
- File_Is_Wild : Boolean := False;
- File_List : String_Access_List_Access;
+ when Other_As_Is =>
+ Place (' ');
+ Place (Arg.all);
+
+ when Unlimited_As_Is =>
+ Place (' ');
+ Place (Arg.all);
+ Param_Count := Param_Count - 1;
+
+ when Files_Or_Wildcard =>
+
+ -- Remove spaces from a comma separated list
+ -- of file names and adjust control variables
+ -- accordingly.
+
+ while Arg_Num < Argument_Count and then
+ (Argv (Argv'Last) = ',' xor
+ Argument (Arg_Num + 1)
+ (Argument (Arg_Num + 1)'First) = ',')
+ loop
+ Argv := new String'
+ (Argv.all & Argument (Arg_Num + 1));
+ Arg_Num := Arg_Num + 1;
+ Arg_Idx := Argv'First;
+ Next_Arg_Idx :=
+ Get_Arg_End (Argv.all, Arg_Idx);
+ Arg := new String'
+ (Argv (Arg_Idx .. Next_Arg_Idx));
+ end loop;
+
+ -- Parse the comma separated list of VMS
+ -- filenames and place them on the command
+ -- line as space separated Unix style
+ -- filenames. Lower case and add default
+ -- extension as appropriate.
+
+ declare
+ Arg1_Idx : Integer := Arg'First;
+
+ function Get_Arg1_End
+ (Arg : String; Arg_Idx : Integer)
+ return Integer;
+ -- Begins looking at Arg_Idx + 1 and
+ -- returns the index of the last character
+ -- before a comma or else the index of the
+ -- last character in the string Arg.
+
+ ------------------
+ -- Get_Arg1_End --
+ ------------------
+ function Get_Arg1_End
+ (Arg : String; Arg_Idx : Integer)
+ return Integer
+ is
begin
- for J in Arg'Range loop
- if Arg (J) = '*'
- or else Arg (J) = '%'
- then
- File_Is_Wild := True;
+ for J in Arg_Idx + 1 .. Arg'Last loop
+ if Arg (J) = ',' then
+ return J - 1;
end if;
end loop;
- if File_Is_Wild then
- File_List := To_Canonical_File_List
- (Arg.all, False);
-
- for J in File_List.all'Range loop
- Place (' ');
- Place_Lower (File_List.all (J).all);
- end loop;
+ return Arg'Last;
+ end Get_Arg1_End;
- else
+ begin
+ loop
+ declare
+ Next_Arg1_Idx :
+ constant Integer :=
+ Get_Arg1_End (Arg.all, Arg1_Idx);
+
+ Arg1 :
+ constant String :=
+ Arg (Arg1_Idx .. Next_Arg1_Idx);
+
+ Normal_File :
+ constant String_Access :=
+ To_Canonical_File_Spec (Arg1);
+
+ begin
Place (' ');
Place_Lower (Normal_File.all);
@@ -1365,542 +1449,447 @@
Place ('.');
Place (Command.Defext);
end if;
- end if;
- Param_Count := Param_Count - 1;
- end;
+ Arg1_Idx := Next_Arg1_Idx + 1;
+ end;
- when Other_As_Is =>
- Place (' ');
- Place (Arg.all);
-
- when Unlimited_As_Is =>
- Place (' ');
- Place (Arg.all);
- Param_Count := Param_Count - 1;
+ exit when Arg1_Idx > Arg'Last;
- when Files_Or_Wildcard =>
-
- -- Remove spaces from a comma separated list
- -- of file names and adjust control variables
- -- accordingly.
-
- while Arg_Num < Argument_Count and then
- (Argv (Argv'Last) = ',' xor
- Argument (Arg_Num + 1)
- (Argument (Arg_Num + 1)'First) = ',')
- loop
- Argv := new String'
- (Argv.all & Argument (Arg_Num + 1));
- Arg_Num := Arg_Num + 1;
- Arg_Idx := Argv'First;
- Next_Arg_Idx :=
- Get_Arg_End (Argv.all, Arg_Idx);
- Arg := new String'
- (Argv (Arg_Idx .. Next_Arg_Idx));
- end loop;
-
- -- Parse the comma separated list of VMS
- -- filenames and place them on the command
- -- line as space separated Unix style
- -- filenames. Lower case and add default
- -- extension as appropriate.
-
- declare
- Arg1_Idx : Integer := Arg'First;
-
- function Get_Arg1_End
- (Arg : String; Arg_Idx : Integer)
- return Integer;
- -- Begins looking at Arg_Idx + 1 and
- -- returns the index of the last character
- -- before a comma or else the index of the
- -- last character in the string Arg.
-
- ------------------
- -- Get_Arg1_End --
- ------------------
+ -- Don't allow two or more commas in
+ -- a row
- function Get_Arg1_End
- (Arg : String; Arg_Idx : Integer)
- return Integer
- is
- begin
- for J in Arg_Idx + 1 .. Arg'Last loop
- if Arg (J) = ',' then
- return J - 1;
- end if;
- end loop;
-
- return Arg'Last;
- end Get_Arg1_End;
-
- begin
- loop
- declare
- Next_Arg1_Idx :
- constant Integer :=
- Get_Arg1_End (Arg.all, Arg1_Idx);
-
- Arg1 :
- constant String :=
- Arg (Arg1_Idx .. Next_Arg1_Idx);
-
- Normal_File :
- constant String_Access :=
- To_Canonical_File_Spec (Arg1);
-
- begin
- Place (' ');
- Place_Lower (Normal_File.all);
-
- if Is_Extensionless (Normal_File.all)
- and then Command.Defext /= " "
- then
- Place ('.');
- Place (Command.Defext);
- end if;
-
- Arg1_Idx := Next_Arg1_Idx + 1;
- end;
-
- exit when Arg1_Idx > Arg'Last;
-
- -- Don't allow two or more commas in
- -- a row
-
- if Arg (Arg1_Idx) = ',' then
- Arg1_Idx := Arg1_Idx + 1;
- if Arg1_Idx > Arg'Last or else
- Arg (Arg1_Idx) = ','
- then
- Put_Line
- (Standard_Error,
- "Malformed Parameter: " &
- Arg.all);
- Put (Standard_Error, "usage: ");
- Put_Line (Standard_Error,
- Command.Usage.all);
- raise Error_Exit;
- end if;
+ if Arg (Arg1_Idx) = ',' then
+ Arg1_Idx := Arg1_Idx + 1;
+ if Arg1_Idx > Arg'Last or else
+ Arg (Arg1_Idx) = ','
+ then
+ Put_Line
+ (Standard_Error,
+ "Malformed Parameter: " &
+ Arg.all);
+ Put (Standard_Error, "usage: ");
+ Put_Line (Standard_Error,
+ Command.Usage.all);
+ raise Error_Exit;
end if;
+ end if;
- end loop;
- end;
- end case;
- end if;
-
- -- Qualifier argument
-
- else
- -- This code is too heavily nested, should be
- -- separated out as separate subprogram ???
+ end loop;
+ end;
+ end case;
+ end if;
- declare
- Sw : Item_Ptr;
- SwP : Natural;
- P2 : Natural;
- Endp : Natural := 0; -- avoid warning!
- Opt : Item_Ptr;
+ -- Qualifier argument
- begin
- SwP := Arg'First;
- while SwP < Arg'Last
- and then Arg (SwP + 1) /= '='
- loop
- SwP := SwP + 1;
- end loop;
+ else
+ -- This code is too heavily nested, should be
+ -- separated out as separate subprogram ???
- -- At this point, the switch name is in
- -- Arg (Arg'First..SwP) and if that is not the
- -- whole switch, then there is an equal sign at
- -- Arg (SwP + 1) and the rest of Arg is what comes
- -- after the equal sign.
-
- -- If make commands are active, see if we have
- -- another COMMANDS_TRANSLATION switch belonging
- -- to gnatmake.
+ declare
+ Sw : Item_Ptr;
+ SwP : Natural;
+ P2 : Natural;
+ Endp : Natural := 0; -- avoid warning!
+ Opt : Item_Ptr;
+
+ begin
+ SwP := Arg'First;
+ while SwP < Arg'Last
+ and then Arg (SwP + 1) /= '='
+ loop
+ SwP := SwP + 1;
+ end loop;
+
+ -- At this point, the switch name is in
+ -- Arg (Arg'First..SwP) and if that is not the
+ -- whole switch, then there is an equal sign at
+ -- Arg (SwP + 1) and the rest of Arg is what comes
+ -- after the equal sign.
+
+ -- If make commands are active, see if we have
+ -- another COMMANDS_TRANSLATION switch belonging
+ -- to gnatmake.
+
+ if Make_Commands_Active /= null then
+ Sw :=
+ Matching_Name
+ (Arg (Arg'First .. SwP),
+ Command.Switches,
+ Quiet => True);
+
+ if Sw /= null
+ and then Sw.Translation = T_Commands
+ then
+ null;
- if Make_Commands_Active /= null then
+ else
Sw :=
Matching_Name
- (Arg (Arg'First .. SwP),
- Command.Switches,
- Quiet => True);
-
- if Sw /= null
- and then Sw.Translation = T_Commands
- then
- null;
-
- else
- Sw :=
- Matching_Name
- (Arg (Arg'First .. SwP),
- Make_Commands_Active.Switches,
- Quiet => False);
- end if;
+ (Arg (Arg'First .. SwP),
+ Make_Commands_Active.Switches,
+ Quiet => False);
+ end if;
-- For case of GNAT MAKE or CHOP, if we cannot
-- find the switch, then see if it is a
-- recognized compiler switch instead, and if
-- so process the compiler switch.
- elsif Command.Name.all = "MAKE"
- or else Command.Name.all = "CHOP" then
+ elsif Command.Name.all = "MAKE"
+ or else Command.Name.all = "CHOP" then
+ Sw :=
+ Matching_Name
+ (Arg (Arg'First .. SwP),
+ Command.Switches,
+ Quiet => True);
+
+ if Sw = null then
Sw :=
Matching_Name
- (Arg (Arg'First .. SwP),
- Command.Switches,
- Quiet => True);
-
- if Sw = null then
- Sw :=
+ (Arg (Arg'First .. SwP),
Matching_Name
- (Arg (Arg'First .. SwP),
- Matching_Name
- ("COMPILE", Commands).Switches,
- Quiet => False);
- end if;
+ ("COMPILE", Commands).Switches,
+ Quiet => False);
+ end if;
-- For all other cases, just search the relevant
-- command.
- else
- Sw :=
- Matching_Name
- (Arg (Arg'First .. SwP),
- Command.Switches,
- Quiet => False);
- end if;
+ else
+ Sw :=
+ Matching_Name
+ (Arg (Arg'First .. SwP),
+ Command.Switches,
+ Quiet => False);
+ end if;
- if Sw /= null then
- case Sw.Translation is
+ if Sw /= null then
+ case Sw.Translation is
- when T_Direct =>
- Place_Unix_Switches (Sw.Unix_String);
- if SwP < Arg'Last
- and then Arg (SwP + 1) = '='
+ when T_Direct =>
+ Place_Unix_Switches (Sw.Unix_String);
+ if SwP < Arg'Last
+ and then Arg (SwP + 1) = '='
+ then
+ Put (Standard_Error,
+ "qualifier options ignored: ");
+ Put_Line (Standard_Error, Arg.all);
+ end if;
+
+ when T_Directories =>
+ if SwP + 1 > Arg'Last then
+ Put (Standard_Error,
+ "missing directories for: ");
+ Put_Line (Standard_Error, Arg.all);
+ Errors := Errors + 1;
+
+ elsif Arg (SwP + 2) /= '(' then
+ SwP := SwP + 2;
+ Endp := Arg'Last;
+
+ elsif Arg (Arg'Last) /= ')' then
+
+ -- Remove spaces from a comma separated
+ -- list of file names and adjust
+ -- control variables accordingly.
+
+ if Arg_Num < Argument_Count and then
+ (Argv (Argv'Last) = ',' xor
+ Argument (Arg_Num + 1)
+ (Argument (Arg_Num + 1)'First) = ',')
then
- Put (Standard_Error,
- "qualifier options ignored: ");
- Put_Line (Standard_Error, Arg.all);
+ Argv :=
+ new String'(Argv.all
+ & Argument
+ (Arg_Num + 1));
+ Arg_Num := Arg_Num + 1;
+ Arg_Idx := Argv'First;
+ Next_Arg_Idx
+ := Get_Arg_End (Argv.all, Arg_Idx);
+ Arg := new String'
+ (Argv (Arg_Idx .. Next_Arg_Idx));
+ goto Tryagain_After_Coalesce;
end if;
- when T_Directories =>
- if SwP + 1 > Arg'Last then
- Put (Standard_Error,
- "missing directories for: ");
- Put_Line (Standard_Error, Arg.all);
- Errors := Errors + 1;
-
- elsif Arg (SwP + 2) /= '(' then
- SwP := SwP + 2;
- Endp := Arg'Last;
-
- elsif Arg (Arg'Last) /= ')' then
-
- -- Remove spaces from a comma separated
- -- list of file names and adjust
- -- control variables accordingly.
-
- if Arg_Num < Argument_Count and then
- (Argv (Argv'Last) = ',' xor
- Argument (Arg_Num + 1)
- (Argument (Arg_Num + 1)'First) = ',')
- then
- Argv :=
- new String'(Argv.all
- & Argument
- (Arg_Num + 1));
- Arg_Num := Arg_Num + 1;
- Arg_Idx := Argv'First;
- Next_Arg_Idx
- := Get_Arg_End (Argv.all, Arg_Idx);
- Arg := new String'
- (Argv (Arg_Idx .. Next_Arg_Idx));
- goto Tryagain_After_Coalesce;
- end if;
+ Put (Standard_Error,
+ "incorrectly parenthesized " &
+ "or malformed argument: ");
+ Put_Line (Standard_Error, Arg.all);
+ Errors := Errors + 1;
+
+ else
+ SwP := SwP + 3;
+ Endp := Arg'Last - 1;
+ end if;
+
+ while SwP <= Endp loop
+ declare
+ Dir_Is_Wild : Boolean := False;
+ Dir_Maybe_Is_Wild : Boolean := False;
+ Dir_List : String_Access_List_Access;
+ begin
+ P2 := SwP;
- Put (Standard_Error,
- "incorrectly parenthesized " &
- "or malformed argument: ");
- Put_Line (Standard_Error, Arg.all);
- Errors := Errors + 1;
+ while P2 < Endp
+ and then Arg (P2 + 1) /= ','
+ loop
- else
- SwP := SwP + 3;
- Endp := Arg'Last - 1;
- end if;
+ -- A wildcard directory spec on
+ -- VMS will contain either * or
+ -- % or ...
+
+ if Arg (P2) = '*' then
+ Dir_Is_Wild := True;
+
+ elsif Arg (P2) = '%' then
+ Dir_Is_Wild := True;
+
+ elsif Dir_Maybe_Is_Wild
+ and then Arg (P2) = '.'
+ and then Arg (P2 + 1) = '.'
+ then
+ Dir_Is_Wild := True;
+ Dir_Maybe_Is_Wild := False;
- while SwP <= Endp loop
- declare
- Dir_Is_Wild : Boolean := False;
- Dir_Maybe_Is_Wild : Boolean := False;
- Dir_List : String_Access_List_Access;
- begin
- P2 := SwP;
-
- while P2 < Endp
- and then Arg (P2 + 1) /= ','
- loop
-
- -- A wildcard directory spec on
- -- VMS will contain either * or
- -- % or ...
-
- if Arg (P2) = '*' then
- Dir_Is_Wild := True;
-
- elsif Arg (P2) = '%' then
- Dir_Is_Wild := True;
-
- elsif Dir_Maybe_Is_Wild
- and then Arg (P2) = '.'
- and then Arg (P2 + 1) = '.'
- then
- Dir_Is_Wild := True;
- Dir_Maybe_Is_Wild := False;
-
- elsif Dir_Maybe_Is_Wild then
- Dir_Maybe_Is_Wild := False;
-
- elsif Arg (P2) = '.'
- and then Arg (P2 + 1) = '.'
- then
- Dir_Maybe_Is_Wild := True;
+ elsif Dir_Maybe_Is_Wild then
+ Dir_Maybe_Is_Wild := False;
- end if;
+ elsif Arg (P2) = '.'
+ and then Arg (P2 + 1) = '.'
+ then
+ Dir_Maybe_Is_Wild := True;
- P2 := P2 + 1;
- end loop;
+ end if;
- if Dir_Is_Wild then
- Dir_List := To_Canonical_File_List
- (Arg (SwP .. P2), True);
-
- for J in Dir_List.all'Range loop
- Place_Unix_Switches
- (Sw.Unix_String);
- Place_Lower
- (Dir_List.all (J).all);
- end loop;
+ P2 := P2 + 1;
+ end loop;
- else
+ if Dir_Is_Wild then
+ Dir_List := To_Canonical_File_List
+ (Arg (SwP .. P2), True);
+
+ for J in Dir_List.all'Range loop
Place_Unix_Switches
(Sw.Unix_String);
Place_Lower
- (To_Canonical_Dir_Spec
- (Arg (SwP .. P2), False).all);
- end if;
-
- SwP := P2 + 2;
- end;
- end loop;
-
- when T_Directory =>
- if SwP + 1 > Arg'Last then
- Put (Standard_Error,
- "missing directory for: ");
- Put_Line (Standard_Error, Arg.all);
- Errors := Errors + 1;
-
- else
- Place_Unix_Switches (Sw.Unix_String);
-
- -- Some switches end in "=". No space
- -- here
+ (Dir_List.all (J).all);
+ end loop;
- if Sw.Unix_String
- (Sw.Unix_String'Last) /= '='
- then
- Place (' ');
+ else
+ Place_Unix_Switches
+ (Sw.Unix_String);
+ Place_Lower
+ (To_Canonical_Dir_Spec
+ (Arg (SwP .. P2), False).all);
end if;
- Place_Lower
- (To_Canonical_Dir_Spec
- (Arg (SwP + 2 .. Arg'Last),
- False).all);
- end if;
-
- when T_File | T_No_Space_File =>
- if SwP + 1 > Arg'Last then
- Put (Standard_Error,
- "missing file for: ");
- Put_Line (Standard_Error, Arg.all);
- Errors := Errors + 1;
-
- else
- Place_Unix_Switches (Sw.Unix_String);
+ SwP := P2 + 2;
+ end;
+ end loop;
- -- Some switches end in "=". No space
- -- here.
+ when T_Directory =>
+ if SwP + 1 > Arg'Last then
+ Put (Standard_Error,
+ "missing directory for: ");
+ Put_Line (Standard_Error, Arg.all);
+ Errors := Errors + 1;
- if Sw.Translation = T_File
- and then Sw.Unix_String
- (Sw.Unix_String'Last) /= '='
- then
- Place (' ');
- end if;
+ else
+ Place_Unix_Switches (Sw.Unix_String);
- Place_Lower
- (To_Canonical_File_Spec
- (Arg (SwP + 2 .. Arg'Last)).all);
- end if;
+ -- Some switches end in "=". No space
+ -- here
- when T_Numeric =>
- if
- OK_Integer (Arg (SwP + 2 .. Arg'Last))
+ if Sw.Unix_String
+ (Sw.Unix_String'Last) /= '='
then
- Place_Unix_Switches (Sw.Unix_String);
- Place (Arg (SwP + 2 .. Arg'Last));
-
- else
- Put (Standard_Error, "argument for ");
- Put (Standard_Error, Sw.Name.all);
- Put_Line
- (Standard_Error, " must be numeric");
- Errors := Errors + 1;
+ Place (' ');
end if;
- when T_Alphanumplus =>
- if
- OK_Alphanumerplus
- (Arg (SwP + 2 .. Arg'Last))
- then
- Place_Unix_Switches (Sw.Unix_String);
- Place (Arg (SwP + 2 .. Arg'Last));
+ Place_Lower
+ (To_Canonical_Dir_Spec
+ (Arg (SwP + 2 .. Arg'Last),
+ False).all);
+ end if;
+
+ when T_File | T_No_Space_File =>
+ if SwP + 1 > Arg'Last then
+ Put (Standard_Error,
+ "missing file for: ");
+ Put_Line (Standard_Error, Arg.all);
+ Errors := Errors + 1;
- else
- Put (Standard_Error, "argument for ");
- Put (Standard_Error, Sw.Name.all);
- Put_Line (Standard_Error,
- " must be alphanumeric");
- Errors := Errors + 1;
- end if;
+ else
+ Place_Unix_Switches (Sw.Unix_String);
- when T_String =>
+ -- Some switches end in "=". No space
+ -- here.
- -- A String value must be extended to the
- -- end of the Argv, otherwise strings like
- -- "foo/bar" get split at the slash.
- --
- -- The begining and ending of the string
- -- are flagged with embedded nulls which
- -- are removed when building the Spawn
- -- call. Nulls are use because they won't
- -- show up in a /? output. Quotes aren't
- -- used because that would make it
- -- difficult to embed them.
+ if Sw.Translation = T_File
+ and then Sw.Unix_String
+ (Sw.Unix_String'Last) /= '='
+ then
+ Place (' ');
+ end if;
+ Place_Lower
+ (To_Canonical_File_Spec
+ (Arg (SwP + 2 .. Arg'Last)).all);
+ end if;
+
+ when T_Numeric =>
+ if
+ OK_Integer (Arg (SwP + 2 .. Arg'Last))
+ then
Place_Unix_Switches (Sw.Unix_String);
- if Next_Arg_Idx /= Argv'Last then
- Next_Arg_Idx := Argv'Last;
- Arg := new String'
- (Argv (Arg_Idx .. Next_Arg_Idx));
-
- SwP := Arg'First;
- while SwP < Arg'Last and then
- Arg (SwP + 1) /= '=' loop
- SwP := SwP + 1;
- end loop;
- end if;
- Place (ASCII.NUL);
Place (Arg (SwP + 2 .. Arg'Last));
- Place (ASCII.NUL);
- when T_Commands =>
+ else
+ Put (Standard_Error, "argument for ");
+ Put (Standard_Error, Sw.Name.all);
+ Put_Line
+ (Standard_Error, " must be numeric");
+ Errors := Errors + 1;
+ end if;
+
+ when T_Alphanumplus =>
+ if
+ OK_Alphanumerplus
+ (Arg (SwP + 2 .. Arg'Last))
+ then
+ Place_Unix_Switches (Sw.Unix_String);
+ Place (Arg (SwP + 2 .. Arg'Last));
- -- Output -largs/-bargs/-cargs
+ else
+ Put (Standard_Error, "argument for ");
+ Put (Standard_Error, Sw.Name.all);
+ Put_Line (Standard_Error,
+ " must be alphanumeric");
+ Errors := Errors + 1;
+ end if;
+
+ when T_String =>
+
+ -- A String value must be extended to the
+ -- end of the Argv, otherwise strings like
+ -- "foo/bar" get split at the slash.
+ --
+ -- The begining and ending of the string
+ -- are flagged with embedded nulls which
+ -- are removed when building the Spawn
+ -- call. Nulls are use because they won't
+ -- show up in a /? output. Quotes aren't
+ -- used because that would make it
+ -- difficult to embed them.
+
+ Place_Unix_Switches (Sw.Unix_String);
+ if Next_Arg_Idx /= Argv'Last then
+ Next_Arg_Idx := Argv'Last;
+ Arg := new String'
+ (Argv (Arg_Idx .. Next_Arg_Idx));
- Place (' ');
- Place (Sw.Unix_String
- (Sw.Unix_String'First ..
- Sw.Unix_String'First + 5));
+ SwP := Arg'First;
+ while SwP < Arg'Last and then
+ Arg (SwP + 1) /= '=' loop
+ SwP := SwP + 1;
+ end loop;
+ end if;
+ Place (ASCII.NUL);
+ Place (Arg (SwP + 2 .. Arg'Last));
+ Place (ASCII.NUL);
- if Sw.Unix_String
- (Sw.Unix_String'First + 7 ..
- Sw.Unix_String'Last) =
- "MAKE"
- then
- Make_Commands_Active := null;
+ when T_Commands =>
- else
- -- Set source of new commands, also
- -- setting this non-null indicates that
- -- we are in the special commands mode
- -- for processing the -xargs case.
-
- Make_Commands_Active :=
- Matching_Name
- (Sw.Unix_String
- (Sw.Unix_String'First + 7 ..
- Sw.Unix_String'Last),
- Commands);
- end if;
+ -- Output -largs/-bargs/-cargs
- when T_Options =>
- if SwP + 1 > Arg'Last then
- Place_Unix_Switches
- (Sw.Options.Unix_String);
- SwP := Endp + 1;
+ Place (' ');
+ Place (Sw.Unix_String
+ (Sw.Unix_String'First ..
+ Sw.Unix_String'First + 5));
+
+ if Sw.Unix_String
+ (Sw.Unix_String'First + 7 ..
+ Sw.Unix_String'Last) =
+ "MAKE"
+ then
+ Make_Commands_Active := null;
+
+ else
+ -- Set source of new commands, also
+ -- setting this non-null indicates that
+ -- we are in the special commands mode
+ -- for processing the -xargs case.
+
+ Make_Commands_Active :=
+ Matching_Name
+ (Sw.Unix_String
+ (Sw.Unix_String'First + 7 ..
+ Sw.Unix_String'Last),
+ Commands);
+ end if;
- elsif Arg (SwP + 2) /= '(' then
- SwP := SwP + 2;
- Endp := Arg'Last;
-
- elsif Arg (Arg'Last) /= ')' then
- Put
- (Standard_Error,
- "incorrectly parenthesized " &
- "argument: ");
- Put_Line (Standard_Error, Arg.all);
- Errors := Errors + 1;
- SwP := Endp + 1;
+ when T_Options =>
+ if SwP + 1 > Arg'Last then
+ Place_Unix_Switches
+ (Sw.Options.Unix_String);
+ SwP := Endp + 1;
- else
- SwP := SwP + 3;
- Endp := Arg'Last - 1;
- end if;
+ elsif Arg (SwP + 2) /= '(' then
+ SwP := SwP + 2;
+ Endp := Arg'Last;
+
+ elsif Arg (Arg'Last) /= ')' then
+ Put
+ (Standard_Error,
+ "incorrectly parenthesized " &
+ "argument: ");
+ Put_Line (Standard_Error, Arg.all);
+ Errors := Errors + 1;
+ SwP := Endp + 1;
+
+ else
+ SwP := SwP + 3;
+ Endp := Arg'Last - 1;
+ end if;
- while SwP <= Endp loop
- P2 := SwP;
+ while SwP <= Endp loop
+ P2 := SwP;
- while P2 < Endp
- and then Arg (P2 + 1) /= ','
- loop
- P2 := P2 + 1;
- end loop;
+ while P2 < Endp
+ and then Arg (P2 + 1) /= ','
+ loop
+ P2 := P2 + 1;
+ end loop;
- -- Option name is in Arg (SwP .. P2)
+ -- Option name is in Arg (SwP .. P2)
- Opt := Matching_Name (Arg (SwP .. P2),
- Sw.Options);
+ Opt := Matching_Name (Arg (SwP .. P2),
+ Sw.Options);
- if Opt /= null then
- Place_Unix_Switches
- (Opt.Unix_String);
- end if;
+ if Opt /= null then
+ Place_Unix_Switches
+ (Opt.Unix_String);
+ end if;
- SwP := P2 + 2;
- end loop;
+ SwP := P2 + 2;
+ end loop;
- when T_Other =>
- Place_Unix_Switches
- (new String'(Sw.Unix_String.all &
- Arg.all));
+ when T_Other =>
+ Place_Unix_Switches
+ (new String'(Sw.Unix_String.all &
+ Arg.all));
- end case;
- end if;
- end;
- end if;
+ end case;
+ end if;
+ end;
+ end if;
- Arg_Idx := Next_Arg_Idx + 1;
- end;
+ Arg_Idx := Next_Arg_Idx + 1;
+ end;
- exit when Arg_Idx > Argv'Last;
+ exit when Arg_Idx > Argv'Last;
- end loop;
+ end loop;
end Process_Argument;
Arg_Num := Arg_Num + 1;
Index: vms_data.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/vms_data.ads,v
retrieving revision 1.2
diff -u -r1.2 vms_data.ads
--- vms_data.ads 10 Nov 2003 17:30:00 -0000 1.2
+++ vms_data.ads 13 Nov 2003 22:38:23 -0000
@@ -1591,6 +1591,17 @@
-- communicated to the compiler through logical names
-- ADA_PRJ_INCLUDE_FILE and ADA_PRJ_OBJECTS_FILE.
+ S_GCC_Psta : aliased constant S := "/PRINT_STANDARD " &
+ "-gnatS";
+ -- /PRINT_STANDARD
+ --
+ -- cause the compiler to output a representation of package Standard
+ -- in a form very close to standard Ada. It is not quite possible to
+ -- do this and remain entirely Standard (since new numeric base types
+ -- cannot be created in standard Ada), but the output is easily
+ -- readable to any Ada programmer, and is useful to determine the
+ -- characteristics of target dependent types in package Standard.
+
S_GCC_Report : aliased constant S := "/REPORT_ERRORS=" &
"VERBOSE " &
"-gnatv " &
@@ -2278,10 +2289,6 @@
"-gnatwA " &
"ALL_GCC " &
"-Wall " &
- "BIASED_ROUNDING " &
- "-gnatwb " &
- "NOBIASED_ROUNDING " &
- "-gnatwB " &
"CONDITIONALS " &
"-gnatwc " &
"NOCONDITIONALS " &
@@ -2399,30 +2406,6 @@
-- backend. Most of these are not relevant
-- to Ada.
--
- -- BIASED_ROUNDING Activate warnings on biased rounding.
- -- If a static floating-point expression has
- -- a value that is exactly half way between
- -- two adjacent machine numbers, then the
- -- rules of Ada (Ada Reference Manual,
- -- para 4.9(38)) require that this rounding
- -- be done away from zero, even if the normal
- -- unbiased rounding rules at run time would
- -- require rounding towards zero.
- --
- -- This warning message alerts you to such
- -- instances where compile-time rounding and
- -- run-time rounding are not equivalent.
- -- If it is important to get proper run-time
- -- rounding, then you can force this by
- -- making one of the operands into a
- -- variable. The default is that such
- -- warnings are not generated. Note that
- -- /WARNINGS=ALL does not affect the setting
- -- of this warning option.
- --
- -- NOBIASED_ROUNDING Suppress warnings on biased rounding.
- -- Disable warnings on biased rounding.
- --
-- CONDITIONALS Activate warnings for conditional
-- Expressions used in tests that are known
-- to be True or False at compile time. The
@@ -2820,6 +2803,7 @@
S_GCC_OptX 'Access,
S_GCC_Polling 'Access,
S_GCC_Project 'Access,
+ S_GCC_Psta 'Access,
S_GCC_Report 'Access,
S_GCC_ReportX 'Access,
S_GCC_Repinfo 'Access,
@@ -4642,12 +4626,6 @@
S_Shared_Noinhib 'Access,
S_Shared_Verb 'Access,
S_Shared_ZZZZZ 'Access);
-
- --------------------------------
- -- Switches for GNAT STANDARD --
- --------------------------------
-
- Standard_Switches : aliased constant Switches := (1 .. 0 => null);
----------------------------
-- Switches for GNAT STUB --