1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- B U T I L -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2012, 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; 27with Targparm; use Targparm; 28 29package body Butil is 30 31 ---------------------- 32 -- Is_Internal_Unit -- 33 ---------------------- 34 35 -- Note: the reason we do not use the Fname package for this function 36 -- is that it would drag too much junk into the binder. 37 38 function Is_Internal_Unit return Boolean is 39 begin 40 return Is_Predefined_Unit 41 or else (Name_Len > 4 42 and then (Name_Buffer (1 .. 5) = "gnat%" 43 or else 44 Name_Buffer (1 .. 5) = "gnat.")) 45 or else 46 (OpenVMS_On_Target 47 and then Name_Len > 3 48 and then (Name_Buffer (1 .. 4) = "dec%" 49 or else 50 Name_Buffer (1 .. 4) = "dec.")); 51 52 end Is_Internal_Unit; 53 54 ------------------------ 55 -- Is_Predefined_Unit -- 56 ------------------------ 57 58 -- Note: the reason we do not use the Fname package for this function 59 -- is that it would drag too much junk into the binder. 60 61 function Is_Predefined_Unit return Boolean is 62 begin 63 return (Name_Len > 3 64 and then Name_Buffer (1 .. 4) = "ada.") 65 66 or else (Name_Len > 6 67 and then Name_Buffer (1 .. 7) = "system.") 68 69 or else (Name_Len > 10 70 and then Name_Buffer (1 .. 11) = "interfaces.") 71 72 or else (Name_Len > 3 73 and then Name_Buffer (1 .. 4) = "ada%") 74 75 or else (Name_Len > 8 76 and then Name_Buffer (1 .. 9) = "calendar%") 77 78 or else (Name_Len > 9 79 and then Name_Buffer (1 .. 10) = "direct_io%") 80 81 or else (Name_Len > 10 82 and then Name_Buffer (1 .. 11) = "interfaces%") 83 84 or else (Name_Len > 13 85 and then Name_Buffer (1 .. 14) = "io_exceptions%") 86 87 or else (Name_Len > 12 88 and then Name_Buffer (1 .. 13) = "machine_code%") 89 90 or else (Name_Len > 13 91 and then Name_Buffer (1 .. 14) = "sequential_io%") 92 93 or else (Name_Len > 6 94 and then Name_Buffer (1 .. 7) = "system%") 95 96 or else (Name_Len > 7 97 and then Name_Buffer (1 .. 8) = "text_io%") 98 99 or else (Name_Len > 20 100 and then Name_Buffer (1 .. 21) = "unchecked_conversion%") 101 102 or else (Name_Len > 22 103 and then Name_Buffer (1 .. 23) = "unchecked_deallocation%") 104 105 or else (Name_Len > 4 106 and then Name_Buffer (1 .. 5) = "gnat%") 107 108 or else (Name_Len > 4 109 and then Name_Buffer (1 .. 5) = "gnat."); 110 end Is_Predefined_Unit; 111 112 ---------------- 113 -- Uname_Less -- 114 ---------------- 115 116 function Uname_Less (U1, U2 : Unit_Name_Type) return Boolean is 117 begin 118 Get_Name_String (U1); 119 120 declare 121 U1_Name : constant String (1 .. Name_Len) := 122 Name_Buffer (1 .. Name_Len); 123 Min_Length : Natural; 124 125 begin 126 Get_Name_String (U2); 127 128 if Name_Len < U1_Name'Last then 129 Min_Length := Name_Len; 130 else 131 Min_Length := U1_Name'Last; 132 end if; 133 134 for I in 1 .. Min_Length loop 135 if U1_Name (I) > Name_Buffer (I) then 136 return False; 137 elsif U1_Name (I) < Name_Buffer (I) then 138 return True; 139 end if; 140 end loop; 141 142 return U1_Name'Last < Name_Len; 143 end; 144 end Uname_Less; 145 146 --------------------- 147 -- Write_Unit_Name -- 148 --------------------- 149 150 procedure Write_Unit_Name (U : Unit_Name_Type) is 151 begin 152 Get_Name_String (U); 153 Write_Str (Name_Buffer (1 .. Name_Len - 2)); 154 155 if Name_Buffer (Name_Len) = 's' then 156 Write_Str (" (spec)"); 157 else 158 Write_Str (" (body)"); 159 end if; 160 161 Name_Len := Name_Len + 5; 162 end Write_Unit_Name; 163 164end Butil; 165