MatCat.OpenSource/8sa1-gcc
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
1b096a0a0a
8sa1-gcc/gcc/ada/gprcmd.adb
Arnaud Charlet 6cdb2c6e80 [multiple changes] 
2004-08-31  Richard Kenner  <kenner@vlsi1.ultra.nyu.edu>

	* misc.c (gnat_print_type): Use TYPE_RM_SIZE_NUM.

	* trans.c (struct stmt_group): Delete field GLOBAL.
	(gnat_init_stmt_group): Do not initialize it.
	(call_to_gnu): Use save_expr, not protect_multiple_eval.
	(Exception_Handler_to_gnu_sjlj): Call build_int_cst, not build_int_2
	(gnat_to_gnu, case N_Character_Literal, N_String_Literal): Likewise.
	(gnat_to_gnu, case N_Compilation_Unit): Do not set GLOBAL in stmt group.
	(start_stmt_group): Likewise.
	(add_stmt, add_decl_expr): Rework handling of global DECL_EXPRs.

	* utils2.c (ggc.h): Include.
	(build_call_raise): Call build_int_cst, not build_int_2.

	* utils.c (gnat_init_decl_processing): Fix arg to
	build_common_tree_nodes.
	(create_subprog_type): Do not use SET_TYPE_CI_CO_LIST.
	(gnat_define_builtin): Set built_in_decls.
	(init_gigi_decls): Call build_int_cst, not build_int_2.

	* ada-tree.h (struct lang_decl, struct lang_type): Field is type tree.
	(GET_TYPE_LANG_SPECIFIC, SET_TYPE_LANG_SPECIFIC): New macros.
	(GET_DECL_LANG_SPECIFIC, SET_DECL_LANG_SPECIFIC): Likewise.
	(TYPE_CI_CO_LIST, SET_TYPE_CI_CO_LIST, TYPE_MODULE,
	SET_TYPE_MODULE): Use them.
	(TYPE_INDEX_TYPE, SET_TYPE_INDEX_TYPE, TYPE_DIGITS_VALUE): Likewise.
	(SET_TYPE_DIGITS_VALUE, TYPE_UNCONSTRAINED_ARRAY): Likewise.
	(SET_TYPE_UNCONSTRAINED_ARRAY, TYPE_ADA_SIZE,
	SET_TYPE_ADA_SIZE): Likewise.
	(TYPE_ACTUAL_BOUNDS, SET_TYPE_ACTUAL_BOUNDS): Likewise.
	(DECL_CONST_CORRESPONDING_VAR,
	SET_DECL_CONST_CORRESPONDING_VAR): Likewise.
	(DECL_ORIGINAL_FIELD, SET_DECL_ORIGINAL_FIELD): Likewise.
	(TYPE_RM_SIZE_INT, TYPE_RM_SIZE_ENUM, SET_TYPE_RM_SIZE_ENUM): Deleted.
	(TYPE_RM_SIZE_NUM): New macro.
	(TYPE_RM_SIZE): Modified to use above.

	* cuintp.c: (build_cst_from_int): New function.
	(UI_To_gnu): Use it.

	* decl.c (gnat_to_gnu_entity): Use TYPE_RM_SIZE_NUM.
	(make_type_from_size): Avoid changing TYPE_UNSIGNED of a type.
	(gnat_substitute_in_type, case ARRAY_TYPE): If old had a
	MIN_EXPR for the size, copy it into new.

2004-08-31  Robert Dewar  <dewar@gnat.com>

	* exp_ch6.adb (Expand_Call): Properly handle validity checks for
	packed indexed component where array is an IN OUT formal. This
	generated garbage code previously.

	* gnat_ugn.texi: Document -fverbose-asm

	* gnat-style.texi: Minor updates (note that boolean constants and
	variables are joined with AND/OR rather than short circuit forms).

2004-08-31  Ed Schonberg  <schonberg@gnat.com>

	* exp_util.adb (Safe_Unchecked_Type_Conversion): Conversion is safe if
	it is an upward conversion of an untagged type with no representation
	change.

2004-08-31  Thomas Quinot  <quinot@act-europe.fr>

	* rtsfind.ads: Move RCI_Subp_Info and RCI_Subp_Info_Array to
	System.Partition_Interface.

	* checks.adb (Apply_Access_Checks): Do not generate checks when
	expander is not active (but check for unset reference to prefix of
	dereference).

	* sem_prag.adb (Analyze_Pragma, case Pragma_Debug): Uniformly rewrite
	pragma Debug as an if statement with a constant condition, for
	consistent treatment of entity references contained within the
	enclosed procedure call.

2004-08-31  Vincent Celier  <celier@gnat.com>

	* bindgen.adb: (Set_EA_Last): New procedure
	(Gen_Exception_Table_Ada, Gen_Exception_Table_C): Use new procedure
	Set_EA_Last.
	(Gen_Adafinal_Ada): If no finalization, adafinal does nothing
	(Gen_Output_File_Ada): Always call Gen_Adafinal_Ada, so that SAL can be
	linked without errors.
	(Gen_Exception_Table_Ada): Correct bugs when generating code for arrays
	ST and EA.
	(Gen_Exception_Table_C): Correct same bugs

	* vms_data.ads: Add new qualifier /VERBOSE_ASM to GCC_Switches

	* g-os_lib.adb (Normalize_Pathname.Get_Directory): When Dir is empty,
	on Windows, make sure that the drive letter is in upper case.

	* g-os_lib.ads (Normalize_Pathname): Add a comment to indicate that on
	Windows, when the drive letter is added and Case_Sensitive is True, the
	drive letter is forced to upper case.

	* mlib-tgt-irix.adb (Build_Dynamic_Library): Transfer all -lxxx options
	to Options_2 for the call to MLib.Utl.Gcc.

	* bld.adb (Put_Include_Project): Use '/', not '\' on Windows as
	directory separator when defining BASE_DIR.

2004-08-19  Pascal Obry  <obry@gnat.com>

	* gprcmd.adb (Extend): Do not output trailing directory separator. This
	is not needed and it confuses Windows GNU/make which does not report
	directory terminated by a slash as a directory.
	(gprcmd): Idem for "pwd" internal command.

	* Makefile.generic: Use __GPRCOLON__ instead of pipe character in
	target names rewrite to fix regressions with recent version of
	GNU/make. Starting with GNU/make 3.80 the pipe character was not
	handled properly anymore.

From-SVN: r86883
2004-09-01 13:51:54 +02:00

614 lines
19 KiB
Ada
Raw Blame History

------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- G P R C M D --
-- --
-- B o d y --
-- --
-- Copyright (C) 2002-2004 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- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- A utility used by Makefile.generic to handle multi-language builds.
-- gprcmd provides a set of commands so that the makefiles do not need
-- to depend on unix utilities not available on all targets.
-- The list of commands recognized by gprcmd are:
-- pwd display current directory
-- to_lower display next argument in lower case
-- to_absolute convert pathnames to absolute directories when needed
-- cat dump contents of a given file
-- extend handle recursive directories ("/**" notation)
-- deps post process dependency makefiles
-- stamp copy file time stamp from file1 to file2
-- prefix get the prefix of the GNAT installation
-- path convert a list of directories to a path list, inserting a
-- path separator after each directory, including the last one
-- ignore do nothing
with Gnatvsn;
with Osint; use Osint;
with Namet; use Namet;
with Ada.Characters.Handling; use Ada.Characters.Handling;
with Ada.Command_Line; use Ada.Command_Line;
with Ada.Text_IO; use Ada.Text_IO;
with GNAT.OS_Lib; use GNAT.OS_Lib;
with GNAT.Directory_Operations; use GNAT.Directory_Operations;
with GNAT.Regpat; use GNAT.Regpat;
procedure Gprcmd is
-- ??? comments are thin throughout this unit
Gprdebug : constant String := To_Lower (Getenv ("GPRDEBUG").all);
Debug : constant Boolean := Gprdebug = "true";
-- When Debug is True, gprcmd displays its arguments to Standard_Error.
-- This is to help to debug.
procedure Cat (File : String);
-- Print the contents of file on standard output.
-- If the file cannot be read, exit the process with an error code.
procedure Check_Args (Condition : Boolean);
-- If Condition is false, print command invoked, then the usage,
-- and exit the process.
procedure Deps (Objext : String; File : String; GCC : Boolean);
-- Process $(CC) dependency file. If GCC is True, add a rule so that make
-- will not complain when a file is removed/added. If GCC is False, add a
-- rule to recompute the dependency file when needed
procedure Extend (Dir : String);
-- If Dir ends with /**, Put all subdirs recursively on standard output,
-- otherwise put Dir.
procedure Usage;
-- Display the command line options and exit the process.
procedure Copy_Time_Stamp (From, To : String);
-- Copy file time stamp from file From to file To.
procedure Display_Command;
-- Display the invoked command to Standard_Error
---------
-- Cat --
---------
procedure Cat (File : String) is
FD : File_Descriptor;
Buffer : String_Access;
Length : Integer;
begin
FD := Open_Read (File, Fmode => Binary);
if FD = Invalid_FD then
OS_Exit (2);
end if;
Length := Integer (File_Length (FD));
Buffer := new String (1 .. Length);
Length := Read (FD, Buffer.all'Address, Length);
Close (FD);
Put (Buffer.all);
Free (Buffer);
end Cat;
----------------
-- Check_Args --
----------------
procedure Check_Args (Condition : Boolean) is
begin
if not Condition then
Put_Line
(Standard_Error,
"bad call to gprcmd with" & Argument_Count'Img & " arguments.");
for J in 0 .. Argument_Count loop
Put (Standard_Error, Argument (J) & " ");
end loop;
New_Line (Standard_Error);
Usage;
end if;
end Check_Args;
---------------------
-- Copy_Time_Stamp --
---------------------
procedure Copy_Time_Stamp (From, To : String) is
function Copy_Attributes
(From, To : String;
Mode : Integer) return Integer;
pragma Import (C, Copy_Attributes, "__gnat_copy_attribs");
-- Mode = 0 - copy only time stamps.
-- Mode = 1 - copy time stamps and read/write/execute attributes
FD : File_Descriptor;
begin
if not Is_Regular_File (From) then
return;
end if;
FD := Create_File (To, Fmode => Binary);
if FD = Invalid_FD then
OS_Exit (2);
end if;
Close (FD);
if Copy_Attributes (From & ASCII.NUL, To & ASCII.NUL, 0) /= 0 then
OS_Exit (2);
end if;
end Copy_Time_Stamp;
----------
-- Deps --
----------
procedure Deps (Objext : String; File : String; GCC : Boolean) is
Colon : constant String := ':' & ASCII.LF;
NL : constant String := (1 => ASCII.LF);
Base : constant String := ' ' & Base_Name (File) & ": ";
FD : File_Descriptor;
Buffer : String_Access;
Length : Integer;
Obj_Regexp : constant Pattern_Matcher :=
Compile ("^.*\" & Objext & ": ");
Matched : Match_Array (0 .. 0);
Start : Natural;
First : Natural;
Last : Natural;
begin
FD := Open_Read_Write (File, Fmode => Binary);
if FD = Invalid_FD then
return;
end if;
Length := Integer (File_Length (FD));
Buffer := new String (1 .. Length);
Length := Read (FD, Buffer.all'Address, Length);
if GCC then
Lseek (FD, 0, Seek_End);
else
Close (FD);
FD := Create_File (File, Fmode => Binary);
end if;
Start := Buffer'First;
while Start <= Buffer'Last loop
-- Parse Buffer line by line
while Start < Buffer'Last
and then (Buffer (Start) = ASCII.CR
or else Buffer (Start) = ASCII.LF)
loop
Start := Start + 1;
end loop;
Last := Start;
while Last < Buffer'Last
and then Buffer (Last + 1) /= ASCII.CR
and then Buffer (Last + 1) /= ASCII.LF
loop
Last := Last + 1;
end loop;
Match (Obj_Regexp, Buffer (Start .. Last), Matched);
if GCC then
if Matched (0) = No_Match then
First := Start;
else
First := Matched (0).Last + 1;
end if;
Length := Write (FD, Buffer (First)'Address, Last - First + 1);
if Start = Last or else Buffer (Last) = '\' then
Length := Write (FD, NL (1)'Address, NL'Length);
else
Length := Write (FD, Colon (1)'Address, Colon'Length);
end if;
else
if Matched (0) = No_Match then
First := Start;
else
Length :=
Write (FD, Buffer (Start)'Address,
Matched (0).Last - Start - 1);
Length := Write (FD, Base (Base'First)'Address, Base'Length);
First := Matched (0).Last + 1;
end if;
Length := Write (FD, Buffer (First)'Address, Last - First + 1);
Length := Write (FD, NL (1)'Address, NL'Length);
end if;
Start := Last + 1;
end loop;
Close (FD);
Free (Buffer);
end Deps;
---------------------
-- Display_Command --
---------------------
procedure Display_Command is
begin
for J in 0 .. Argument_Count loop
Put (Standard_Error, Argument (J) & ' ');
end loop;
New_Line (Standard_Error);
end Display_Command;
------------
-- Extend --
------------
procedure Extend (Dir : String) is
procedure Recursive_Extend (D : String);
-- Recursively display all subdirectories of D
----------------------
-- Recursive_Extend --
----------------------
procedure Recursive_Extend (D : String) is
Iter : Dir_Type;
Buffer : String (1 .. 8192);
Last : Natural;
begin
Open (Iter, D);
loop
Read (Iter, Buffer, Last);
exit when Last = 0;
if Buffer (1 .. Last) /= "."
and then Buffer (1 .. Last) /= ".."
then
declare
Abs_Dir : constant String := D & "/" & Buffer (1 .. Last);
begin
if Is_Directory (Abs_Dir)
and then not Is_Symbolic_Link (Abs_Dir)
then
Put (' ' & Abs_Dir);
Recursive_Extend (Abs_Dir);
end if;
end;
end if;
end loop;
Close (Iter);
exception
when Directory_Error =>
null;
end Recursive_Extend;
-- Start of processing for Extend
begin
if Dir'Length < 3
or else (Dir (Dir'Last - 2) /= '/'
and then Dir (Dir'Last - 2) /= Directory_Separator)
or else Dir (Dir'Last - 1 .. Dir'Last) /= "**"
then
Put (Dir);
return;
end if;
declare
D : constant String := Dir (Dir'First .. Dir'Last - 3);
begin
Put (D);
Recursive_Extend (D);
end;
end Extend;
-----------
-- Usage --
-----------
procedure Usage is
begin
Put_Line (Standard_Error, "usage: gprcmd cmd [arguments]");
Put_Line (Standard_Error, "where cmd is one of the following commands:");
Put_Line (Standard_Error, " pwd " &
"display current directory");
Put_Line (Standard_Error, " to_lower " &
"display next argument in lower case");
Put_Line (Standard_Error, " to_absolute " &
"convert pathnames to absolute " &
"directories when needed");
Put_Line (Standard_Error, " cat " &
"dump contents of a given file");
Put_Line (Standard_Error, " extend " &
"handle recursive directories " &
"(""/**"" notation)");
Put_Line (Standard_Error, " deps " &
"post process dependency makefiles");
Put_Line (Standard_Error, " stamp " &
"copy file time stamp from file1 to file2");
Put_Line (Standard_Error, " prefix " &
"get the prefix of the GNAT installation");
Put_Line (Standard_Error, " path_sep " &
"returns the path separator");
Put_Line (Standard_Error, " linkopts " &
"process attribute Linker'Linker_Options");
Put_Line (Standard_Error, " ignore " &
"do nothing");
OS_Exit (1);
end Usage;
-- Start of processing for Gprcmd
begin
if Debug then
Display_Command;
end if;
Check_Args (Argument_Count > 0);
declare
Cmd : constant String := Argument (1);
begin
if Cmd = "-v" then
-- Output on standard error, because only returned values should
-- go to standard output.
Put (Standard_Error, "GPRCMD ");
Put (Standard_Error, Gnatvsn.Gnat_Version_String);
Put_Line (Standard_Error,
" Copyright 2002-2004, Free Software Fundation, Inc.");
Usage;
elsif Cmd = "pwd" then
declare
CD : constant String := Get_Current_Dir;
begin
Put (Format_Pathname (CD (CD'First .. CD'Last - 1), UNIX));
end;
elsif Cmd = "cat" then
Check_Args (Argument_Count = 2);
Cat (Argument (2));
elsif Cmd = "to_lower" then
Check_Args (Argument_Count >= 2);
for J in 2 .. Argument_Count loop
Put (To_Lower (Argument (J)));
if J < Argument_Count then
Put (' ');
end if;
end loop;
elsif Cmd = "to_absolute" then
Check_Args (Argument_Count > 2);
declare
Dir : constant String := Argument (2);
begin
for J in 3 .. Argument_Count loop
if Is_Absolute_Path (Argument (J)) then
Put (Format_Pathname (Argument (J), UNIX));
else
Put (Format_Pathname
(Normalize_Pathname
(Format_Pathname (Argument (J)),
Format_Pathname (Dir)),
UNIX));
end if;
if J < Argument_Count then
Put (' ');
end if;
end loop;
end;
elsif Cmd = "extend" then
Check_Args (Argument_Count >= 2);
declare
Dir : constant String := Argument (2);
begin
-- Loop to remove quotes that may have been added around arguments
for J in 3 .. Argument_Count loop
declare
Arg : constant String := Argument (J);
First : Natural := Arg'First;
Last : Natural := Arg'Last;
begin
if Arg (First) = '"' and then Arg (Last) = '"' then
First := First + 1;
Last := Last - 1;
end if;
if Is_Absolute_Path (Arg (First .. Last)) then
Extend (Format_Pathname (Arg (First .. Last), UNIX));
else
Extend
(Format_Pathname
(Normalize_Pathname
(Format_Pathname (Arg (First .. Last)),
Format_Pathname (Dir)),
UNIX));
end if;
if J < Argument_Count then
Put (' ');
end if;
end;
end loop;
end;
elsif Cmd = "deps" then
Check_Args (Argument_Count in 3 .. 4);
Deps (Argument (2), Argument (3), GCC => Argument_Count = 4);
elsif Cmd = "stamp" then
Check_Args (Argument_Count = 3);
Copy_Time_Stamp (Argument (2), Argument (3));
elsif Cmd = "prefix" then
-- Find the GNAT prefix. gprcmd is found in <prefix>/bin.
-- So we find the full path of gprcmd, verify that it is in a
-- subdirectory "bin", and return the <prefix> if it is the case.
-- Otherwise, nothing is returned.
Find_Program_Name;
declare
Path : constant String_Access :=
Locate_Exec_On_Path (Name_Buffer (1 .. Name_Len));
Index : Natural;
begin
if Path /= null then
Index := Path'Last;
while Index >= Path'First + 4 loop
exit when Path (Index) = Directory_Separator;
Index := Index - 1;
end loop;
if Index > Path'First + 5
and then Path (Index - 3 .. Index - 1) = "bin"
and then Path (Index - 4) = Directory_Separator
then
-- We have found the <prefix>, return it
Put (Path (Path'First .. Index - 5));
end if;
end if;
end;
-- For "path" just add path separator after each directory argument
elsif Cmd = "path_sep" then
Put (Path_Separator);
-- Check the linker options for relative paths. Insert the project
-- base dir before relative paths.
elsif Cmd = "linkopts" then
Check_Args (Argument_Count >= 2);
-- First argument is the base directory of the project file
declare
Base_Dir : constant String := Argument (2) & '/';
begin
-- process the remainder of the arguments
for J in 3 .. Argument_Count loop
declare
Arg : constant String := Argument (J);
begin
-- If it is a switch other than a -L switch, just send back
-- the argument.
if Arg (Arg'First) = '-' and then
(Arg'Length <= 2 or else Arg (Arg'First + 1) /= 'L')
then
Put (Arg);
else
-- If it is a file, check if its path is relative, and
-- if it is relative, add <project base dir>/ in front.
-- Otherwise just send back the argument.
if Arg'Length <= 2
or else Arg (Arg'First .. Arg'First + 1) /= "-L"
then
if not Is_Absolute_Path (Arg) then
Put (Base_Dir);
end if;
Put (Arg);
-- For -L switches, check if the path is relative and
-- proceed similarly.
else
Put ("-L");
if
not Is_Absolute_Path (Arg (Arg'First + 2 .. Arg'Last))
then
Put (Base_Dir);
end if;
Put (Arg (Arg'First + 2 .. Arg'Last));
end if;
end if;
end;
-- Insert a space between each processed argument
if J /= Argument_Count then
Put (' ');
end if;
end loop;
end;
-- For "ignore" do nothing
elsif Cmd = "ignore" then
null;
-- Unknown command
else
Check_Args (False);
end if;
end;
end Gprcmd;
Reference in New Issue View Git Blame Copy Permalink