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
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
|
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- B L D - I O --
-- --
-- B o d y --
-- --
-- Copyright (C) 2002-2003 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT 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 distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Ada.Exceptions;
with Ada.Text_IO;
with Ada.Unchecked_Deallocation;
with GNAT.OS_Lib; use GNAT.OS_Lib;
with Osint;
package body Bld.IO is
use Ada;
Initial_Number_Of_Lines : constant := 100;
Initial_Length_Of_Line : constant := 50;
type Line is record
Length : Natural := 0;
Value : String_Access;
Suppressed : Boolean := False;
end record;
-- One line of a Makefile.
-- Length is the position of the last column in the line.
-- Suppressed is set to True by procedure Suppress.
type Line_Array is array (Positive range <>) of Line;
type Buffer is access Line_Array;
procedure Free is new Ada.Unchecked_Deallocation (Line_Array, Buffer);
Lines : Buffer := new Line_Array (1 .. Initial_Number_Of_Lines);
-- The lines of a Makefile
Current : Positive := 1;
-- Position of the last line in the Makefile
File : Text_IO.File_Type;
-- The current Makefile
type File_Name_Data;
type File_Name_Ref is access File_Name_Data;
type File_Name_Data is record
Value : String_Access;
Next : File_Name_Ref;
end record;
-- Used to record the names of all Makefiles created, so that we may delete
-- them if necessary.
File_Names : File_Name_Ref;
-- List of all the Makefiles created so far.
-----------
-- Close --
-----------
procedure Close is
begin
Flush;
Text_IO.Close (File);
exception
when X : others =>
Text_IO.Put_Line (Exceptions.Exception_Message (X));
Osint.Fail ("cannot close a Makefile");
end Close;
------------
-- Create --
------------
procedure Create (File_Name : String) is
begin
Text_IO.Create (File, Text_IO.Out_File, File_Name);
Current := 1;
Lines (1).Length := 0;
Lines (1).Suppressed := False;
File_Names :=
new File_Name_Data'(Value => new String'(File_Name),
Next => File_Names);
exception
when X : others =>
Text_IO.Put_Line (Exceptions.Exception_Message (X));
Osint.Fail ("cannot create """ & File_Name & '"');
end Create;
----------------
-- Delete_All --
----------------
procedure Delete_All is
Success : Boolean;
begin
if Text_IO.Is_Open (File) then
Text_IO.Delete (File);
File_Names := File_Names.Next;
end if;
while File_Names /= null loop
Delete_File (File_Names.Value.all, Success);
File_Names := File_Names.Next;
end loop;
end Delete_All;
-----------
-- Flush --
-----------
procedure Flush is
Last : Natural;
begin
if Lines (Current).Length /= 0 then
Osint.Fail ("INTERNAL ERROR: flushing before end of line: """ &
Lines (Current).Value
(1 .. Lines (Current).Length));
end if;
for J in 1 .. Current - 1 loop
if not Lines (J).Suppressed then
Last := Lines (J).Length;
-- The last character of a line cannot be a back slash ('\'),
-- otherwise make has a problem. The only real place were it
-- should happen is for directory names on Windows, and then
-- this terminal back slash is not needed.
if Last > 0 and then Lines (J).Value (Last) = '\' then
Last := Last - 1;
end if;
Text_IO.Put_Line (File, Lines (J).Value (1 .. Last));
end if;
end loop;
Current := 1;
Lines (1).Length := 0;
Lines (1).Suppressed := False;
end Flush;
----------
-- Mark --
----------
procedure Mark (Pos : out Position) is
begin
if Lines (Current).Length /= 0 then
Osint.Fail ("INTERNAL ERROR: marking before end of line: """ &
Lines (Current).Value
(1 .. Lines (Current).Length));
end if;
Pos := (Value => Current);
end Mark;
------------------
-- Name_Of_File --
------------------
function Name_Of_File return String is
begin
return Text_IO.Name (File);
end Name_Of_File;
--------------
-- New_Line --
--------------
procedure New_Line is
begin
Current := Current + 1;
if Current > Lines'Last then
declare
New_Lines : constant Buffer :=
new Line_Array (1 .. 2 * Lines'Last);
begin
New_Lines (1 .. Lines'Last) := Lines.all;
Free (Lines);
Lines := New_Lines;
end;
end if;
Lines (Current).Length := 0;
Lines (Current).Suppressed := False;
-- Allocate a new line, if necessary
if Lines (Current).Value = null then
Lines (Current).Value := new String (1 .. Initial_Length_Of_Line);
end if;
end New_Line;
---------
-- Put --
---------
procedure Put (S : String) is
Length : constant Natural := Lines (Current).Length;
begin
if Length + S'Length > Lines (Current).Value'Length then
declare
New_Line : String_Access;
New_Length : Positive := 2 * Lines (Current).Value'Length;
begin
while Length + S'Length > New_Length loop
New_Length := 2 * New_Length;
end loop;
New_Line := new String (1 .. New_Length);
New_Line (1 .. Length) := Lines (Current).Value (1 .. Length);
Free (Lines (Current).Value);
Lines (Current).Value := New_Line;
end;
end if;
Lines (Current).Value (Length + 1 .. Length + S'Length) := S;
Lines (Current).Length := Length + S'Length;
end Put;
-------------
-- Release --
-------------
procedure Release (Pos : Position) is
begin
if Lines (Current).Length /= 0 then
Osint.Fail ("INTERNAL ERROR: releasing before end of line: """ &
Lines (Current).Value
(1 .. Lines (Current).Length));
end if;
if Pos.Value > Current then
Osint.Fail ("INTERNAL ERROR: releasing ahead of current position");
end if;
Current := Pos.Value;
Lines (Current).Length := 0;
end Release;
--------------
-- Suppress --
--------------
procedure Suppress (Pos : Position) is
begin
if Pos.Value >= Current then
Osint.Fail ("INTERNAL ERROR: suppressing ahead of current position");
end if;
Lines (Pos.Value).Suppressed := True;
end Suppress;
begin
-- Allocate the first line.
-- The other ones are allocated by New_Line.
Lines (1).Value := new String (1 .. Initial_Length_Of_Line);
end Bld.IO;
|
