diff options
Diffstat (limited to 'gcc-4.8.3/gcc/ada/butil.adb')
| -rw-r--r-- | gcc-4.8.3/gcc/ada/butil.adb | 164 |
1 files changed, 164 insertions, 0 deletions
diff --git a/gcc-4.8.3/gcc/ada/butil.adb b/gcc-4.8.3/gcc/ada/butil.adb new file mode 100644 index 000000000..703d24395 --- /dev/null +++ b/gcc-4.8.3/gcc/ada/butil.adb @@ -0,0 +1,164 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- B U T I L -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2012, 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 3, 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 COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Output; use Output; +with Targparm; use Targparm; + +package body Butil is + + ---------------------- + -- Is_Internal_Unit -- + ---------------------- + + -- Note: the reason we do not use the Fname package for this function + -- is that it would drag too much junk into the binder. + + function Is_Internal_Unit return Boolean is + begin + return Is_Predefined_Unit + or else (Name_Len > 4 + and then (Name_Buffer (1 .. 5) = "gnat%" + or else + Name_Buffer (1 .. 5) = "gnat.")) + or else + (OpenVMS_On_Target + and then Name_Len > 3 + and then (Name_Buffer (1 .. 4) = "dec%" + or else + Name_Buffer (1 .. 4) = "dec.")); + + end Is_Internal_Unit; + + ------------------------ + -- Is_Predefined_Unit -- + ------------------------ + + -- Note: the reason we do not use the Fname package for this function + -- is that it would drag too much junk into the binder. + + function Is_Predefined_Unit return Boolean is + begin + return (Name_Len > 3 + and then Name_Buffer (1 .. 4) = "ada.") + + or else (Name_Len > 6 + and then Name_Buffer (1 .. 7) = "system.") + + or else (Name_Len > 10 + and then Name_Buffer (1 .. 11) = "interfaces.") + + or else (Name_Len > 3 + and then Name_Buffer (1 .. 4) = "ada%") + + or else (Name_Len > 8 + and then Name_Buffer (1 .. 9) = "calendar%") + + or else (Name_Len > 9 + and then Name_Buffer (1 .. 10) = "direct_io%") + + or else (Name_Len > 10 + and then Name_Buffer (1 .. 11) = "interfaces%") + + or else (Name_Len > 13 + and then Name_Buffer (1 .. 14) = "io_exceptions%") + + or else (Name_Len > 12 + and then Name_Buffer (1 .. 13) = "machine_code%") + + or else (Name_Len > 13 + and then Name_Buffer (1 .. 14) = "sequential_io%") + + or else (Name_Len > 6 + and then Name_Buffer (1 .. 7) = "system%") + + or else (Name_Len > 7 + and then Name_Buffer (1 .. 8) = "text_io%") + + or else (Name_Len > 20 + and then Name_Buffer (1 .. 21) = "unchecked_conversion%") + + or else (Name_Len > 22 + and then Name_Buffer (1 .. 23) = "unchecked_deallocation%") + + or else (Name_Len > 4 + and then Name_Buffer (1 .. 5) = "gnat%") + + or else (Name_Len > 4 + and then Name_Buffer (1 .. 5) = "gnat."); + end Is_Predefined_Unit; + + ---------------- + -- Uname_Less -- + ---------------- + + function Uname_Less (U1, U2 : Unit_Name_Type) return Boolean is + begin + Get_Name_String (U1); + + declare + U1_Name : constant String (1 .. Name_Len) := + Name_Buffer (1 .. Name_Len); + Min_Length : Natural; + + begin + Get_Name_String (U2); + + if Name_Len < U1_Name'Last then + Min_Length := Name_Len; + else + Min_Length := U1_Name'Last; + end if; + + for I in 1 .. Min_Length loop + if U1_Name (I) > Name_Buffer (I) then + return False; + elsif U1_Name (I) < Name_Buffer (I) then + return True; + end if; + end loop; + + return U1_Name'Last < Name_Len; + end; + end Uname_Less; + + --------------------- + -- Write_Unit_Name -- + --------------------- + + procedure Write_Unit_Name (U : Unit_Name_Type) is + begin + Get_Name_String (U); + Write_Str (Name_Buffer (1 .. Name_Len - 2)); + + if Name_Buffer (Name_Len) = 's' then + Write_Str (" (spec)"); + else + Write_Str (" (body)"); + end if; + + Name_Len := Name_Len + 5; + end Write_Unit_Name; + +end Butil; |