1 ------------------------------------------------------------------------------
3 -- GNAT SYSTEM UTILITIES --
9 -- Copyright (C) 2008-2013, 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 pre-processed
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
;
50 with GNAT
.String_Split
; use GNAT
.String_Split
;
53 with XUtil
; use XUtil
;
59 Unit_Name
: constant String := Argument
(1);
60 Tmpl_Name
: constant String := Unit_Name
& "-tmplt";
62 -------------------------------------------------
63 -- Information retrieved from assembly listing --
64 -------------------------------------------------
66 type String_Access
is access all String;
67 -- Note: we can't use GNAT.Strings for this definition, since that unit
68 -- is not available in older base compilers.
70 -- We need to deal with integer values that can be signed or unsigned, so
71 -- we need to accommodate the maximum range of both cases.
73 type Int_Value_Type
is record
75 Abs_Value
: Long_Unsigned
:= 0;
78 function ">" (V1
, V2
: Int_Value_Type
) return Boolean;
79 function "<" (V1
, V2
: Int_Value_Type
) return Boolean;
82 (CND
, -- Named number (decimal)
83 CNU
, -- Named number (decimal, unsigned)
84 CNS
, -- Named number (freeform text)
88 -- Recognized markers found in assembly file. These markers are produced by
89 -- the same-named macros from the C template.
91 subtype Asm_Int_Kind
is Asm_Info_Kind
range CND
.. CNU
;
92 -- Asm_Info_Kind values with int values in input
94 subtype Named_Number
is Asm_Info_Kind
range CND
.. CNS
;
95 -- Asm_Info_Kind values with named numbers in output
97 type Asm_Info
(Kind
: Asm_Info_Kind
:= TXT
) is record
98 Line_Number
: Integer;
99 -- Line number in C source file
101 Constant_Name
: String_Access
;
102 -- Name of constant to be defined
104 Constant_Type
: String_Access
;
105 -- Type of constant (case of Kind = C)
107 Value_Len
: Natural := 0;
108 -- Length of text representation of constant's value
110 Text_Value
: String_Access
;
111 -- Value for CNS / C constant
113 Int_Value
: Int_Value_Type
;
114 -- Value for CND / CNU constant
116 Comment
: String_Access
;
117 -- Additional descriptive comment for constant, or free-form text (TXT)
120 package Asm_Infos
is new GNAT
.Table
121 (Table_Component_Type
=> Asm_Info
,
122 Table_Index_Type
=> Integer,
123 Table_Low_Bound
=> 1,
124 Table_Initial
=> 100,
125 Table_Increment
=> 10);
127 Max_Constant_Name_Len
: Natural := 0;
128 Max_Constant_Value_Len
: Natural := 0;
129 Max_Constant_Type_Len
: Natural := 0;
130 -- Lengths of longest name and longest value
132 Size_Of_Unsigned_Int
: Integer := 0;
133 -- Size of unsigned int on target
135 type Language
is (Lang_Ada
, Lang_C
);
137 function Parse_Int
(S
: String; K
: Asm_Int_Kind
) return Int_Value_Type
;
138 -- Parse a decimal number, preceded by an optional '$' or '#' character,
139 -- and return its value.
141 procedure Output_Info
144 Info_Index
: Integer);
145 -- Output information from the indicated asm info line
147 procedure Parse_Asm_Line
(Line
: String);
148 -- Parse one information line from the assembly source
150 function Contains_Template_Name
(S
: String) return Boolean;
151 -- True if S contains Tmpl_Name, possibly with different casing
153 function Spaces
(Count
: Integer) return String;
154 -- If Count is positive, return a string of Count spaces, else return an
161 function ">" (V1
, V2
: Int_Value_Type
) return Boolean is
162 P1
: Boolean renames V1
.Positive;
163 P2
: Boolean renames V2
.Positive;
164 A1
: Long_Unsigned
renames V1
.Abs_Value
;
165 A2
: Long_Unsigned
renames V2
.Abs_Value
;
167 return (P1
and then not P2
)
168 or else (P1
and then P2
and then A1
> A2
)
169 or else (not P1
and then not P2
and then A1
< A2
);
176 function "<" (V1
, V2
: Int_Value_Type
) return Boolean is
178 return not (V1
> V2
) and then not (V1
= V2
);
181 ----------------------------
182 -- Contains_Template_Name --
183 ----------------------------
185 function Contains_Template_Name
(S
: String) return Boolean is
187 if Index
(Source
=> To_Lower
(S
), Pattern
=> Tmpl_Name
) > 0 then
192 end Contains_Template_Name
;
198 procedure Output_Info
201 Info_Index
: Integer)
203 Info
: Asm_Info
renames Asm_Infos
.Table
(Info_Index
);
205 procedure Put
(S
: String);
212 procedure Put
(S
: String) is
217 -- Start of processing for Output_Info
223 -- Handled in the common code for comments below
230 Put
(" subtype " & Info
.Constant_Name
.all
231 & " is Interfaces.C."
232 & 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);
356 when CND | CNU | CNS | C | SUB =>
357 Index1 := Index2 + 1;
360 Info.Constant_Name := Field_Alloc;
364 Info.Constant_Name'Length > Max_Constant_Name_Len
366 Max_Constant_Name_Len := Info.Constant_Name'Length;
369 Index1 := Index2 + 1;
372 if Info.Kind = C then
373 Info.Constant_Type := Field_Alloc;
375 if Info.Constant_Type'Length > Max_Constant_Type_Len then
376 Max_Constant_Type_Len := Info.Constant_Type'Length;
379 Index1 := Index2 + 1;
383 if Info.Kind = CND or else Info.Kind = CNU then
385 Parse_Int (Line (Index1 .. Index2 - 1), Info.Kind);
386 Info.Value_Len := Info.Int_Value.Abs_Value'Img'Length
- 1;
388 if not Info
.Int_Value
.Positive then
389 Info
.Value_Len
:= Info
.Value_Len
+ 1;
393 Info
.Text_Value
:= Field_Alloc
;
394 Info
.Value_Len
:= Info
.Text_Value
'Length;
397 if Info
.Constant_Name
.all = "SIZEOF_unsigned_int" then
398 Size_Of_Unsigned_Int
:=
399 8 * Integer (Info
.Int_Value
.Abs_Value
);
406 Index1
:= Index2
+ 1;
407 Index2
:= Line
'Last + 1;
408 Info
.Comment
:= Field_Alloc
;
410 if Info
.Kind
= TXT
then
411 Info
.Text_Value
:= Info
.Comment
;
413 -- Update Max_Constant_Value_Len, but only if this constant has a
414 -- comment (else the value is allowed to be longer).
416 elsif Info
.Comment
'Length > 0 then
417 if Info
.Value_Len
> Max_Constant_Value_Len
then
418 Max_Constant_Value_Len
:= Info
.Value_Len
;
422 Asm_Infos
.Append
(Info
);
428 (Standard_Error
, "can't parse " & Line
);
430 (Standard_Error
, "exception raised: " & Exception_Information
(E
));
440 Tmpl_File
: Ada
.Text_IO
.File_Type
;
441 Ada_Ofile
, C_Ofile
: Sfile
;
442 Current_Line
: in out Integer)
444 function Get_Value
(Name
: String) return Int_Value_Type
;
445 -- Returns the value of the variable Name
451 function Get_Value
(Name
: String) return Int_Value_Type
is
453 if Is_Subset
(To_Set
(Name
), Decimal_Digit_Set
) then
454 return Parse_Int
(Name
, CND
);
457 for K
in 1 .. Asm_Infos
.Last
loop
458 if Asm_Infos
.Table
(K
).Constant_Name
/= null then
459 if Name
= Asm_Infos
.Table
(K
).Constant_Name
.all then
460 return Asm_Infos
.Table
(K
).Int_Value
;
465 -- Not found returns 0
474 Line
: String (1 .. 256);
476 Value1
: Int_Value_Type
;
477 Value2
: Int_Value_Type
;
480 -- Start of processing for Parse_Cond
483 Create
(Sline
, If_Line
, " ");
485 if Slice_Count
(Sline
) /= 4 then
486 Put_Line
(Standard_Error
, "can't parse " & If_Line
);
489 Value1
:= Get_Value
(Slice
(Sline
, 2));
490 Value2
:= Get_Value
(Slice
(Sline
, 4));
492 if Slice
(Sline
, 3) = ">" then
493 Res
:= Cond
and (Value1
> Value2
);
495 elsif Slice
(Sline
, 3) = "<" then
496 Res
:= Cond
and (Value1
< Value2
);
498 elsif Slice
(Sline
, 3) = "=" then
499 Res
:= Cond
and (Value1
= Value2
);
501 elsif Slice
(Sline
, 3) = "/=" then
502 Res
:= Cond
and (Value1
/= Value2
);
505 -- No other operator can be used
507 Put_Line
(Standard_Error
, "unknown operator in " & If_Line
);
511 Current_Line
:= Current_Line
+ 1;
514 Get_Line
(Tmpl_File
, Line
, Last
);
515 Current_Line
:= Current_Line
+ 1;
516 exit when Line
(1 .. Last
) = "@END_IF";
518 if Last
> 4 and then Line
(1 .. 4) = "@IF " then
520 (Line
(1 .. Last
), Res
,
521 Tmpl_File
, Ada_Ofile
, C_Ofile
, Current_Line
);
523 elsif Line
(1 .. Last
) = "@ELSE" then
524 Res
:= Cond
and not Res
;
527 Put_Line
(Ada_OFile
, Line
(1 .. Last
));
528 Put_Line
(C_OFile
, Line
(1 .. Last
));
539 K
: Asm_Int_Kind
) return Int_Value_Type
541 First
: Integer := S
'First;
542 Result
: Int_Value_Type
;
545 -- On some platforms, immediate integer values are prefixed with
546 -- a $ or # character in assembly output.
548 if S
(First
) = '$' or else S
(First
) = '#' then
552 if S
(First
) = '-' then
553 Result
.Positive := False;
556 Result
.Positive := True;
559 Result
.Abs_Value
:= Long_Unsigned
'Value (S
(First
.. S
'Last));
561 if not Result
.Positive and then K
= CNU
then
563 -- Negative value, but unsigned expected: take 2's complement
564 -- reciprocical value.
566 Result
.Abs_Value
:= ((not Result
.Abs_Value
) + 1)
568 (Shift_Left
(1, Size_Of_Unsigned_Int
) - 1);
569 Result
.Positive := True;
576 Put_Line
(Standard_Error
, "can't parse decimal value: " & S
);
584 function Spaces
(Count
: Integer) return String is
589 return (1 .. Count
=> ' ');
593 -- Local declarations
597 Tmpl_File_Name
: constant String := Tmpl_Name
& ".i";
598 Asm_File_Name
: constant String := Tmpl_Name
& ".s";
602 Ada_File_Name
: constant String := Unit_Name
& ".ads";
603 C_File_Name
: constant String := Unit_Name
& ".h";
605 Asm_File
: Ada
.Text_IO
.File_Type
;
606 Tmpl_File
: Ada
.Text_IO
.File_Type
;
610 Line
: String (1 .. 256);
612 -- Line being processed
614 Current_Line
: Integer;
615 Current_Info
: Integer;
616 In_Comment
: Boolean;
617 In_Template
: Boolean;
619 -- Start of processing for XOSCons
622 -- Load values from assembly file
624 Open
(Asm_File
, In_File
, Asm_File_Name
);
625 while not End_Of_File
(Asm_File
) loop
626 Get_Line
(Asm_File
, Line
, Last
);
627 if Last
> 2 and then Line
(1 .. 2) = "->" then
628 Parse_Asm_Line
(Line
(3 .. Last
));
634 -- Load C template and output definitions
636 Open
(Tmpl_File
, In_File
, Tmpl_File_Name
);
637 Create
(Ada_OFile
, Out_File
, Ada_File_Name
);
638 Create
(C_OFile
, Out_File
, C_File_Name
);
641 Current_Info
:= Asm_Infos
.First
;
644 while not End_Of_File
(Tmpl_File
) loop
646 Get_Line
(Tmpl_File
, Line
, Last
);
648 if Last
>= 2 and then Line
(1 .. 2) = "# " then
654 while Index
<= Last
and then Line
(Index
) in '0' .. '9' loop
658 if Contains_Template_Name
(Line
(Index
+ 1 .. Last
)) then
659 Current_Line
:= Integer'Value (Line
(3 .. Index
- 1));
663 In_Template
:= False;
667 elsif In_Template
then
669 if Line
(1 .. Last
) = "*/" then
670 Put_Line
(C_OFile
, Line
(1 .. Last
));
673 elsif Last
> 4 and then Line
(1 .. 4) = "@IF " then
675 (Line
(1 .. Last
), True,
676 Tmpl_File
, Ada_Ofile
, C_Ofile
, Current_Line
);
679 Put_Line
(Ada_OFile
, Line
(1 .. Last
));
680 Put_Line
(C_OFile
, Line
(1 .. Last
));
683 elsif Line
(1 .. Last
) = "/*" then
684 Put_Line
(C_OFile
, Line
(1 .. Last
));
687 elsif Asm_Infos
.Table
(Current_Info
).Line_Number
= Current_Line
then
688 if Fixed
.Index
(Line
, "/*NOGEN*/") = 0 then
689 Output_Info
(Lang_Ada
, Ada_OFile
, Current_Info
);
690 Output_Info
(Lang_C
, C_OFile
, Current_Info
);
693 Current_Info
:= Current_Info
+ 1;
696 Current_Line
:= Current_Line
+ 1;
704 Put_Line
("xoscons <base_name>");