1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
|
-- Mcode back-end for ortho - Main subprogram.
-- Copyright (C) 2006 Tristan Gingold
--
-- GHDL is free software; you can redistribute it and/or modify it under
-- the terms of the GNU General Public License as published by the Free
-- Software Foundation; either version 2, or (at your option) any later
-- version.
--
-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
-- for more details.
--
-- You should have received a copy of the GNU General Public License
-- along with GCC; see the file COPYING. If not, write to the Free
-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
-- 02111-1307, USA.
with Ada.Unchecked_Conversion;
with Ada.Command_Line; use Ada.Command_Line;
with Ada.Unchecked_Deallocation;
with Ada.Text_IO; use Ada.Text_IO;
with Binary_File; use Binary_File;
with GNAT.OS_Lib; use GNAT.OS_Lib;
with Ortho_Code.Debug;
with Ortho_Mcode; use Ortho_Mcode;
with Ortho_Front; use Ortho_Front;
with Ortho_Code.Flags; use Ortho_Code.Flags;
with Binary_File.Elf;
with Binary_File.Coff;
with Binary_File.Memory;
procedure Ortho_Code_Main
is
Output : String_Acc := null;
type Format_Type is (Format_Coff, Format_Elf);
Format : constant Format_Type := Format_Elf;
First_File : Natural;
Opt : String_Acc;
Opt_Arg : String_Acc;
Filename : String_Acc;
Exec_Func : String_Acc;
Res : Natural;
I : Natural;
Argc : Natural;
Val : Integer;
procedure Unchecked_Deallocation is new Ada.Unchecked_Deallocation
(Name => String_Acc, Object => String);
procedure Write_Output
is
Fd : File_Descriptor;
begin
Fd := Create_File (Output.all, Binary);
if Fd /= Invalid_FD then
case Format is
when Format_Elf =>
Binary_File.Elf.Write (Fd);
when Format_Coff =>
Binary_File.Coff.Write (Fd);
end case;
Close (Fd);
end if;
end Write_Output;
begin
First_File := Natural'Last;
Exec_Func := null;
Val := 0;
Ortho_Front.Init;
Argc := Argument_Count;
I := 1;
while I <= Argc loop
declare
Arg : constant String := Argument (I);
begin
if Arg (1) = '-' then
if Arg'Length > 5 and then Arg (1 .. 5) = "--be-" then
Ortho_Code.Debug.Set_Be_Flag (Arg);
I := I + 1;
elsif Arg = "-o" then
if I = Argc then
Put_Line (Standard_Error, "error: missing filename to '-o'");
return;
end if;
Output := new String'(Argument (I + 1));
I := I + 2;
elsif Arg = "-quiet" then
-- Skip silently.
I := I + 1;
elsif Arg = "--exec" then
if I = Argc then
Put_Line (Standard_Error,
"error: missing function name to '--exec'");
return;
end if;
Exec_Func := new String'(Argument (I + 1));
I := I + 2;
elsif Arg = "-a" then
if I = Argc then
Put_Line (Standard_Error,
"error: missing value after 'a'");
return;
end if;
Val := Integer'Value (Argument (I + 1));
I := I + 2;
elsif Arg = "-g" then
Flag_Debug := Debug_Dwarf;
I := I + 1;
elsif Arg = "-g0" then
Flag_Debug := Debug_None;
I := I + 1;
elsif Arg = "-p" or Arg = "-pg" then
Flag_Profile := True;
I := I + 1;
else
-- This is really an argument.
Opt := new String'(Arg);
if I < Argument_Count then
Opt_Arg := new String'(Argument (I + 1));
else
Opt_Arg := null;
end if;
Res := Ortho_Front.Decode_Option (Opt, Opt_Arg);
case Res is
when 0 =>
Put_Line (Standard_Error, "unknown option '" & Arg & "'");
return;
when 1 =>
I := I + 1;
when 2 =>
I := I + 2;
when others =>
raise Program_Error;
end case;
Unchecked_Deallocation (Opt);
Unchecked_Deallocation (Opt_Arg);
end if;
else
First_File := I;
exit;
end if;
end;
end loop;
Ortho_Mcode.Init;
Set_Exit_Status (Failure);
if First_File > Argument_Count then
begin
if not Parse (null) then
return;
end if;
exception
when others =>
return;
end;
else
for I in First_File .. Argument_Count loop
Filename := new String'(Argument (First_File));
begin
if not Parse (Filename) then
return;
end if;
exception
when others =>
return;
end;
end loop;
end if;
Ortho_Mcode.Finish;
if Ortho_Code.Debug.Flag_Debug_Hli then
Set_Exit_Status (Success);
return;
end if;
if Exec_Func /= null then
declare
Sym : Symbol;
procedure Putchar (V : Integer);
pragma Import (C, Putchar);
type Func_Acc is access function (V : Integer) return Integer;
function Conv is new Ada.Unchecked_Conversion
(Source => Pc_Type, Target => Func_Acc);
F : Func_Acc;
-- Set a breakpoint on this procedure under a debugger if you need
-- to debug the resulting binary in memory.
procedure Breakme (Func : Func_Acc) is
begin
F := Func;
end Breakme;
V : Integer;
Err : Boolean;
begin
Binary_File.Memory.Write_Memory_Init;
-- Export putchar.
Sym := Binary_File.Get_Symbol ("putchar");
if Sym /= Null_Symbol then
Binary_File.Memory.Set_Symbol_Address (Sym, Putchar'Address);
end if;
-- Relocate.
Binary_File.Memory.Write_Memory_Relocate (Err);
if Err then
return;
end if;
-- Dump the binary file.
if Output /= null then
Write_Output;
end if;
Sym := Binary_File.Get_Symbol (Exec_Func.all);
if Sym = Null_Symbol then
Put_Line (Standard_Error, "no '" & Exec_Func.all & "' symbol");
else
Breakme (Conv (Get_Symbol_Vaddr (Sym)));
V := F.all (Val);
Put_Line ("Result is " & Integer'Image (V));
end if;
end;
elsif Output /= null then
Write_Output;
end if;
Set_Exit_Status (Success);
exception
when others =>
Set_Exit_Status (2);
raise;
end Ortho_Code_Main;
|
