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
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306 | --------------------------------------------------------------------------------
-- NOM DU CSU (corps) : InSrc.adb
-- AUTEUR DU CSU : P. Pignard
-- VERSION DU CSU : 3.0a
-- DATE DE LA DERNIERE MISE A JOUR : Octobre 2023
-- ROLE DU CSU : Unité de gestion des textes sources.
--
--
-- FONCTIONS EXPORTEES DU CSU :
--
--
-- FONCTIONS LOCALES DU CSU :
--
--
-- NOTES :
--
-- COPYRIGHT : (c) Pascal Pignard 2023
-- LICENCE : CeCILL V2.1 (https://cecill.info)
-- CONTACT : http://blady.pagesperso-orange.fr
--------------------------------------------------------------------------------
with Ada.Exceptions; use Ada.Exceptions;
with Ada.Strings.Wide_Wide_Maps; use Ada.Strings.Wide_Wide_Maps;
with Ada.Characters.Wide_Wide_Latin_1; use Ada.Characters.Wide_Wide_Latin_1;
with Ada.Strings.Wide_Wide_Maps.Wide_Wide_Constants; use Ada.Strings.Wide_Wide_Maps.Wide_Wide_Constants;
with BasicDef;
package body InSrc is
use UXStrings.Text_IO;
Asciinul : constant Wide_Wide_Character := NUL;
Asciietx : constant Wide_Wide_Character := ETX;
Asciieot : constant Wide_Wide_Character := EOT;
Asciibel : constant Wide_Wide_Character := BEL;
Asciitab : constant Wide_Wide_Character := HT;
Asciilf : constant Wide_Wide_Character := LF;
Asciiff : constant Wide_Wide_Character := FF;
Asciicr : constant Wide_Wide_Character := CR;
Asciinak : constant Wide_Wide_Character := NAK;
Asciisp : constant Wide_Wide_Character := ' ';
-- caractère séparateur de ligne pour le système considéré
Newlinechar : constant Wide_Wide_Character := Asciilf;
NormAsciiCharRange : constant Wide_Wide_Character_Range := (Low => Space, High => LC_Y_Diaeresis);
Normasciicharset : constant Wide_Wide_Character_Set := To_Set ((NormAsciiCharRange));
Identcharset : constant Wide_Wide_Character_Set := To_Set ('_') or Decimal_Digit_Set or Letter_Set;
Chiffrecharset : constant Wide_Wide_Character_Set := Decimal_Digit_Set;
Hexacharset : constant Wide_Wide_Character_Set := Hexadecimal_Digit_Set;
Blanccharset : constant Wide_Wide_Character_Set :=
(To_Set (Asciibel) or To_Set (Asciitab) or To_Set (Asciilf) or To_Set (Asciiff) or To_Set (Asciicr) or
To_Set (Asciisp)) and
not To_Set (Newlinechar);
type TGenericErr is (ManqueApos, ManqueComment);
-- Procédure donnant le nom et la ligne courante du fichier source.
procedure Status (Object : not null access TSourceMgr; Name : out UXString; Ligne : out Natural) is
begin
Name := BasicDef.FSplitName (Object.FName);
Ligne := Object.CptLigne;
end Status;
procedure FileRead (F : in out File_Type; Buffer : in out Ttextbuff) is
Ch : Wide_Wide_Character;
begin
while not End_Of_File (F) loop
if End_Of_Line (F) then
Skip_Line (F);
Append (Buffer, Line_Mark);
else
Get (F, Ch);
Append (Buffer, Ch);
end if;
end loop;
exception
when E : others =>
Put_Line (From_UTF_8 (Exception_Information (E)));
Raise_Exception
(Exception_Identity (E), To_UTF_8 ("Erreur de lecture du fichier source : """ & Name (F) & """."));
end FileRead;
-- Procédure de lecture du contenu du fichier source.
procedure Open (Object : not null access TSourceMgr; Name : UXString) is
begin
Object.FName := Name;
Object.CptCar := 0;
Object.CptLigne := 1;
Open (Object.FRef, In_File, Name, UTF_8, LF_Ending);
Put_Line ("Lecture de " & BasicDef.FSplitName (Name) & " ...");
FileRead (Object.FRef, Object.TextBuff);
Close (Object.FRef);
Append (Object.TextBuff, Asciieot);
Object.ChTemp := Element (Object.TextBuff, 1);
exception
when E : others =>
Raise_Exception
(Exception_Identity (E),
Exception_Message (E) & To_UTF_8 ("Erreur d'ouverture du fichier source """ & Name & """."));
end Open;
-- Procédure de lecture d'un caractère du buffer contenant le texte source.
-- Le caractère lu est dans Ch1, le suivant est dans Ch2.
procedure Read (Object : not null access TSourceMgr; Ch1, Ch2 : out Wide_Wide_Character) is
begin
Ch1 := Object.ChTemp;
Object.CptCar := Object.CptCar + 1;
if Object.ChTemp = Newlinechar then
Object.CptLigne := Object.CptLigne + 1;
end if;
if Object.ChTemp /= Asciieot then
Object.ChTemp := Element (Object.TextBuff, Integer'Succ (Object.CptCar));
end if;
Ch2 := Object.ChTemp;
end Read;
-- Procédure de destruction du buffer.
procedure Close (Object : not null access TSourceMgr) is
begin
Object.FName := Null_UXString;
Object.TextBuff := From_Unicode (Asciieot);
end Close;
-- Affiche la raison de l'erreur.
procedure AffGenericErr (Id : TGenericErr) is
function Image is new UXStrings.Conversions.Scalar_Image (TGenericErr);
begin
Put_Line ("Erreur generique : " & Image (Id));
end AffGenericErr;
-- Affiche une chaîne à la suite d'une erreur.
procedure AffChaineErr (Chaine : UXString) is
begin
Put_Line ("Erreur : " & Chaine);
end AffChaineErr;
-- Lit un ou plusieurs caractère dans le texte source et le ou les transforme en éléments lexicaux.
procedure ReadToken (TokenId : out TTokenId; Token : out Ttokenstr) is
Ch, ChSuivant : Wide_Wide_Character;
-- Lit une chaîne de caractères.
procedure ReadChaine is
begin
Read (SrcAuto, Ch, ChSuivant);
while Is_In (Ch, Normasciicharset) loop
if (Ch = '`') and (ChSuivant = '`') then
Read (SrcAuto, Ch, ChSuivant);
elsif (Ch = '`') and (ChSuivant /= '`') then
Ch := Asciietx;
end if;
if Ch /= Asciietx then
Token := Token & Ch;
Read (SrcAuto, Ch, ChSuivant);
end if;
end loop;
case Ch is
when Asciieot =>
AffGenericErr (ManqueApos);
AffChaineErr ("Fin de fichier non attendue.");
TokenId := ErrorId;
when Asciietx =>
TokenId := CarId;
when others =>
AffGenericErr (ManqueApos);
AffChaineErr ("caractère non attendu : " & From_Unicode (Ch));
TokenId := ErrorId;
end case;
end ReadChaine;
-- Lit un commentaire.
procedure ReadComment is
Enr : Boolean := True;
begin
if Ch = '(' then
Read (SrcAuto, Ch, ChSuivant);
end if;
Read (SrcAuto, Ch, ChSuivant);
while not Is_In (Ch, To_Set (Asciieot) or To_Set (Asciietx)) loop
if Ch = Newlinechar then
Enr := False;
end if;
if Ch = Asciietx then
Ch := Asciinul;
end if;
if Ch = '}' then
Ch := Asciietx;
end if;
if (Ch = '*') and (ChSuivant = ')') then
Read (SrcAuto, Ch, ChSuivant);
Ch := Asciietx;
end if;
if Ch /= Asciietx then
if Enr then
Token := Token & Ch;
end if;
Read (SrcAuto, Ch, ChSuivant);
end if;
end loop;
if Ch = Asciietx then
TokenId := CommentId;
else
AffGenericErr (ManqueComment);
TokenId := ErrorId;
end if;
end ReadComment;
-- Lit un commentaire d'une ligne.
procedure ReadCommentSingleLine is
begin
if Ch = '-' then
Read (SrcAuto, Ch, ChSuivant);
end if;
Read (SrcAuto, Ch, ChSuivant);
while not Is_In (Ch, To_Set (Asciieot) or To_Set (Asciietx)) loop
if Ch = Newlinechar then
Ch := Asciietx;
else
Token := Token & Ch;
Read (SrcAuto, Ch, ChSuivant);
end if;
end loop;
if Ch = Asciietx then
TokenId := CommentId;
else
AffGenericErr (ManqueComment);
TokenId := ErrorId;
end if;
end ReadCommentSingleLine;
-- Lit un identificateur.
procedure ReadIdent is
Found : IdAutoUnit.Cursor;
use type IdAutoUnit.Cursor;
begin
Token := Token & Ch;
while Is_In (ChSuivant, Identcharset) loop
Read (SrcAuto, Ch, ChSuivant);
Token := Token & Ch;
end loop;
Found := IdAuto.Find (Token.To_Lower);
if Found /= IdAutoUnit.No_Element then
TokenId := IdAutoUnit.Element (Found);
else
TokenId := UndefId;
end if;
end ReadIdent;
begin
Token := Null_UXString;
TokenId := ErrorId;
Read (SrcAuto, Ch, ChSuivant);
while Is_In (Ch, Blanccharset) loop
Read (SrcAuto, Ch, ChSuivant);
end loop;
case Ch is
when Asciieot =>
TokenId := EotId;
when Newlinechar =>
TokenId := NewlineId;
when '`' =>
ReadChaine;
when '(' =>
if ChSuivant = '*' then
ReadComment;
else
TokenId := ParOuvId;
Token := "(";
end if;
when ')' =>
TokenId := ParFermId;
Token := ")";
when '-' =>
if ChSuivant = '-' then
ReadCommentSingleLine;
else
TokenId := ErrorId;
Token := "-" & ChSuivant;
end if;
when '+' =>
TokenId := PlusId;
Token := "+";
when '.' =>
if ChSuivant = '.' then
TokenId := PointpointId;
Read (SrcAuto, Ch, ChSuivant);
Token := "..";
else
TokenId := ErrorId;
Token := "." & ChSuivant;
end if;
when ',' =>
TokenId := VirgId;
Token := ",";
when 'A' .. 'Z' | 'a' .. 'z' | '_' =>
ReadIdent;
when '{' =>
ReadComment;
when others =>
TokenId := ErrorId;
Token := From_Unicode (Ch);
end case;
end ReadToken;
end InSrc;
|