1 ------------------------------------------------------------------------------
3 -- GNAT SYSTEM UTILITIES --
9 -- Copyright (C) 2008-2023, Free Software Foundation, Inc. --
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. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 -- The base name of the template file is given by Argument (1). This program
27 -- generates the spec for this specified unit (let's call it UNIT_NAME).
29 -- It works in conjunction with a C template file which must be preprocessed
30 -- and compiled using the cross compiler. Two input files are used:
31 -- - the preprocessed C file: UNIT_NAME-tmplt.i
32 -- - the generated assembly file: UNIT_NAME-tmplt.s
34 -- The generated files are UNIT_NAME.ads and UNIT_NAME.h
36 with Ada
.Characters
.Handling
; use Ada
.Characters
.Handling
;
37 with Ada
.Command_Line
; use Ada
.Command_Line
;
38 with Ada
.Exceptions
; use Ada
.Exceptions
;
39 with Ada
.Streams
.Stream_IO
; use Ada
.Streams
.Stream_IO
;
40 with Ada
.Strings
.Fixed
; use Ada
.Strings
.Fixed
;
41 with Ada
.Strings
.Maps
; use Ada
.Strings
.Maps
;
42 with Ada
.Strings
.Maps
.Constants
; use Ada
.Strings
.Maps
.Constants
;
43 with Ada
.Text_IO
; use Ada
.Text_IO
;
45 pragma Warnings
(Off
);
46 -- System.Unsigned_Types is an internal GNAT unit
47 with System
.Unsigned_Types
; use System
.Unsigned_Types
;
51 with GNAT
.String_Split
; use GNAT
.String_Split
;
54 with XUtil
; use XUtil
;
60 Unit_Name
: constant String := Argument
(1);
61 Tmpl_Name
: constant String := Unit_Name
& "-tmplt";
63 -------------------------------------------------
64 -- Information retrieved from assembly listing --
65 -------------------------------------------------
67 type String_Access
is access all String;
68 -- Note: we can't use GNAT.Strings for this definition, since that unit
69 -- is not available in older base compilers.
71 -- We need to deal with integer values that can be signed or unsigned, so
72 -- we need to accommodate the maximum range of both cases.
74 type Int_Value_Type
is record
76 Abs_Value
: Long_Unsigned
:= 0;
79 function ">" (V1
, V2
: Int_Value_Type
) return Boolean;
80 function "<" (V1
, V2
: Int_Value_Type
) return Boolean;
83 (CND
, -- Named number (decimal)
84 CNU
, -- Named number (decimal, unsigned)
85 CNS
, -- Named number (freeform text)
89 -- Recognized markers found in assembly file. These markers are produced by
90 -- the same-named macros from the C template.
92 subtype Asm_Int_Kind
is Asm_Info_Kind
range CND
.. CNU
;
93 -- Asm_Info_Kind values with int values in input
95 subtype Named_Number
is Asm_Info_Kind
range CND
.. CNS
;
96 -- Asm_Info_Kind values with named numbers in output
98 type Asm_Info
(Kind
: Asm_Info_Kind
:= TXT
) is record
99 Line_Number
: Integer;
100 -- Line number in C source file
102 Constant_Name
: String_Access
;
103 -- Name of constant to be defined
105 Constant_Type
: String_Access
;
106 -- Type of constant (case of Kind = C)
108 Value_Len
: Natural := 0;
109 -- Length of text representation of constant's value
111 Text_Value
: String_Access
;
112 -- Value for CNS / C constant
114 Int_Value
: Int_Value_Type
;
115 -- Value for CND / CNU constant
117 Comment
: String_Access
;
118 -- Additional descriptive comment for constant, or free-form text (TXT)
121 package Asm_Infos
is new GNAT
.Table
122 (Table_Component_Type
=> Asm_Info
,
123 Table_Index_Type
=> Integer,
124 Table_Low_Bound
=> 1,
125 Table_Initial
=> 100,
126 Table_Increment
=> 10);
128 Max_Constant_Name_Len
: Natural := 0;
129 Max_Constant_Value_Len
: Natural := 0;
130 Max_Constant_Type_Len
: Natural := 0;
131 -- Lengths of longest name and longest value
133 Size_Of_Unsigned_Int
: Integer := 0;
134 -- Size of unsigned int on target
136 type Language
is (Lang_Ada
, Lang_C
);
138 function Parse_Int
(S
: String; K
: Asm_Int_Kind
) return Int_Value_Type
;
139 -- Parse a decimal number, preceded by an optional '$' or '#' character,
140 -- and return its value.
142 procedure Output_Info
145 Info_Index
: Integer);
146 -- Output information from the indicated asm info line
148 procedure Parse_Asm_Line
(Line
: String);
149 -- Parse one information line from the assembly source
151 function Contains_Template_Name
(S
: String) return Boolean;
152 -- True if S contains Tmpl_Name, possibly with different casing
154 function Spaces
(Count
: Integer) return String;
155 -- If Count is positive, return a string of Count spaces, else return
162 function ">" (V1
, V2
: Int_Value_Type
) return Boolean is
163 P1
: Boolean renames V1
.Positive;
164 P2
: Boolean renames V2
.Positive;
165 A1
: Long_Unsigned
renames V1
.Abs_Value
;
166 A2
: Long_Unsigned
renames V2
.Abs_Value
;
168 return (P1
and then not P2
)
169 or else (P1
and then A1
> A2
)
170 or else (not P1
and then not P2
and then A1
< A2
);
177 function "<" (V1
, V2
: Int_Value_Type
) return Boolean is
179 return not (V1
> V2
) and then not (V1
= V2
);
182 ----------------------------
183 -- Contains_Template_Name --
184 ----------------------------
186 function Contains_Template_Name
(S
: String) return Boolean is
188 if Index
(Source
=> To_Lower
(S
), Pattern
=> Tmpl_Name
) > 0 then
193 end Contains_Template_Name
;
199 procedure Output_Info
202 Info_Index
: Integer)
204 Info
: Asm_Info
renames Asm_Infos
.Table
(Info_Index
);
206 procedure Put
(S
: String);
213 procedure Put
(S
: String) is
218 -- Start of processing for Output_Info
224 -- Handled in the common code for comments below
231 Put
(" subtype " & Info
.Constant_Name
.all
232 & " is " & Info
.Text_Value
.all & ";");
234 Put
("#define " & Info
.Constant_Name
.all & " "
235 & Info
.Text_Value
.all);
240 -- All named number cases
244 Put
(" " & Info
.Constant_Name
.all);
245 Put
(Spaces
(Max_Constant_Name_Len
246 - Info
.Constant_Name
'Length));
248 if Info
.Kind
in Named_Number
then
249 Put
(" : constant := ");
251 Put
(" : constant " & Info
.Constant_Type
.all);
252 Put
(Spaces
(Max_Constant_Type_Len
253 - Info
.Constant_Type
'Length));
258 Put
("#define " & Info
.Constant_Name
.all & " ");
259 Put
(Spaces
(Max_Constant_Name_Len
260 - Info
.Constant_Name
'Length));
263 if Info
.Kind
in Asm_Int_Kind
then
264 if not Info
.Int_Value
.Positive then
268 Put
(Trim
(Info
.Int_Value
.Abs_Value
'Img, Side
=> Left
));
272 Is_String
: constant Boolean :=
274 and then Info
.Constant_Type
.all = "String";
281 Put
(Info
.Text_Value
.all);
289 if Lang
= Lang_Ada
then
292 if Info
.Comment
'Length > 0 then
293 Put
(Spaces
(Max_Constant_Value_Len
- Info
.Value_Len
));
299 if Lang
= Lang_Ada
then
300 Put
(Info
.Comment
.all);
310 procedure Parse_Asm_Line
(Line
: String) is
311 Index1
, Index2
: Integer := Line
'First;
313 function Field_Alloc
return String_Access
;
314 -- Allocate and return a copy of Line (Index1 .. Index2 - 1)
316 procedure Find_Colon
(Index
: in out Integer);
317 -- Increment Index until the next colon in Line
323 function Field_Alloc
return String_Access
is
325 return new String'(Line (Index1 .. Index2 - 1));
332 procedure Find_Colon (Index : in out Integer) is
336 exit when Index > Line'Last or else Line (Index) = ':';
340 -- Start of processing for Parse_Asm_Line
346 Info : Asm_Info (Kind => Asm_Info_Kind'Value
347 (Line (Line'First .. Index2 - 1)));
349 Index1 := Index2 + 1;
353 Integer (Parse_Int (Line (Index1 .. Index2 - 1), CNU).Abs_Value);
362 Index1 := Index2 + 1;
365 Info.Constant_Name := Field_Alloc;
369 Info.Constant_Name'Length > Max_Constant_Name_Len
371 Max_Constant_Name_Len := Info.Constant_Name'Length;
374 Index1 := Index2 + 1;
377 if Info.Kind = C then
378 Info.Constant_Type := Field_Alloc;
380 if Info.Constant_Type'Length > Max_Constant_Type_Len then
381 Max_Constant_Type_Len := Info.Constant_Type'Length;
384 Index1 := Index2 + 1;
388 if Info.Kind = CND or else Info.Kind = CNU then
390 Parse_Int (Line (Index1 .. Index2 - 1), Info.Kind);
391 Info.Value_Len := Info.Int_Value.Abs_Value'Img'Length
- 1;
393 if not Info
.Int_Value
.Positive then
394 Info
.Value_Len
:= Info
.Value_Len
+ 1;
398 Info
.Text_Value
:= Field_Alloc
;
399 Info
.Value_Len
:= Info
.Text_Value
'Length;
402 if Info
.Constant_Name
.all = "SIZEOF_unsigned_int" then
403 Size_Of_Unsigned_Int
:=
404 8 * Integer (Info
.Int_Value
.Abs_Value
);
411 Index1
:= Index2
+ 1;
412 Index2
:= Line
'Last + 1;
413 Info
.Comment
:= Field_Alloc
;
415 if Info
.Kind
= TXT
then
416 Info
.Text_Value
:= Info
.Comment
;
418 -- Update Max_Constant_Value_Len, but only if this constant has a
419 -- comment (else the value is allowed to be longer).
421 elsif Info
.Comment
'Length > 0 then
422 if Info
.Value_Len
> Max_Constant_Value_Len
then
423 Max_Constant_Value_Len
:= Info
.Value_Len
;
427 Asm_Infos
.Append
(Info
);
433 (Standard_Error
, "can't parse " & Line
);
435 (Standard_Error
, "exception raised: " & Exception_Information
(E
));
445 Tmpl_File
: Ada
.Text_IO
.File_Type
;
446 Ada_Ofile
, C_Ofile
: Sfile
;
447 Current_Line
: in out Integer)
449 function Get_Value
(Name
: String) return Int_Value_Type
;
450 -- Returns the value of the variable Name
456 function Get_Value
(Name
: String) return Int_Value_Type
is
458 if Is_Subset
(To_Set
(Name
), Decimal_Digit_Set
) then
459 return Parse_Int
(Name
, CND
);
462 for K
in 1 .. Asm_Infos
.Last
loop
463 if Asm_Infos
.Table
(K
).Constant_Name
/= null then
464 if Name
= Asm_Infos
.Table
(K
).Constant_Name
.all then
465 return Asm_Infos
.Table
(K
).Int_Value
;
470 -- Not found returns 0
479 Line
: String (1 .. 256);
481 Value1
: Int_Value_Type
;
482 Value2
: Int_Value_Type
;
485 -- Start of processing for Parse_Cond
488 Create
(Sline
, If_Line
, " ");
490 if Slice_Count
(Sline
) /= 4 then
491 Put_Line
(Standard_Error
, "can't parse " & If_Line
);
494 Value1
:= Get_Value
(Slice
(Sline
, 2));
495 Value2
:= Get_Value
(Slice
(Sline
, 4));
497 pragma Annotate
(CodePeer
, Modified
, Value1
);
498 pragma Annotate
(CodePeer
, Modified
, Value2
);
500 if Slice
(Sline
, 3) = ">" then
501 Res
:= Cond
and (Value1
> Value2
);
503 elsif Slice
(Sline
, 3) = "<" then
504 Res
:= Cond
and (Value1
< Value2
);
506 elsif Slice
(Sline
, 3) = "=" then
507 Res
:= Cond
and (Value1
= Value2
);
509 elsif Slice
(Sline
, 3) = "/=" then
510 Res
:= Cond
and (Value1
/= Value2
);
513 -- No other operator can be used
515 Put_Line
(Standard_Error
, "unknown operator in " & If_Line
);
519 Current_Line
:= Current_Line
+ 1;
522 Get_Line
(Tmpl_File
, Line
, Last
);
523 Current_Line
:= Current_Line
+ 1;
524 exit when Line
(1 .. Last
) = "@END_IF";
526 if Last
> 4 and then Line
(1 .. 4) = "@IF " then
528 (Line
(1 .. Last
), Res
,
529 Tmpl_File
, Ada_Ofile
, C_Ofile
, Current_Line
);
531 elsif Line
(1 .. Last
) = "@ELSE" then
532 Res
:= Cond
and not Res
;
535 Put_Line
(Ada_OFile
, Line
(1 .. Last
));
536 Put_Line
(C_OFile
, Line
(1 .. Last
));
547 K
: Asm_Int_Kind
) return Int_Value_Type
549 First
: Integer := S
'First;
550 Result
: Int_Value_Type
;
553 -- On some platforms, immediate integer values are prefixed with
554 -- a $ or # character in assembly output.
556 if S
(First
) = '$' or else S
(First
) = '#' then
560 if S
(First
) = '-' then
561 Result
.Positive := False;
564 Result
.Positive := True;
567 Result
.Abs_Value
:= Long_Unsigned
'Value (S
(First
.. S
'Last));
569 if not Result
.Positive and then K
= CNU
then
571 -- Negative value, but unsigned expected: take 2's complement
572 -- reciprocical value.
574 Result
.Abs_Value
:= ((not Result
.Abs_Value
) + 1)
576 (Shift_Left
(1, Size_Of_Unsigned_Int
) - 1);
577 Result
.Positive := True;
584 Put_Line
(Standard_Error
, "can't parse decimal value: " & S
);
592 function Spaces
(Count
: Integer) return String is
597 return (1 .. Count
=> ' ');
601 -- Local declarations
605 Tmpl_File_Name
: constant String := Tmpl_Name
& ".i";
606 Asm_File_Name
: constant String := Tmpl_Name
& ".s";
610 Ada_File_Name
: constant String := Unit_Name
& ".ads";
611 C_File_Name
: constant String := Unit_Name
& ".h";
613 Asm_File
: Ada
.Text_IO
.File_Type
;
614 Tmpl_File
: Ada
.Text_IO
.File_Type
;
618 Line
: String (1 .. 256);
620 -- Line being processed
622 Current_Line
: Integer;
623 Current_Info
: Integer;
624 In_Comment
: Boolean;
625 In_Template
: Boolean := False;
627 -- Start of processing for XOSCons
630 -- Load values from assembly file
632 Open
(Asm_File
, In_File
, Asm_File_Name
);
633 while not End_Of_File
(Asm_File
) loop
634 Get_Line
(Asm_File
, Line
, Last
);
635 if Last
> 2 and then Line
(1 .. 2) = "->" then
636 Parse_Asm_Line
(Line
(3 .. Last
));
642 -- Load C template and output definitions
644 Open
(Tmpl_File
, In_File
, Tmpl_File_Name
);
645 Create
(Ada_OFile
, Out_File
, Ada_File_Name
);
646 Create
(C_OFile
, Out_File
, C_File_Name
);
649 Current_Info
:= Asm_Infos
.First
;
652 while not End_Of_File
(Tmpl_File
) loop
654 Get_Line
(Tmpl_File
, Line
, Last
);
656 if Last
>= 2 and then Line
(1 .. 2) = "# " then
662 while Index
<= Last
and then Line
(Index
) in '0' .. '9' loop
666 if Contains_Template_Name
(Line
(Index
+ 1 .. Last
)) then
667 Current_Line
:= Integer'Value (Line
(3 .. Index
- 1));
671 In_Template
:= False;
675 elsif In_Template
then
677 if Line
(1 .. Last
) = "*/" then
678 Put_Line
(C_OFile
, Line
(1 .. Last
));
681 elsif Last
> 4 and then Line
(1 .. 4) = "@IF " then
683 (Line
(1 .. Last
), True,
684 Tmpl_File
, Ada_Ofile
, C_Ofile
, Current_Line
);
687 Put_Line
(Ada_OFile
, Line
(1 .. Last
));
688 Put_Line
(C_OFile
, Line
(1 .. Last
));
691 elsif Line
(1 .. Last
) = "/*" then
692 Put_Line
(C_OFile
, Line
(1 .. Last
));
695 elsif Asm_Infos
.Table
(Current_Info
).Line_Number
= Current_Line
then
696 if Fixed
.Index
(Line
, "/*NOGEN*/") = 0 then
697 Output_Info
(Lang_Ada
, Ada_OFile
, Current_Info
);
698 Output_Info
(Lang_C
, C_OFile
, Current_Info
);
701 Current_Info
:= Current_Info
+ 1;
704 Current_Line
:= Current_Line
+ 1;
712 Put_Line
("raised " & Ada
.Exceptions
.Exception_Information
(E
));
713 GNAT
.OS_Lib
.OS_Exit
(1);