1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- L I B . U T I L -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2013, 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 Hostparm; 27with Osint.C; use Osint.C; 28with Stringt; use Stringt; 29 30package body Lib.Util is 31 32 Max_Line : constant Natural := 2 * Hostparm.Max_Name_Length + 64; 33 Max_Buffer : constant Natural := 1000 * Max_Line; 34 35 Info_Buffer : String (1 .. Max_Buffer); 36 -- Info_Buffer used to prepare lines of library output 37 38 Info_Buffer_Len : Natural := 0; 39 -- Number of characters stored in Info_Buffer 40 41 Info_Buffer_Col : Natural := 1; 42 -- Column number of next character to be written. 43 -- Can be different from Info_Buffer_Len + 1 because of tab characters 44 -- written by Write_Info_Tab. 45 46 procedure Write_Info_Hex_Byte (J : Natural); 47 -- Place two hex digits representing the value J (which is in the range 48 -- 0-255) in Info_Buffer, incrementing Info_Buffer_Len by 2. The digits 49 -- are output using lower case letters. 50 51 --------------------- 52 -- Write_Info_Char -- 53 --------------------- 54 55 procedure Write_Info_Char (C : Character) is 56 begin 57 Info_Buffer_Len := Info_Buffer_Len + 1; 58 Info_Buffer (Info_Buffer_Len) := C; 59 Info_Buffer_Col := Info_Buffer_Col + 1; 60 end Write_Info_Char; 61 62 -------------------------- 63 -- Write_Info_Char_Code -- 64 -------------------------- 65 66 procedure Write_Info_Char_Code (Code : Char_Code) is 67 begin 68 -- 00 .. 7F 69 70 if Code <= 16#7F# then 71 Write_Info_Char (Character'Val (Code)); 72 73 -- 80 .. FF 74 75 elsif Code <= 16#FF# then 76 Write_Info_Char ('U'); 77 Write_Info_Hex_Byte (Natural (Code)); 78 79 -- 0100 .. FFFF 80 81 else 82 Write_Info_Char ('W'); 83 Write_Info_Hex_Byte (Natural (Code / 256)); 84 Write_Info_Hex_Byte (Natural (Code mod 256)); 85 end if; 86 end Write_Info_Char_Code; 87 88 -------------------- 89 -- Write_Info_Col -- 90 -------------------- 91 92 function Write_Info_Col return Positive is 93 begin 94 return Info_Buffer_Col; 95 end Write_Info_Col; 96 97 -------------------- 98 -- Write_Info_EOL -- 99 -------------------- 100 101 procedure Write_Info_EOL is 102 begin 103 if Hostparm.OpenVMS 104 or else Info_Buffer_Len + Max_Line + 1 > Max_Buffer 105 then 106 Write_Info_Terminate; 107 else 108 -- Delete any trailing blanks 109 110 while Info_Buffer_Len > 0 111 and then Info_Buffer (Info_Buffer_Len) = ' ' 112 loop 113 Info_Buffer_Len := Info_Buffer_Len - 1; 114 end loop; 115 116 Info_Buffer_Len := Info_Buffer_Len + 1; 117 Info_Buffer (Info_Buffer_Len) := ASCII.LF; 118 Info_Buffer_Col := 1; 119 end if; 120 end Write_Info_EOL; 121 122 ------------------------- 123 -- Write_Info_Hex_Byte -- 124 ------------------------- 125 126 procedure Write_Info_Hex_Byte (J : Natural) is 127 Hexd : constant array (0 .. 15) of Character := "0123456789abcdef"; 128 begin 129 Write_Info_Char (Hexd (J / 16)); 130 Write_Info_Char (Hexd (J mod 16)); 131 end Write_Info_Hex_Byte; 132 133 ------------------------- 134 -- Write_Info_Initiate -- 135 ------------------------- 136 137 procedure Write_Info_Initiate (Key : Character) renames Write_Info_Char; 138 139 -------------------- 140 -- Write_Info_Int -- 141 -------------------- 142 143 procedure Write_Info_Int (N : Int) is 144 begin 145 if N >= 0 then 146 Write_Info_Nat (N); 147 148 -- Negative numbers, use Write_Info_Uint to avoid problems with largest 149 -- negative number. 150 151 else 152 Write_Info_Uint (UI_From_Int (N)); 153 end if; 154 end Write_Info_Int; 155 156 --------------------- 157 -- Write_Info_Name -- 158 --------------------- 159 160 procedure Write_Info_Name (Name : Name_Id) is 161 begin 162 Get_Name_String (Name); 163 Info_Buffer (Info_Buffer_Len + 1 .. Info_Buffer_Len + Name_Len) := 164 Name_Buffer (1 .. Name_Len); 165 Info_Buffer_Len := Info_Buffer_Len + Name_Len; 166 Info_Buffer_Col := Info_Buffer_Col + Name_Len; 167 end Write_Info_Name; 168 169 procedure Write_Info_Name (Name : File_Name_Type) is 170 begin 171 Write_Info_Name (Name_Id (Name)); 172 end Write_Info_Name; 173 174 procedure Write_Info_Name (Name : Unit_Name_Type) is 175 begin 176 Write_Info_Name (Name_Id (Name)); 177 end Write_Info_Name; 178 179 ----------------------------------- 180 -- Write_Info_Name_May_Be_Quoted -- 181 ----------------------------------- 182 183 procedure Write_Info_Name_May_Be_Quoted (Name : File_Name_Type) is 184 Quoted : Boolean := False; 185 Cur : Positive; 186 187 begin 188 Get_Name_String (Name); 189 190 -- The file/path name is quoted only if it includes spaces 191 192 for J in 1 .. Name_Len loop 193 if Name_Buffer (J) = ' ' then 194 Quoted := True; 195 exit; 196 end if; 197 end loop; 198 199 -- Deal with quoting string if needed 200 201 if Quoted then 202 Insert_Str_In_Name_Buffer ("""", 1); 203 Add_Char_To_Name_Buffer ('"'); 204 205 -- Any character '"' is doubled 206 207 Cur := 2; 208 while Cur < Name_Len loop 209 if Name_Buffer (Cur) = '"' then 210 Insert_Str_In_Name_Buffer ("""", Cur); 211 Cur := Cur + 2; 212 else 213 Cur := Cur + 1; 214 end if; 215 end loop; 216 end if; 217 218 Info_Buffer (Info_Buffer_Len + 1 .. Info_Buffer_Len + Name_Len) := 219 Name_Buffer (1 .. Name_Len); 220 Info_Buffer_Len := Info_Buffer_Len + Name_Len; 221 Info_Buffer_Col := Info_Buffer_Col + Name_Len; 222 end Write_Info_Name_May_Be_Quoted; 223 224 -------------------- 225 -- Write_Info_Nat -- 226 -------------------- 227 228 procedure Write_Info_Nat (N : Nat) is 229 begin 230 if N > 9 then 231 Write_Info_Nat (N / 10); 232 end if; 233 234 Write_Info_Char (Character'Val (N mod 10 + Character'Pos ('0'))); 235 end Write_Info_Nat; 236 237 --------------------- 238 -- Write_Info_Slit -- 239 --------------------- 240 241 procedure Write_Info_Slit (S : String_Id) is 242 C : Character; 243 244 begin 245 Write_Info_Str (""""); 246 247 for J in 1 .. String_Length (S) loop 248 C := Get_Character (Get_String_Char (S, J)); 249 250 if C in Character'Val (16#20#) .. Character'Val (16#7E#) 251 and then C /= '{' 252 then 253 Write_Info_Char (C); 254 255 if C = '"' then 256 Write_Info_Char (C); 257 end if; 258 259 else 260 Write_Info_Char ('{'); 261 Write_Info_Hex_Byte (Character'Pos (C)); 262 Write_Info_Char ('}'); 263 end if; 264 end loop; 265 266 Write_Info_Char ('"'); 267 end Write_Info_Slit; 268 269 -------------------- 270 -- Write_Info_Str -- 271 -------------------- 272 273 procedure Write_Info_Str (Val : String) is 274 begin 275 Info_Buffer (Info_Buffer_Len + 1 .. Info_Buffer_Len + Val'Length) 276 := Val; 277 Info_Buffer_Len := Info_Buffer_Len + Val'Length; 278 Info_Buffer_Col := Info_Buffer_Col + Val'Length; 279 end Write_Info_Str; 280 281 -------------------- 282 -- Write_Info_Tab -- 283 -------------------- 284 285 procedure Write_Info_Tab (Col : Positive) is 286 Next_Tab : Positive; 287 288 begin 289 if Col <= Info_Buffer_Col then 290 Write_Info_Str (" "); 291 else 292 loop 293 Next_Tab := 8 * ((Info_Buffer_Col - 1) / 8) + 8 + 1; 294 exit when Col < Next_Tab; 295 Write_Info_Char (ASCII.HT); 296 Info_Buffer_Col := Next_Tab; 297 end loop; 298 299 while Info_Buffer_Col < Col loop 300 Write_Info_Char (' '); 301 end loop; 302 end if; 303 end Write_Info_Tab; 304 305 -------------------------- 306 -- Write_Info_Terminate -- 307 -------------------------- 308 309 procedure Write_Info_Terminate is 310 begin 311 -- Delete any trailing blanks 312 313 while Info_Buffer_Len > 0 314 and then Info_Buffer (Info_Buffer_Len) = ' ' 315 loop 316 Info_Buffer_Len := Info_Buffer_Len - 1; 317 end loop; 318 319 -- Write_Library_Info adds the EOL 320 321 Write_Library_Info (Info_Buffer (1 .. Info_Buffer_Len)); 322 323 Info_Buffer_Len := 0; 324 Info_Buffer_Col := 1; 325 end Write_Info_Terminate; 326 327 --------------------- 328 -- Write_Info_Uint -- 329 --------------------- 330 331 procedure Write_Info_Uint (N : Uint) is 332 begin 333 UI_Image (N, Decimal); 334 Write_Info_Str (UI_Image_Buffer (1 .. UI_Image_Length)); 335 end Write_Info_Uint; 336 337end Lib.Util; 338