1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- B U T I L -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2019, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- 17-- for more details. You should have received a copy of the GNU General -- 18-- Public License distributed with GNAT; see file COPYING3. If not, go to -- 19-- http://www.gnu.org/licenses for a complete copy of the license. -- 20-- -- 21-- GNAT was originally developed by the GNAT team at New York University. -- 22-- Extensive contributions were provided by Ada Core Technologies Inc. -- 23-- -- 24------------------------------------------------------------------------------ 25 26with Output; use Output; 27 28package body Butil is 29 30 ---------------------- 31 -- Is_Internal_Unit -- 32 ---------------------- 33 34 -- Note: the reason we do not use the Fname package for this function 35 -- is that it would drag too much junk into the binder. 36 37 function Is_Internal_Unit return Boolean is 38 begin 39 return Is_Predefined_Unit 40 or else (Name_Len > 4 and then (Name_Buffer (1 .. 5) = "gnat%" 41 or else 42 Name_Buffer (1 .. 5) = "gnat.")); 43 end Is_Internal_Unit; 44 45 ------------------------ 46 -- Is_Predefined_Unit -- 47 ------------------------ 48 49 -- Note: the reason we do not use the Fname package for this function 50 -- is that it would drag too much junk into the binder. 51 52 function Is_Predefined_Unit return Boolean is 53 L : Natural renames Name_Len; 54 B : String renames Name_Buffer; 55 begin 56 return (L > 3 and then B (1 .. 4) = "ada.") 57 or else (L > 6 and then B (1 .. 7) = "system.") 58 or else (L > 10 and then B (1 .. 11) = "interfaces.") 59 or else (L > 3 and then B (1 .. 4) = "ada%") 60 or else (L > 8 and then B (1 .. 9) = "calendar%") 61 or else (L > 9 and then B (1 .. 10) = "direct_io%") 62 or else (L > 10 and then B (1 .. 11) = "interfaces%") 63 or else (L > 13 and then B (1 .. 14) = "io_exceptions%") 64 or else (L > 12 and then B (1 .. 13) = "machine_code%") 65 or else (L > 13 and then B (1 .. 14) = "sequential_io%") 66 or else (L > 6 and then B (1 .. 7) = "system%") 67 or else (L > 7 and then B (1 .. 8) = "text_io%") 68 or else (L > 20 and then B (1 .. 21) = "unchecked_conversion%") 69 or else (L > 22 and then B (1 .. 23) = "unchecked_deallocation%") 70 or else (L > 4 and then B (1 .. 5) = "gnat%") 71 or else (L > 4 and then B (1 .. 5) = "gnat."); 72 end Is_Predefined_Unit; 73 74 ---------------- 75 -- Uname_Less -- 76 ---------------- 77 78 function Uname_Less (U1, U2 : Unit_Name_Type) return Boolean is 79 begin 80 Get_Name_String (U1); 81 82 declare 83 U1_Name : constant String (1 .. Name_Len) := 84 Name_Buffer (1 .. Name_Len); 85 Min_Length : Natural; 86 87 begin 88 Get_Name_String (U2); 89 90 if Name_Len < U1_Name'Last then 91 Min_Length := Name_Len; 92 else 93 Min_Length := U1_Name'Last; 94 end if; 95 96 for J in 1 .. Min_Length loop 97 if U1_Name (J) > Name_Buffer (J) then 98 return False; 99 elsif U1_Name (J) < Name_Buffer (J) then 100 return True; 101 end if; 102 end loop; 103 104 return U1_Name'Last < Name_Len; 105 end; 106 end Uname_Less; 107 108 --------------------- 109 -- Write_Unit_Name -- 110 --------------------- 111 112 procedure Write_Unit_Name (U : Unit_Name_Type) is 113 begin 114 Get_Name_String (U); 115 Write_Str (Name_Buffer (1 .. Name_Len - 2)); 116 117 if Name_Buffer (Name_Len) = 's' then 118 Write_Str (" (spec)"); 119 else 120 Write_Str (" (body)"); 121 end if; 122 123 Name_Len := Name_Len + 5; 124 end Write_Unit_Name; 125 126end Butil; 127