Mercurial > hg > CbC > CbC_gcc
diff gcc/ada/butil.adb @ 111:04ced10e8804
gcc 7
author | kono |
---|---|
date | Fri, 27 Oct 2017 22:46:09 +0900 |
parents | |
children | 84e7813d76e9 |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/gcc/ada/butil.adb Fri Oct 27 22:46:09 2017 +0900 @@ -0,0 +1,126 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- B U T I L -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2014, 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; + +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.")); + 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 + L : Natural renames Name_Len; + B : String renames Name_Buffer; + begin + return (L > 3 and then B (1 .. 4) = "ada.") + or else (L > 6 and then B (1 .. 7) = "system.") + or else (L > 10 and then B (1 .. 11) = "interfaces.") + or else (L > 3 and then B (1 .. 4) = "ada%") + or else (L > 8 and then B (1 .. 9) = "calendar%") + or else (L > 9 and then B (1 .. 10) = "direct_io%") + or else (L > 10 and then B (1 .. 11) = "interfaces%") + or else (L > 13 and then B (1 .. 14) = "io_exceptions%") + or else (L > 12 and then B (1 .. 13) = "machine_code%") + or else (L > 13 and then B (1 .. 14) = "sequential_io%") + or else (L > 6 and then B (1 .. 7) = "system%") + or else (L > 7 and then B (1 .. 8) = "text_io%") + or else (L > 20 and then B (1 .. 21) = "unchecked_conversion%") + or else (L > 22 and then B (1 .. 23) = "unchecked_deallocation%") + or else (L > 4 and then B (1 .. 5) = "gnat%") + or else (L > 4 and then B (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 J in 1 .. Min_Length loop + if U1_Name (J) > Name_Buffer (J) then + return False; + elsif U1_Name (J) < Name_Buffer (J) 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;