+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- G N A T _ W R A P P E R --
--- --
--- B o d y --
--- --
--- Copyright (C) 2002-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- --
--- 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. --
--- --
-------------------------------------------------------------------------------
-
--- GNAT_Wrapper is to be used as the starter program for most of the GNAT
--- executables. It sets up the working environment variables and calls the
--- real executable which is to be found under the 'real' sub-directory.
---
--- This avoids using the registry on Windows which is tricky to setup to run
--- multiple compilers (GNAT Pro release and wavefronts for example) at the
--- same time.
-
-with Ada.Command_Line; use Ada.Command_Line;
-with GNAT.OS_Lib; use GNAT.OS_Lib;
-
-procedure GNAT_Wrapper is
- DS : Character renames Directory_Separator;
- PS : Character renames Path_Separator;
-
- procedure Split_Command;
- -- Parse Actual_Name and set K and L variables (see below).
-
- Actual_Name : String_Access := new String'(Command_Name);
-
- K : Natural;
- -- Index of the directory separator just before program name's first
- -- character.
-
- L : Natural;
- -- Index of the last character of the GNATPRO install directory.
-
- LD_LIBRARY_PATH : String_Access := Getenv ("LD_LIBRARY_PATH");
- PATH : String_Access := Getenv ("PATH");
-
- -------------------
- -- Split_Command --
- -------------------
-
- procedure Split_Command is
- begin
- K := Actual_Name'Last;
- loop
- exit when K = 0
- or else Actual_Name (K) = '\' or else Actual_Name (K) = '/';
- K := K - 1;
- end loop;
- end Split_Command;
-
-begin
- Split_Command;
-
- if K = 0 then
- -- No path information found, locate the program on the path.
- declare
- Old : String_Access := Actual_Name;
- begin
- Actual_Name := Locate_Exec_On_Path (Actual_Name.all);
- Free (Old);
-
- Split_Command;
- end;
- end if;
-
- -- Skip 'bin' from directory above. GNAT binaries are always under
- -- <gnatpro>/bin directory.
-
- L := K - 4;
-
- declare
- Prog : constant String := Actual_Name (K + 1 .. Actual_Name'Last);
- Dir : constant String := Actual_Name (Actual_Name'First .. L - 1);
- Real : constant String := Dir & DS & ".bin";
- Bin : constant String := Dir & DS & "bin";
- Args : Argument_List (1 .. Argument_Count);
- Result : Integer;
-
- begin
- Setenv ("GCC_ROOT", Dir);
- Setenv ("GNAT_ROOT", Dir);
- Setenv ("BINUTILS_ROOT", Dir);
- Setenv ("LD_LIBRARY_PATH", Dir & DS & "lib" & PS & LD_LIBRARY_PATH.all);
- Setenv ("PATH", Real & PS & Bin & PS & PATH.all);
-
- -- Call the right executable under "<dir>/.bin"
-
- for K in 1 .. Argument_Count loop
- Args (K) := new String'(Argument (K));
- end loop;
-
- Normalize_Arguments (Args);
- Result := Spawn (Real & DS & Prog, Args);
-
- for K in 1 .. Argument_Count loop
- Free (Args (K));
- end loop;
-
- OS_Exit (Result);
- end;
-end GNAT_Wrapper;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT SYSTEM UTILITIES --
--- --
--- G N A T P S T A --
--- --
--- B o d y --
--- --
--- 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- --
--- 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. --
--- --
-------------------------------------------------------------------------------
-
--- Program to print out listing of Standard package for the target (not
--- the host) with all constants appearing explicitly. This is not really
--- valid Ada, since one cannot really define new base types, but it is a
--- helpful listing from a documentation point of view.
-
--- Note that special care has been taken to use the host parameters for
--- integer and floating point sizes.
-
-with Ada.Text_IO; use Ada.Text_IO;
-with Gnatvsn;
-with Ttypef; use Ttypef;
-with Ttypes; use Ttypes;
-with Types; use Types;
-
-procedure GnatPsta is
- pragma Ident (Gnatvsn.Gnat_Static_Version_String);
-
- procedure P (Item : String) renames Ada.Text_IO.Put_Line;
-
- procedure P_Int_Range (Size : Pos; Put_First : Boolean := True);
- -- Prints the range of an integer based on its Size. If Put_First is
- -- False, then skip the first bound.
-
- procedure P_Float_Range (Nb_Digits : Pos);
- -- Prints the maximum range of a Float whose 'Digits is given by Nb_Digits
-
- -------------------
- -- P_Float_Range --
- -------------------
-
- procedure P_Float_Range (Nb_Digits : Pos) is
- begin
- -- This routine assumes only IEEE floats.
- -- ??? Should the following be adapted for OpenVMS ?
-
- case Nb_Digits is
- when IEEES_Digits =>
- P (" range " & IEEES_First'Universal_Literal_String & " .. " &
- IEEES_Last'Universal_Literal_String & ";");
- when IEEEL_Digits =>
- P (" range " & IEEEL_First'Universal_Literal_String & " .. " &
- IEEEL_Last'Universal_Literal_String & ";");
- when IEEEX_Digits =>
- P (" range " & IEEEX_First'Universal_Literal_String & " .. " &
- IEEEX_Last'Universal_Literal_String & ";");
-
- when others =>
- P (";");
- end case;
-
- -- If one of the floating point types of the host computer has the
- -- same digits as the target float we are processing, then print out
- -- the float range using the host computer float type.
-
- if Nb_Digits = Short_Float'Digits then
- P (" -- " &
- Short_Float'First'Img & " .. " & Short_Float'Last'Img);
-
- elsif Nb_Digits = Float'Digits then
- P (" -- " &
- Float'First'Img & " .. " & Float'Last'Img);
-
- elsif Nb_Digits = Long_Float'Digits then
- P (" -- " &
- Long_Float'First'Img & " .. " & Long_Float'Last'Img);
-
- elsif Nb_Digits = Long_Long_Float'Digits then
- P (" -- " &
- Long_Long_Float'First'Img & " .. " & Long_Long_Float'Last'Img);
- end if;
-
- New_Line;
- end P_Float_Range;
-
- -----------------
- -- P_Int_Range --
- -----------------
-
- procedure P_Int_Range (Size : Pos; Put_First : Boolean := True) is
- begin
- if Put_First then
- Put (" is range -(2 **" & Pos'Image (Size - 1) & ")");
- end if;
- P (" .. +(2 **" & Pos'Image (Size - 1) & " - 1);");
- end P_Int_Range;
-
--- Start of processing for GnatPsta
-
-begin
- P ("package Standard is");
- P ("pragma Pure(Standard);");
- New_Line;
-
- P (" type Boolean is (False, True);");
- New_Line;
-
- -- Integer types
-
- Put (" type Integer");
- P_Int_Range (Standard_Integer_Size);
- New_Line;
-
- Put (" subtype Natural is Integer range 0");
- P_Int_Range (Standard_Integer_Size, Put_First => False);
-
- Put (" subtype Positive is Integer range 1");
- P_Int_Range (Standard_Integer_Size, Put_First => False);
- New_Line;
-
- Put (" type Short_Short_Integer");
- P_Int_Range (Standard_Short_Short_Integer_Size);
-
- Put (" type Short_Integer ");
- P_Int_Range (Standard_Short_Integer_Size);
-
- Put (" type Long_Integer ");
- P_Int_Range (Standard_Long_Integer_Size);
-
- Put (" type Long_Long_Integer ");
- P_Int_Range (Standard_Long_Long_Integer_Size);
- New_Line;
-
- -- Floating point types
-
- P (" type Short_Float is digits"
- & Standard_Short_Float_Digits'Img);
- P_Float_Range (Standard_Short_Float_Digits);
-
- P (" type Float is digits"
- & Standard_Float_Digits'Img);
- P_Float_Range (Standard_Float_Digits);
-
- P (" type Long_Float is digits"
- & Standard_Long_Float_Digits'Img);
- P_Float_Range (Standard_Long_Float_Digits);
-
- P (" type Long_Long_Float is digits"
- & Standard_Long_Long_Float_Digits'Img);
- P_Float_Range (Standard_Long_Long_Float_Digits);
-
- P (" -- function ""*"" (Left : root_integer; Right : root_real)");
- P (" -- return root_real;");
- New_Line;
-
- P (" -- function ""*"" (Left : root_real; Right : root_integer)");
- P (" -- return root_real;");
- New_Line;
-
- P (" -- function ""/"" (Left : root_real; Right : root_integer)");
- P (" -- return root_real;");
- New_Line;
-
- P (" -- function ""*"" (Left : universal_fixed; " &
- "Right : universal_fixed)");
- P (" -- return universal_fixed;");
- New_Line;
-
- P (" -- function ""/"" (Left : universal_fixed; " &
- "Right : universal_fixed)");
- P (" -- return universal_fixed;");
- New_Line;
-
- P (" -- The declaration of type Character is based on the standard");
- P (" -- ISO 8859-1 character set.");
- New_Line;
-
- P (" -- There are no character literals corresponding to the positions");
- P (" -- for control characters. They are indicated by lower case");
- P (" -- identifiers in the following list.");
- New_Line;
-
- P (" -- Note: this type cannot be represented accurately in Ada");
- New_Line;
-
- P (" -- type Character is");
- New_Line;
-
- P (" -- (nul, soh, stx, etx, eot, enq, ack, bel,");
- P (" -- bs, ht, lf, vt, ff, cr, so, si,");
- New_Line;
-
- P (" -- dle, dc1, dc2, dc3, dc4, nak, syn, etb,");
- P (" -- can, em, sub, esc, fs, gs, rs, us,");
- New_Line;
-
- P (" -- ' ', '!', '""', '#', '$', '%', '&', ''',");
- P (" -- '(', ')', '*', '+', ',', '-', '.', '/',");
- New_Line;
-
- P (" -- '0', '1', '2', '3', '4', '5', '6', '7',");
- P (" -- '8', '9', ':', ';', '<', '=', '>', '?',");
- New_Line;
-
- P (" -- '@', 'A', 'B', 'C', 'D', 'E', 'F', 'G',");
- P (" -- 'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O',");
- New_Line;
-
- P (" -- 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W',");
- P (" -- 'X', 'Y', 'Z', '[', '\', ']', '^', '_',");
- New_Line;
-
- P (" -- '`', 'a', 'b', 'c', 'd', 'e', 'f', 'g',");
- P (" -- 'h', 'i', 'j', 'k', 'l', 'm', 'n', 'o',");
- New_Line;
-
- P (" -- 'p', 'q', 'r', 's', 't', 'u', 'v', 'w',");
- P (" -- 'x', 'y', 'z', '{', '|', '}', '~', del,");
- New_Line;
-
- P (" -- reserved_128, reserved_129, bph, nbh,");
- P (" -- reserved_132, nel, ssa, esa,");
- New_Line;
-
- P (" -- hts, htj, vts, pld, plu, ri, ss2, ss3,");
- New_Line;
-
- P (" -- dcs, pu1, pu2, sts, cch, mw, spa, epa,");
- New_Line;
-
- P (" -- sos, reserved_153, sci, csi,");
- P (" -- st, osc, pm, apc,");
- New_Line;
-
- P (" -- ... );");
- New_Line;
-
- P (" -- The declaration of type Wide_Character is based " &
- "on the standard");
- P (" -- ISO 10646 BMP character set.");
- New_Line;
-
- P (" -- Note: this type cannot be represented accurately in Ada");
- New_Line;
-
- P (" -- The first 256 positions have the same contents as " &
- "type Character");
- New_Line;
-
- P (" -- type Wide_Character is (nul, soh ... FFFE, FFFF);");
- New_Line;
-
- P (" package ASCII is");
- New_Line;
-
- P (" -- Control characters:");
- New_Line;
-
- P (" NUL : constant Character := Character'Val (16#00#);");
- P (" SOH : constant Character := Character'Val (16#01#);");
- P (" STX : constant Character := Character'Val (16#02#);");
- P (" ETX : constant Character := Character'Val (16#03#);");
- P (" EOT : constant Character := Character'Val (16#04#);");
- P (" ENQ : constant Character := Character'Val (16#05#);");
- P (" ACK : constant Character := Character'Val (16#06#);");
- P (" BEL : constant Character := Character'Val (16#07#);");
- P (" BS : constant Character := Character'Val (16#08#);");
- P (" HT : constant Character := Character'Val (16#09#);");
- P (" LF : constant Character := Character'Val (16#0A#);");
- P (" VT : constant Character := Character'Val (16#0B#);");
- P (" FF : constant Character := Character'Val (16#0C#);");
- P (" CR : constant Character := Character'Val (16#0D#);");
- P (" SO : constant Character := Character'Val (16#0E#);");
- P (" SI : constant Character := Character'Val (16#0F#);");
- P (" DLE : constant Character := Character'Val (16#10#);");
- P (" DC1 : constant Character := Character'Val (16#11#);");
- P (" DC2 : constant Character := Character'Val (16#12#);");
- P (" DC3 : constant Character := Character'Val (16#13#);");
- P (" DC4 : constant Character := Character'Val (16#14#);");
- P (" NAK : constant Character := Character'Val (16#15#);");
- P (" SYN : constant Character := Character'Val (16#16#);");
- P (" ETB : constant Character := Character'Val (16#17#);");
- P (" CAN : constant Character := Character'Val (16#18#);");
- P (" EM : constant Character := Character'Val (16#19#);");
- P (" SUB : constant Character := Character'Val (16#1A#);");
- P (" ESC : constant Character := Character'Val (16#1B#);");
- P (" FS : constant Character := Character'Val (16#1C#);");
- P (" GS : constant Character := Character'Val (16#1D#);");
- P (" RS : constant Character := Character'Val (16#1E#);");
- P (" US : constant Character := Character'Val (16#1F#);");
- P (" DEL : constant Character := Character'Val (16#7F#);");
- New_Line;
-
- P (" -- Other characters:");
- New_Line;
-
- P (" Exclam : constant Character := '!';");
- P (" Quotation : constant Character := '""';");
- P (" Sharp : constant Character := '#';");
- P (" Dollar : constant Character := '$';");
- P (" Percent : constant Character := '%';");
- P (" Ampersand : constant Character := '&';");
- P (" Colon : constant Character := ':';");
- P (" Semicolon : constant Character := ';';");
- P (" Query : constant Character := '?';");
- P (" At_Sign : constant Character := '@';");
- P (" L_Bracket : constant Character := '[';");
- P (" Back_Slash : constant Character := '\';");
- P (" R_Bracket : constant Character := ']';");
- P (" Circumflex : constant Character := '^';");
- P (" Underline : constant Character := '_';");
- P (" Grave : constant Character := '`';");
- P (" L_Brace : constant Character := '{';");
- P (" Bar : constant Character := '|';");
- P (" R_Brace : constant Character := '}';");
- P (" Tilde : constant Character := '~';");
- New_Line;
-
- P (" -- Lower case letters:");
- New_Line;
-
- for C in Character range 'a' .. 'z' loop
- P (" LC_" & Character'Val (Character'Pos (C) - 32) &
- " : constant Character := '" & C & "';");
- end loop;
- New_Line;
-
- P (" end ASCII;");
- New_Line;
-
- P (" type String is array (Positive range <>) of Character;");
- P (" pragma Pack (String);");
- New_Line;
-
- P (" type Wide_String is array (Positive range <>) of Wide_Character;");
- P (" pragma Pack (Wide_String);");
- New_Line;
-
- -- Here it's OK to use the Duration type of the host compiler since
- -- the implementation of Duration in GNAT is target independent.
-
- P (" type Duration is delta" &
- Duration'Image (Duration'Delta));
- P (" range -((2 **" & Natural'Image (Duration'Size - 1) &
- " - 1) *" & Duration'Image (Duration'Delta) & ") ..");
- P (" +((2 **" & Natural'Image (Duration'Size - 1) &
- " - 1) *" & Duration'Image (Duration'Delta) & ");");
- P (" for Duration'Small use" & Duration'Image (Duration'Small) & ";");
- New_Line;
-
- P (" Constraint_Error : exception;");
- P (" Program_Error : exception;");
- P (" Storage_Error : exception;");
- P (" Tasking_Error : exception;");
- New_Line;
-
- P ("end Standard;");
-end GnatPsta;
OSDN Git Service
