Skip several gcc.dg/builtin-dynamic-object-size tests on hppa*-*-hpux*
[official-gcc.git] / gcc / ada / butil.adb
blobe8d8f27a59450df8d780798e2b6ff34ca91ce439
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- B U T I L --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2023, 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 ------------------------------------------------------------------------------
26 with Ada.Unchecked_Deallocation;
27 with Opt; use Opt;
28 with Output; use Output;
30 with GNAT; use GNAT;
32 with System.OS_Lib; use System.OS_Lib;
34 package body Butil is
36 -----------------------
37 -- Local subprograms --
38 -----------------------
40 procedure Parse_Next_Unit_Name (Iter : in out Forced_Units_Iterator);
41 -- Parse the name of the next available unit accessible through iterator
42 -- Iter and save it in the iterator.
44 function Read_Forced_Elab_Order_File return String_Ptr;
45 -- Read the contents of the forced-elaboration-order file supplied to the
46 -- binder via switch -f and return them as a string. Return null if the
47 -- file is not available.
49 --------------
50 -- Has_Next --
51 --------------
53 function Has_Next (Iter : Forced_Units_Iterator) return Boolean is
54 begin
55 return Present (Iter.Unit_Name);
56 end Has_Next;
58 ----------------------
59 -- Is_Internal_Unit --
60 ----------------------
62 -- Note: the reason we do not use the Fname package for this function
63 -- is that it would drag too much junk into the binder.
65 function Is_Internal_Unit return Boolean is
66 begin
67 return Is_Predefined_Unit
68 or else (Name_Len > 4 and then (Name_Buffer (1 .. 5) = "gnat%"
69 or else
70 Name_Buffer (1 .. 5) = "gnat."));
71 end Is_Internal_Unit;
73 ------------------------
74 -- Is_Predefined_Unit --
75 ------------------------
77 -- Note: the reason we do not use the Fname package for this function
78 -- is that it would drag too much junk into the binder.
80 function Is_Predefined_Unit return Boolean is
81 L : Natural renames Name_Len;
82 B : String renames Name_Buffer;
83 begin
84 return (L > 3 and then B (1 .. 4) = "ada.")
85 or else (L > 6 and then B (1 .. 7) = "system.")
86 or else (L > 10 and then B (1 .. 11) = "interfaces.")
87 or else (L > 3 and then B (1 .. 4) = "ada%")
88 or else (L > 8 and then B (1 .. 9) = "calendar%")
89 or else (L > 9 and then B (1 .. 10) = "direct_io%")
90 or else (L > 10 and then B (1 .. 11) = "interfaces%")
91 or else (L > 13 and then B (1 .. 14) = "io_exceptions%")
92 or else (L > 12 and then B (1 .. 13) = "machine_code%")
93 or else (L > 13 and then B (1 .. 14) = "sequential_io%")
94 or else (L > 6 and then B (1 .. 7) = "system%")
95 or else (L > 7 and then B (1 .. 8) = "text_io%")
96 or else (L > 20 and then B (1 .. 21) = "unchecked_conversion%")
97 or else (L > 22 and then B (1 .. 23) = "unchecked_deallocation%")
98 or else (L > 4 and then B (1 .. 5) = "gnat%")
99 or else (L > 4 and then B (1 .. 5) = "gnat.");
100 end Is_Predefined_Unit;
102 --------------------------
103 -- Iterate_Forced_Units --
104 --------------------------
106 function Iterate_Forced_Units return Forced_Units_Iterator is
107 Iter : Forced_Units_Iterator;
109 begin
110 Iter.Order := Read_Forced_Elab_Order_File;
111 Parse_Next_Unit_Name (Iter);
113 return Iter;
114 end Iterate_Forced_Units;
116 ----------
117 -- Next --
118 ----------
120 procedure Next
121 (Iter : in out Forced_Units_Iterator;
122 Unit_Name : out Unit_Name_Type;
123 Unit_Line : out Logical_Line_Number)
125 begin
126 if not Has_Next (Iter) then
127 raise Iterator_Exhausted;
128 end if;
130 Unit_Line := Iter.Unit_Line;
131 Unit_Name := Iter.Unit_Name;
132 pragma Assert (Present (Unit_Name));
134 Parse_Next_Unit_Name (Iter);
135 end Next;
137 --------------------------
138 -- Parse_Next_Unit_Name --
139 --------------------------
141 procedure Parse_Next_Unit_Name (Iter : in out Forced_Units_Iterator) is
142 Body_Suffix : constant String := " (body)";
143 Body_Type : constant String := "%b";
144 Body_Length : constant Positive := Body_Suffix'Length;
145 Body_Offset : constant Natural := Body_Length - 1;
147 Comment_Header : constant String := "--";
148 Comment_Offset : constant Natural := Comment_Header'Length - 1;
150 Spec_Suffix : constant String := " (spec)";
151 Spec_Type : constant String := "%s";
152 Spec_Length : constant Positive := Spec_Suffix'Length;
153 Spec_Offset : constant Natural := Spec_Length - 1;
155 Index : Positive renames Iter.Order_Index;
156 Line : Logical_Line_Number renames Iter.Order_Line;
157 Order : String_Ptr renames Iter.Order;
159 function At_Comment return Boolean;
160 pragma Inline (At_Comment);
161 -- Determine whether iterator Iter is positioned over the start of a
162 -- comment.
164 function At_Terminator return Boolean;
165 pragma Inline (At_Terminator);
166 -- Determine whether iterator Iter is positioned over a line terminator
167 -- character.
169 function At_Whitespace return Boolean;
170 pragma Inline (At_Whitespace);
171 -- Determine whether iterator Iter is positioned over a whitespace
172 -- character.
174 function Is_Terminator (C : Character) return Boolean;
175 pragma Inline (Is_Terminator);
176 -- Determine whether character C denotes a line terminator
178 function Is_Whitespace (C : Character) return Boolean;
179 pragma Inline (Is_Whitespace);
180 -- Determine whether character C denotes a whitespace
182 procedure Parse_Unit_Name;
183 pragma Inline (Parse_Unit_Name);
184 -- Find and parse the first available unit name
186 procedure Skip_Comment;
187 pragma Inline (Skip_Comment);
188 -- Skip a comment by reaching a line terminator
190 procedure Skip_Terminator;
191 pragma Inline (Skip_Terminator);
192 -- Skip a line terminator and deal with the logical line numbering
194 procedure Skip_Whitespace;
195 pragma Inline (Skip_Whitespace);
196 -- Skip whitespace
198 function Within_Order
199 (Low_Offset : Natural := 0;
200 High_Offset : Natural := 0) return Boolean;
201 pragma Inline (Within_Order);
202 -- Determine whether index of iterator Iter is still within the range of
203 -- the order string. Low_Offset may be used to inspect the area that is
204 -- less than the index. High_Offset may be used to inspect the area that
205 -- is greater than the index.
207 ----------------
208 -- At_Comment --
209 ----------------
211 function At_Comment return Boolean is
212 begin
213 -- The interator is over a comment when the index is positioned over
214 -- the start of a comment header.
216 -- unit (spec) -- comment
217 -- ^
218 -- Index
220 return
221 Within_Order (High_Offset => Comment_Offset)
222 and then Order (Index .. Index + Comment_Offset) = Comment_Header;
223 end At_Comment;
225 -------------------
226 -- At_Terminator --
227 -------------------
229 function At_Terminator return Boolean is
230 begin
231 return Within_Order and then Is_Terminator (Order (Index));
232 end At_Terminator;
234 -------------------
235 -- At_Whitespace --
236 -------------------
238 function At_Whitespace return Boolean is
239 begin
240 return Within_Order and then Is_Whitespace (Order (Index));
241 end At_Whitespace;
243 -------------------
244 -- Is_Terminator --
245 -------------------
247 function Is_Terminator (C : Character) return Boolean is
248 begin
249 -- Carriage return is treated intentionally as whitespace since it
250 -- appears only on certain targets, while line feed is consistent on
251 -- all of them.
253 return C = ASCII.LF;
254 end Is_Terminator;
256 -------------------
257 -- Is_Whitespace --
258 -------------------
260 function Is_Whitespace (C : Character) return Boolean is
261 begin
262 return
263 C = ' '
264 or else C = ASCII.CR -- carriage return
265 or else C = ASCII.FF -- form feed
266 or else C = ASCII.HT -- horizontal tab
267 or else C = ASCII.VT; -- vertical tab
268 end Is_Whitespace;
270 ---------------------
271 -- Parse_Unit_Name --
272 ---------------------
274 procedure Parse_Unit_Name is
275 pragma Assert (not At_Comment);
276 pragma Assert (not At_Terminator);
277 pragma Assert (not At_Whitespace);
278 pragma Assert (Within_Order);
280 procedure Find_End_Index_Of_Unit_Name;
281 pragma Inline (Find_End_Index_Of_Unit_Name);
282 -- Position the index of iterator Iter at the last character of the
283 -- first available unit name.
285 ---------------------------------
286 -- Find_End_Index_Of_Unit_Name --
287 ---------------------------------
289 procedure Find_End_Index_Of_Unit_Name is
290 begin
291 -- At this point the index points at the start of a unit name. The
292 -- unit name may be legal, in which case it appears as:
294 -- unit (body)
296 -- However, it may also be illegal:
298 -- unit without suffix
299 -- unit with multiple prefixes (spec)
301 -- In order to handle both forms, find the construct following the
302 -- unit name. This is either a comment, a terminator, or the end
303 -- of the order:
305 -- unit (body) -- comment
306 -- unit without suffix <terminator>
307 -- unit with multiple prefixes (spec)<end of order>
309 -- Once the construct is found, truncate the unit name by skipping
310 -- all white space between the construct and the end of the unit
311 -- name.
313 -- Find the construct that follows the unit name
315 while Within_Order loop
316 if At_Comment then
317 exit;
319 elsif At_Terminator then
320 exit;
321 end if;
323 Index := Index + 1;
324 end loop;
326 -- Position the index prior to the construct that follows the unit
327 -- name.
329 Index := Index - 1;
331 -- Truncate towards the end of the unit name
333 while Within_Order loop
334 if At_Whitespace then
335 Index := Index - 1;
336 else
337 exit;
338 end if;
339 end loop;
340 end Find_End_Index_Of_Unit_Name;
342 -- Local variables
344 Start_Index : constant Positive := Index;
346 End_Index : Positive;
347 Is_Body : Boolean := False;
348 Is_Spec : Boolean := False;
350 -- Start of processing for Parse_Unit_Name
352 begin
353 Find_End_Index_Of_Unit_Name;
354 End_Index := Index;
356 pragma Assert (Start_Index <= End_Index);
358 -- At this point the indices are positioned as follows:
360 -- End_Index
361 -- Index
362 -- v
363 -- unit (spec) -- comment
364 -- ^
365 -- Start_Index
367 -- Rewind the index, skipping over the legal suffixes
369 -- Index End_Index
370 -- v v
371 -- unit (spec) -- comment
372 -- ^
373 -- Start_Index
375 if Within_Order (Low_Offset => Body_Offset)
376 and then Order (Index - Body_Offset .. Index) = Body_Suffix
377 then
378 Is_Body := True;
379 Index := Index - Body_Length;
381 elsif Within_Order (Low_Offset => Spec_Offset)
382 and then Order (Index - Spec_Offset .. Index) = Spec_Suffix
383 then
384 Is_Spec := True;
385 Index := Index - Spec_Length;
386 end if;
388 -- Capture the line where the unit name is defined
390 Iter.Unit_Line := Line;
392 -- Transform the unit name to match the format recognized by the
393 -- name table.
395 if Is_Body then
396 Iter.Unit_Name :=
397 Name_Find (Order (Start_Index .. Index) & Body_Type);
399 elsif Is_Spec then
400 Iter.Unit_Name :=
401 Name_Find (Order (Start_Index .. Index) & Spec_Type);
403 -- Otherwise the unit name is illegal, so leave it as is
405 else
406 Iter.Unit_Name := Name_Find (Order (Start_Index .. Index));
407 end if;
409 -- Advance the index past the unit name
411 -- End_IndexIndex
412 -- vv
413 -- unit (spec) -- comment
414 -- ^
415 -- Start_Index
417 Index := End_Index + 1;
418 end Parse_Unit_Name;
420 ------------------
421 -- Skip_Comment --
422 ------------------
424 procedure Skip_Comment is
425 begin
426 pragma Assert (At_Comment);
428 while Within_Order loop
429 if At_Terminator then
430 exit;
431 end if;
433 Index := Index + 1;
434 end loop;
435 end Skip_Comment;
437 ---------------------
438 -- Skip_Terminator --
439 ---------------------
441 procedure Skip_Terminator is
442 begin
443 pragma Assert (At_Terminator);
445 Index := Index + 1;
446 Line := Line + 1;
447 end Skip_Terminator;
449 ---------------------
450 -- Skip_Whitespace --
451 ---------------------
453 procedure Skip_Whitespace is
454 begin
455 while Within_Order loop
456 if At_Whitespace then
457 Index := Index + 1;
458 else
459 exit;
460 end if;
461 end loop;
462 end Skip_Whitespace;
464 ------------------
465 -- Within_Order --
466 ------------------
468 function Within_Order
469 (Low_Offset : Natural := 0;
470 High_Offset : Natural := 0) return Boolean
472 begin
473 return
474 Order /= null
475 and then Index - Low_Offset >= Order'First
476 and then Index + High_Offset <= Order'Last;
477 end Within_Order;
479 -- Start of processing for Parse_Next_Unit_Name
481 begin
482 -- A line in the forced-elaboration-order file has the following
483 -- grammar:
485 -- LINE ::=
486 -- [WHITESPACE] UNIT_NAME [WHITESPACE] [COMMENT] TERMINATOR
488 -- WHITESPACE ::=
489 -- <any whitespace character>
490 -- | <carriage return>
492 -- UNIT_NAME ::=
493 -- UNIT_PREFIX [WHITESPACE] UNIT_SUFFIX
495 -- UNIT_PREFIX ::=
496 -- <any string>
498 -- UNIT_SUFFIX ::=
499 -- (body)
500 -- | (spec)
502 -- COMMENT ::=
503 -- -- <any string>
505 -- TERMINATOR ::=
506 -- <line feed>
507 -- <end of file>
509 -- Items in <> brackets are semantic notions
511 -- Assume that the order has no remaining units
513 Iter.Unit_Line := No_Line_Number;
514 Iter.Unit_Name := No_Unit_Name;
516 -- Try to find the first available unit name from the current position
517 -- of iteration.
519 while Within_Order loop
520 Skip_Whitespace;
522 if At_Comment then
523 Skip_Comment;
525 elsif not Within_Order then
526 exit;
528 elsif At_Terminator then
529 Skip_Terminator;
531 else
532 Parse_Unit_Name;
533 exit;
534 end if;
535 end loop;
536 end Parse_Next_Unit_Name;
538 ---------------------------------
539 -- Read_Forced_Elab_Order_File --
540 ---------------------------------
542 function Read_Forced_Elab_Order_File return String_Ptr is
543 procedure Free is new Ada.Unchecked_Deallocation (String, String_Ptr);
545 Descr : File_Descriptor;
546 Len : Natural;
547 Len_Read : Natural;
548 Result : String_Ptr;
549 Success : Boolean;
551 begin
552 if Force_Elab_Order_File = null then
553 return null;
554 end if;
556 -- Obtain and sanitize a descriptor to the elaboration-order file
558 Descr := Open_Read (Force_Elab_Order_File.all, Binary);
560 if Descr = Invalid_FD then
561 return null;
562 end if;
564 -- Determine the size of the file, allocate a result large enough to
565 -- house its contents, and read it.
567 Len := Natural (File_Length (Descr));
569 if Len = 0 then
570 return null;
571 end if;
573 Result := new String (1 .. Len);
574 Len_Read := Read (Descr, Result (1)'Address, Len);
576 -- The read failed to acquire the whole content of the file
578 if Len_Read /= Len then
579 Free (Result);
580 return null;
581 end if;
583 Close (Descr, Success);
585 -- The file failed to close
587 if not Success then
588 Free (Result);
589 return null;
590 end if;
592 return Result;
593 end Read_Forced_Elab_Order_File;
595 ----------------
596 -- Uname_Less --
597 ----------------
599 function Uname_Less (U1, U2 : Unit_Name_Type) return Boolean is
600 begin
601 Get_Name_String (U1);
603 declare
604 U1_Name : constant String (1 .. Name_Len) :=
605 Name_Buffer (1 .. Name_Len);
606 Min_Length : Natural;
608 begin
609 Get_Name_String (U2);
611 if Name_Len < U1_Name'Last then
612 Min_Length := Name_Len;
613 else
614 Min_Length := U1_Name'Last;
615 end if;
617 for J in 1 .. Min_Length loop
618 if U1_Name (J) > Name_Buffer (J) then
619 return False;
620 elsif U1_Name (J) < Name_Buffer (J) then
621 return True;
622 end if;
623 end loop;
625 return U1_Name'Last < Name_Len;
626 end;
627 end Uname_Less;
629 ---------------------
630 -- Write_Unit_Name --
631 ---------------------
633 procedure Write_Unit_Name (U : Unit_Name_Type) is
634 begin
635 Get_Name_String (U);
636 Write_Str (Name_Buffer (1 .. Name_Len - 2));
638 if Name_Buffer (Name_Len) = 's' then
639 Write_Str (" (spec)");
640 else
641 Write_Str (" (body)");
642 end if;
644 Name_Len := Name_Len + 5;
645 end Write_Unit_Name;
647 end Butil;