File : es_prolog.adb
1 -- Fichier ENT_SOR.ADB
2 -- Package d'entrée/sortie de l'interpréteur PROLOG.
3
4
5 with Text_Io; use Text_Io;
6 with Int32_Io; use Int32_Io;
7 with Objets_Prolog; use Objets_Prolog;
8 with Infos;
9
10
11 ----------------------------------------------------------------------------------------------------------------------------------
12
13
14 package body Es_Prolog is
15
16
17 ----------------------------
18 -- Les symboles pré-définis.
19 ----------------------------
20 Liste_Vide : constant Mot := Cree_Symbole("[]");
21 Vecteur_Vide : constant Mot := Cree_Symbole("()");
22 S_Puissance : constant Mot := Cree_Symbole("^");
23 S_Slash : constant Mot := Cree_Symbole("/");
24 S_Etoile : constant Mot := Cree_Symbole("*");
25 S_Moins : constant Mot := Cree_Symbole("-");
26 S_Plus : constant Mot := Cree_Symbole("+");
27 S_Sup : constant Mot := Cree_Symbole(">");
28 S_Sup_Egal : constant Mot := Cree_Symbole(">=");
29 S_Inf : constant Mot := Cree_Symbole("<");
30 S_Egal_Inf : constant Mot := Cree_Symbole("=<");
31 S_Egal : constant Mot := Cree_Symbole("=");
32 S_Par_Gauche : constant Mot := Cree_Symbole("(");
33 S_Par_Droite : constant Mot := Cree_Symbole(")");
34 S_Point : constant Mot := Cree_Symbole(".");
35 S_Point_Cr : constant Mot := Cree_Symbole('.' & Ascii.Cr);
36 S_Point_Virgule : constant Mot := Cree_Symbole(";");
37 S_2points_Moins : constant Mot := Cree_Symbole(":-");
38 S_Virgule : constant Mot := Cree_Symbole(",");
39 S_Is : constant Mot := Cree_Symbole("is");
40 S_Egal_Egal : constant Mot := Cree_Symbole("==");
41 S_Egal_Point_Point : constant Mot := Cree_Symbole("=..");
42 S_Egal_2points_Egal : constant Mot := Cree_Symbole("=:=");
43 S_Egal_Antislash_Egal : constant Mot := Cree_Symbole("=\=");
44 S_Antislash_Plus : constant Mot := Cree_Symbole("\+");
45 S_Antislash_Egal : constant Mot := Cree_Symbole("\=");
46 S_Antislash_Egal_Egal : constant Mot := Cree_Symbole("\==");
47 S_Arobasque_Inf : constant Mot := Cree_Symbole("@<");
48 S_Arobasque_Sup : constant Mot := Cree_Symbole("@>");
49 S_Arobasque_Sup_Egal : constant Mot := Cree_Symbole("@>=");
50 S_Arobasque_Egal_Inf : constant Mot := Cree_Symbole("@=<");
51 S_Slash_Slash : constant Mot := Cree_Symbole("//");
52 S_Crochet_Gauche : constant Mot := Cree_Symbole("[");
53 S_Crochet_Droit : constant Mot := Cree_Symbole("]");
54 S_Barre_V : constant Mot := Cree_Symbole("|");
55 S_Mod : constant Mot := Cree_Symbole("mod");
56 S_Not : constant Mot := Cree_Symbole("not");
57
58
59 -----------------------------------------------------------------
60 -- Les types et les variables nécessaires à l'analyse syntaxique.
61 -----------------------------------------------------------------
62
63
64 Sortie_Analyse_Passe1 : Boolean; -- Le seul moyen trouvé de distinguer a,(b,c) de a,b,c (à améliorer !)
65
66
67 -- La parenthese droite, le ']' et le '|' sont des séparateurs.
68 type A_Delimiteur is array(Positive range <>) of Mot;
69 Delimit : constant A_Delimiteur := (S_Par_Droite, S_Crochet_Droit, S_Barre_V);
70
71
72 -- Le point suivi d'un retour chariot indique que l'utilisateur a terminé sa saisie.
73 type A_Terminateur is array(Positive range <>) of Mot;
74 Terminat : constant A_Terminateur := (1 => S_Point_Cr);
75
76
77 -- Les opérateurs sont caractérisés par une priorité gauche et une priorité droite.
78
79 subtype Priorite is Natural; -- La priorité des opérateurs.
80 Priorite_Prefixe_Unaire : constant Priorite := 800; -- Servira pour le signe moins unaire. ex : -2.
81
82 type Type_Operateur is (Libre, -- Entrée non utilisée dans la table des opérateurs
83 Prefixe, -- Forme op expr
84 Infixe, -- Forme E1 op E2 op E3...
85 Postfixe); -- Forme expr op
86 -- Un opérateur peut etre à la fois préfixé, infixé et postfixé.
87 -- C'est le contexte qui permettra de choisir le bon type d'opérateur.
88
89
90 type Operateur is record
91 Op : Mot := Liste_Vide;
92 Type_Op : Type_Operateur := Libre;
93 Prio_G, Prio_D : Priorite;
94 Multiple : Boolean; -- Ne concerne que les opérateurs infixes. (Codage dense).
95 end record;
96
97 --pragma PACK(OPERATEUR); -- Pour loger sur 10 octets plutot que 12.
98
99
100 Carac_Op : array(Prefixe..Postfixe) of Operateur; -- Servira lors de l'analyse syntaxique : voir la fonction ANALYSE.
101
102 Nbre_Max_Operateurs : constant := 100;
103 subtype Indice_Table_Op is Positive range 1..Nbre_Max_Operateurs;
104
105 Topop : Indice_Table_Op; -- Sera initialisé au moment de l'élaboration du package.
106 Table_Op : array(Indice_Table_Op) of Operateur :=
107 -----------------------------------------------------
108 ( (S_Not, Prefixe, 0, 400, False),
109 (S_2points_Moins, Prefixe, 0, 10, False),
110 -----------------------------------------------------
111 (S_Par_Gauche, Infixe, 2000, 0, False),
112 (S_Puissance, Infixe, 900, 899, False),
113 (S_Mod, Infixe, 700, 700, False),
114 (S_Slash, Infixe, 700, 700, False),
115 (S_Etoile, Infixe, 700, 700, True),
116 (S_Moins, Infixe, 600, 600, True),
117 (S_Plus, Infixe, 600, 600, True),
118 (S_Sup, Infixe, 500, 500, True),
119 (S_Sup_Egal, Infixe, 500, 500, True),
120 (S_Inf, Infixe, 500, 500, True),
121 (S_Egal_Inf, Infixe, 500, 500, True),
122 (S_Egal, Infixe, 500, 500, True),
123 (S_Egal_Egal, Infixe, 500, 500, True),
124 (S_Egal_Point_Point, Infixe, 500, 500, True),
125 (S_Egal_2points_Egal, Infixe, 500, 500, True),
126 (S_Egal_Antislash_Egal, Infixe, 500, 500, True),
127 (S_Antislash_Plus, Infixe, 500, 500, True),
128 (S_Antislash_Egal, Infixe, 500, 500, True),
129 (S_Antislash_Egal_Egal, Infixe, 500, 500, True),
130 (S_Arobasque_Inf, Infixe, 500, 500, True),
131 (S_Arobasque_Sup, Infixe, 500, 500, True),
132 (S_Arobasque_Sup_Egal, Infixe, 500, 500, True),
133 (S_Arobasque_Egal_Inf, Infixe, 500, 500, True),
134 (S_Egal_Egal, Infixe, 500, 500, True),
135 (S_Is, Infixe, 300, 300, True),
136 (S_Barre_V, Infixe, 0, 30, False), -- Pour interdire expression du genre [a,b|c,d]
137 (S_Virgule, Infixe, 30, 29, True),
138 (S_Point_Virgule, Infixe, 20, 20, True),
139 (S_2points_Moins, Infixe, 10, 10, False),
140 -----------------------------------------------------
141 others => (Liste_Vide, Libre, 0, 0, False) );
142 -----------------------------------------------------
143
144
145 Taille_Token_Maxi : constant Positive := 3;
146 type A_Token is array(Positive range <>) of String(1..Taille_Token_Maxi);
147
148 -- ATTENTION ! Respecter l'ordre d'apparition :
149 -- De la chaine la plus courte à la chaine la plus longue, lorsque les n 1ers caracteres sont égaux.
150 -- Si le token a moins de TAILLE_TOKEN_MAXI caracteres alors on complete avec des espaces.
151 Table_Token : constant A_Token :=
152 ("== ", "=< ", "=..", "=:=", "=\=",
153 ">= ",
154 "\+ ", "\= ", "\==",
155 "@< ", "@> ", "@>=", "@=<",
156 "// ",
157 ":- ",
158 "/\ ",
159 "\/ " );
160
161
162 -- Les entrées se font caractere par caractere, ce qui permet de ne pas imposer de longueur maximale à une ligne.
163 -- La lecture des tokens ci-dessus pose un probleme : Il faut anticiper la lecture des caracteres afin de savoir si ce qui suit
164 -- est un token. Comme on ne peut pas anticiper la lecture, il faut lire les caracteres et les placer dans un buffer de
165 -- relecture si ces caracteres ne correspondent à aucun des token ci-dessus.
166 Buffer_Relecture : String(1..Taille_Token_Maxi);
167 Tete_Buffer : Positive := Buffer_Relecture'First;
168 Queue_Buffer : Positive := Tete_Buffer;
169
170
171 ------------------------------------
172 -- Les constantes messages d'erreur.
173 ------------------------------------
174 Missing_2nd_Quote : constant String := "missing 2nd quote";
175 Used_As_Argument : constant String := "used as argument";
176 Used_As_Prefix_Operator: constant String := "used as prefix operator";
177 Operator_Not_Found : constant String := "operator not found";
178 Or_Operator_Not_Found : constant String := "or " & Operator_Not_Found;
179 Syntax_Error : constant String := "Syntax Error ! ";
180 Not_Found : constant String := "not found";
181 File_Not_Found : constant String := "File not found ";
182 Overflow_Error : constant String := "Overflow error !";
183
184
185 --------------------------------------------------------
186 -- Déclaration du fichier d'entrée et de sortie courant.
187 --------------------------------------------------------
188 Entree_Courante : File_Type;
189 Sortie_Courante : File_Type;
190
191
192 ----------------
193 -- Informations.
194 ----------------
195
196
197 procedure Informations is
198 Taille : Integer;
199 begin
200 Taille := Operateur'Size / 8;
201 Infos("Table des operateurs",
202 Int32(Taille), -1, -1, Int32(Nbre_Max_Operateurs), Int32(Nbre_Max_Operateurs) * Int32(Taille));
203 Taille := Taille_Token_Maxi;
204 Infos("Table des tokens",
205 Int32(Taille), -1, -1, Int32(Table_Token'Length), Int32(Table_Token'Length) * Int32(Taille));
206 end Informations;
207
208
209 -----------------------------------------------
210 -- Les primitives d'écriture d'un objet PROLOG.
211 -----------------------------------------------
212
213
214 procedure Ecrit(Objet : Mot; Avec_Quote : Boolean := True) is -- Ecrit l'objet PROLOG sur la sortie standard.
215
216
217 procedure Ecrit_Obj(Objet : Mot); -- Référence en avant.
218
219
220 -- Inclus dans ECRIT.
221 procedure Ecrit_Liste(Objet : Mot) is
222 -- En entrée : OBJET = la liste à afficher.
223 -- Exemple de sortie : [E1, E2, ..., En] ou [E1, E2, ... En|Em]
224 Obj : Mot := Objet;
225 begin
226 Put('[');
227 Ecrit_Obj(Premier(Obj));
228 Obj := Reste(Obj);
229 loop
230 if not Doublet_L(Obj) then
231 if not Egalite_Mot(Obj, Liste_Vide) then Put('|'); Ecrit_Obj(Obj); end if;
232 exit;
233 else
234 Put(", ");
235 Ecrit_Obj(Premier(Obj));
236 Obj := Reste(Obj);
237 end if;
238 end loop;
239 Put(']');
240 end Ecrit_Liste;
241
242
243 -- Inclus dans ECRIT.
244 procedure Ecrit_Vecteur(Objet : Mot) is
245 -- En entrée : OBJET = le vecteur à afficher. Exemple de sortie : (E1, E2, ..., En).
246 Obj : Mot := Objet;
247 begin
248 Put('(');
249 loop
250 Ecrit_Obj(Premier(Obj));
251 Obj := Reste(Obj);
252 exit when not Doublet_V(Obj);
253 Put(", ");
254 end loop;
255 Put(')');
256 end Ecrit_Vecteur;
257
258
259 -- Inclus dans ECRIT.
260 procedure Ecrit_Obj(Objet : Mot) is -- Ecrit l'objet PROLOG sur la sortie standard.
261 begin
262 if Symbole(Objet) then
263 Symbole_Chaine(Objet, Pname_Buffer, Pname_Long, Pname_Print_Quote); -- Représentation externe brute du symbole
264 if Pname_Print_Quote and Avec_Quote then Put('''); end if; -- Si nécessaire on entoure avec des quotes '...'
265 for I in 1..Pname_Long loop
266 if Pname_Buffer(I) = ''' and Avec_Quote then
267 Put("''"); -- Si une quote alors on double la quote (convention)
268 else
269 Put(Pname_Buffer(I));
270 end if;
271 end loop;
272 if Pname_Print_Quote and Avec_Quote then Put('''); end if;
273 elsif Entier(Objet) then Put(Entier_Val(Objet), 1);
274 elsif Variable(Objet) then
275 Put('_');
276 if Variable_Rang(Objet) /= 0 then Put(Variable_Rang(Objet), 1); end if;
277 elsif Doublet_L(Objet) then -- Forme [E1, E2, ..., En|Em]
278 Ecrit_Liste(Objet);
279 elsif Doublet_V(Objet) then -- Forme (E1, E2, ..., En)
280 Ecrit_Vecteur(Objet);
281 elsif Doublet_F(Objet) then -- Forme f(...)
282 Ecrit_Obj(Premier(Objet));
283 if Doublet(Reste(Objet)) then
284 Ecrit_Obj(Reste(Objet));
285 else
286 Ecrit_Obj(Vecteur_Vide);
287 end if;
288 end if;
289 end Ecrit_Obj;
290
291
292 begin -- ECRIT
293 Ecrit_Obj(Objet);
294 end Ecrit;
295
296
297 ----------------------------------
298 -- Gestion des erreurs de syntaxe.
299 ----------------------------------
300
301
302 procedure Vide_Entree is -- Vide le tampon d'entrée, suite à une erreur de syntaxe.
303 Sauve_Echo : Boolean := Echo;
304 Pas_Fichier : Boolean := Name(Standard_Input) = Name(Current_Input);
305 begin
306 Echo := True;
307 loop
308 if Carac_Lu = Fin_De_Fichier then exit;
309 elsif Carac_Lu = '.' then
310 if Lit_Carac <= ' ' or else Carac_Lu = '%' then exit; end if;
311 elsif Pas_Fichier and then Carac_Lu = Ascii.Cr then exit; -- Si entrée depuis clavier alors on arrete si <CR>.
312 else
313 Carac_Lu := Lit_Carac;
314 end if;
315 end loop;
316 Echo := Sauve_Echo;
317 end Vide_Entree;
318
319
320 procedure Syntaxe(Msg : String) is -- Juste un message à afficher.
321 begin
322 New_Line;
323 Put(Syntax_Error);
324 Put_Line(Msg);
325 Vide_Entree;
326 raise Erreur_De_Syntaxe;
327 end Syntaxe;
328
329
330 procedure Syntaxe(Objet : Mot; Msg : String) is -- Un objet PROLOG et un message à afficher.
331 Obj : Mot := Objet;
332 begin
333 if Egalite_Mot(Obj, S_Point_Cr) then Obj := S_Point; end if; -- Remplacé car affichage provoque retour à la ligne.
334 New_Line;
335 Put(Syntax_Error);
336 Put('''); Ecrit(Obj); Put(''');
337 Put(' ');
338 Put_Line(Msg);
339 Vide_Entree;
340 raise Erreur_De_Syntaxe;
341 end Syntaxe;
342
343
344 -------------------------------------------
345 -- Entrée de bas niveau (niveau caractere).
346 -------------------------------------------
347
348
349 procedure Entree_Standard is -- Entrée depuis l'unité standard par défaut.
350 begin
351 if Is_Open(Entree_Courante) then Close(Entree_Courante); end if;
352 Set_Input(Standard_Input);
353 Entree_Depuis_Standard := True;
354 Carac_Lu := ' ';
355 end Entree_Standard;
356
357
358 function Entree_Fichier(Symb : Mot) return Boolean is -- Entrée depuis le fichier indiqué par le symbole SYMB.
359 begin
360 Symbole_Chaine(Symb, Pname_Buffer, Pname_Long, Pname_Print_Quote);
361 if Is_Open(Entree_Courante) then Close(Entree_Courante); end if;
362 Open(Entree_Courante, In_File, Pname_Buffer(1..Pname_Long));
363 Set_Input(Entree_Courante);
364 Entree_Depuis_Standard := Name(Current_Input) = Name(Standard_Input);
365 Carac_Lu := ' ';
366 return True;
367 exception
368 when Name_Error =>
369 Put(File_Not_Found);
370 Put('"'); Put(Pname_Buffer(1..Pname_Long)); Put('"'); New_Line;
371 Entree_Standard;
372 return False;
373 end Entree_Fichier;
374
375
376 procedure Ecrit_Buffer_Relecture(C: Character) is -- Place le caractere dans le buffer de re-lecture.
377 begin
378 Buffer_Relecture(Tete_Buffer) := C;
379 Tete_Buffer := Tete_Buffer + 1;
380 if Tete_Buffer > Buffer_Relecture'Last then
381 Tete_Buffer := Buffer_Relecture'First;
382 end if;
383 if Tete_Buffer = Queue_Buffer then
384 raise Buffer_Relect_Plein;
385 end if;
386 end Ecrit_Buffer_Relecture;
387
388
389 function Buffer_Relecture_Vide return Boolean is -- Renvoie vrai si le buffer de re-lecture est vide.
390 begin
391 return Tete_Buffer = Queue_Buffer;
392 end Buffer_Relecture_Vide;
393
394
395 function Lit_Buffer_Relecture return Character is -- Lecture depuis le buffer de re-lecture.
396 begin
397 if Buffer_Relecture_Vide then
398 raise Buffer_Relect_Vide;
399 end if;
400 Carac_Lu := Buffer_Relecture(Queue_Buffer);
401 Queue_Buffer := Queue_Buffer + 1;
402 if Queue_Buffer > Buffer_Relecture'Last then
403 Queue_Buffer := Buffer_Relecture'First;
404 end if;
405 return Carac_Lu;
406 end Lit_Buffer_Relecture;
407
408
409 function Lit_Carac return Character is -- Lecture d'un caractere. Ne reconnait pas les commentaires.
410 begin
411 if not Buffer_Relecture_Vide then
412 return Lit_Buffer_Relecture;
413 elsif End_Of_Line then
414 Skip_Line;
415 Carac_Lu := Ascii.Cr;
416 if Echo then New_Line; end if;
417 return Ascii.Cr;
418 else
419 Get(Carac_Lu);
420 if Echo then Put(Carac_Lu); end if;
421 if Carac_Lu = Ascii.Eot then Debug; end if;
422 if Carac_Lu = Ascii.Enq then Echo := not Echo; end if;
423 return Carac_Lu;
424 end if;
425 exception
426 when End_Error => Carac_Lu := Fin_De_Fichier;
427 return Fin_De_Fichier;
428 end Lit_Carac;
429
430
431 function Caractere_Significatif(C : Character) return Character is -- Renvoie le 1er caractere significatif à partir de C.
432 begin
433 Carac_Lu := C;
434 loop
435 if Carac_Lu = '%' then -- Début de commentaire
436 while Lit_Carac /= Fin_De_Fichier and then -- Recherche la fin de la ligne
437 Carac_Lu /= Ascii.Cr loop null; end loop;
438 elsif Carac_Lu = Fin_De_Fichier or Carac_Lu > ' ' then return Carac_Lu;
439 elsif Lit_Carac /= '%' and then
440 (Carac_Lu = Fin_De_Fichier or Carac_Lu > ' ') then return Carac_Lu;
441 end if;
442 end loop;
443 end Caractere_Significatif;
444
445
446 ------------------------------------------------------------
447 -- Entrée de niveau intermédiaire : reconnaissance de token.
448 ------------------------------------------------------------
449
450
451 function Val_Chiffre(C : Character) return Natural is -- Renvoie la valeur entre 0 et 9 du caractere C dans '0'..'9'.
452 begin
453 return Character'Pos(C) - Character'Pos('0');
454 end Val_Chiffre;
455
456
457 function Lit_Nombre return Mot is -- On part d'un caractere déjà lu.
458 V : Type_Nombre := Val_Chiffre(Carac_Lu); -- TYPE_NOMBRE fourni par le package OBJETS_PROLOG.
459 begin
460 while Lit_Carac in '0'..'9' loop
461 V := V * 10 + Val_Chiffre(Carac_Lu);
462 end loop;
463 return Cree_Entier(V);
464 exception
465 when Numeric_Error => Put_Line(Overflow_Error);
466 Vide_Entree;
467 raise Erreur_De_Syntaxe;
468 end Lit_Nombre;
469
470
471 procedure Lit_Symbvar is -- On part d'un caractere déjà lu.
472 begin
473 Pname_Print_Quote := False;
474 for I in Pname_Buffer'range loop
475 Pname_Buffer(I) := Carac_Lu;
476 if not Caractere_De_Symbole(Lit_Carac) then
477 Pname_Long := I;
478 return;
479 end if;
480 end loop;
481 -- Ici le buffer est plein. On va rechercher la fin du symbole sans stocker les caracteres rencontrés.
482 while Caractere_De_Symbole(Lit_Carac) loop
483 null;
484 end loop;
485 Pname_Long := Pname_Buffer'Last;
486 return;
487 end Lit_Symbvar;
488
489
490 function Lit_Symbole return Mot is -- Lecture d'un symbole. On a déjà lu le 1er caractere.
491 begin
492 Lit_Symbvar;
493 return Cree_Symbole(Pname_Buffer(1..Pname_Long), Pname_Print_Quote);
494 end Lit_Symbole;
495
496
497 function Lit_Variable return Mot is -- Lecture d'une variable. On a déjà lu le 1er caractere (majuscule).
498 begin
499 Lit_Symbvar;
500 return Cree_Variable(Pname_Buffer(1..Pname_Long));
501 end Lit_Variable;
502
503
504 function Lit_Symbchaine return Mot is -- On part d'un caractere déjà lu et qui est ' (quote).
505 begin
506 Pname_Print_Quote := False; -- Passera à vrai si la chaine contient des break-characters.
507 Pname_Long := 0;
508 loop
509 if Lit_Carac = Fin_De_Fichier then
510 Syntaxe(Missing_2nd_Quote);
511 elsif Carac_Lu = Ascii.Cr then -- Une fin de ligne est codée par CR + LF.
512 Pname_Long := Pname_Long + 1;
513 exit when Pname_Long > Pname_Buffer'Length;
514 Pname_Buffer(Pname_Long) := Ascii.Cr;
515 Pname_Print_Quote := True; -- A partir d'ici on est sur que le CR a été stocké.
516 Pname_Long := Pname_Long + 1;
517 exit when Pname_Long > Pname_Buffer'Length;
518 Pname_Buffer(Pname_Long) := Ascii.Lf;
519 elsif Carac_Lu = ''' then
520 if Lit_Carac = ''' then -- Une double quote signifie une quote dans la chaine.
521 Pname_Long := Pname_Long + 1;
522 exit when Pname_Long > Pname_Buffer'Length;
523 Pname_Buffer(Pname_Long) := Carac_Lu;
524 Pname_Print_Quote := True;
525 else -- Une simple quote indique la fin de la chaine.
526 Pname_Print_Quote := (Pname_Long=0) or Pname_Print_Quote; -- Si chaine vide alors il faut entourer par des quotes.
527 return Cree_Symbole(Pname_Buffer(1..Pname_Long), Pname_Print_Quote); -- Renvoie symbole correspondant à chaine analysée.
528 end if;
529 else
530 Pname_Long := Pname_Long + 1;
531 exit when Pname_Long > Pname_Buffer'Length;
532 Pname_Buffer(Pname_Long) := Carac_Lu;
533 Pname_Print_Quote := not Caractere_De_Symbole(Carac_Lu) or Pname_Print_Quote;
534 end if;
535 end loop;
536 -- Ici le buffer est plein. On va rechercher la fin de la chaine.
537 loop
538 if Lit_Carac = Fin_De_Fichier then
539 Syntaxe(Missing_2nd_Quote);
540 elsif Carac_Lu = ''' and then
541 Lit_Carac /= ''' then
542 return Cree_Symbole(Pname_Buffer(1..Pname_Long), Pname_Print_Quote); -- Renvoie symbole correspondant à chaine analysée
543 end if;
544 end loop;
545 end Lit_Symbchaine;
546
547
548 function Lit_Token_Aux return Mot is -- Reconnaissance des tokens spéciaux tels que =:= :- =.. etc...
549 type Result is (Non_Trouve, Possible, Trouve, Trouve_Long_Max);
550 Indice_Debut : Integer := Table_Token'First;
551 Indice_Fin : Integer := Table_Token'Last;
552 Pos_Carac : Integer := 1;
553
554 function Cherche_Token(Carac : Character) return Result is -- Recherche du token en cours dans la table des tokens.
555 begin
556 for I in Indice_Debut..Indice_Fin loop
557 if Table_Token(I)(Pos_Carac) = ' ' then -- Un espace indique la fin du token.
558 return Trouve;
559 elsif Table_Token(I)(Pos_Carac) = Carac then
560 if Pos_Carac = Taille_Token_Maxi then -- Si on en est au dernier caractere alors terminé.
561 return Trouve_Long_Max;
562 else
563 Indice_Debut := I;
564 for J in Indice_Debut..Indice_Fin loop -- Recherche la position du dernier token ayant les memes caracteres
565 exit when Table_Token(J)(Pos_Carac) /= Carac;
566 Indice_Fin := J;
567 end loop;
568 return Possible;
569 end if;
570 end if;
571 end loop;
572 return Non_Trouve;
573 end Cherche_Token;
574
575 begin
576 loop
577 Pname_Buffer(Pos_Carac) := Carac_Lu;
578 case Cherche_Token(Carac_Lu) is
579 when Non_Trouve =>
580 for I in 2..Pos_Carac loop -- Pour faire comme si on n'avait lu que le 1er caractere
581 Ecrit_Buffer_Relecture(Pname_Buffer(I));
582 end loop;
583 Carac_Lu := Lit_Carac; -- Pour la suite de l'analyse
584 if Pname_Buffer(1) = '.' and then (Carac_Lu <= ' ' or else Carac_Lu ='%') then
585 return S_Point_Cr; -- Renvoie un symbole spécial indiquant la fin de la saisie
586 else
587 return Cree_Symbole(Pname_Buffer(1..1)); -- Le token est un break character
588 end if;
589 when Trouve => -- Ici on a lu un caractere de trop, ce qui est parfait
590 return Cree_Symbole(Pname_Buffer(1..Pos_Carac-1));
591 when Trouve_Long_Max => -- Ici on n'a lu que les caracteres du token
592 Carac_Lu := Lit_Carac;
593 return Cree_Symbole(Pname_Buffer(1..Pos_Carac));
594 when Possible => -- Jusque là, les caracteres lus concordent avec le début d'un token
595 Pos_Carac := Pos_Carac + 1; -- Pour comparer le prochain caractere du token...
596 Carac_Lu := Lit_Carac; -- ...avec le caractere lu suivant
597 end case;
598 end loop;
599 end Lit_Token_Aux;
600
601
602 function Lit_Token return Mot is -- Lecture d'un token. On part d'un caractere déjà lu.
603 begin
604 if Caractere_Significatif(Carac_Lu) = Fin_De_Fichier then raise Fin_Du_Fichier; end if;
605 case Carac_Lu is
606 when '0'..'9' => Token := Lit_Nombre;
607 when 'A'..'Z' | '_' => Token := Lit_Variable;
608 when ''' => Token := Lit_Symbchaine;
609 when others => if Caractere_De_Symbole(Carac_Lu) then
610 Token := Lit_Symbole;
611 else
612 Token := Lit_Token_Aux;
613 end if;
614 end case;
615 return Token;
616 end Lit_Token;
617
618
619 -------------------------------------------------
620 -- Entrée de haut niveau avec analyse syntaxique.
621 -------------------------------------------------
622
623
624 function Analyse(Objet : Mot; Coef_Droit : Priorite) return Mot; -- Pré-déclaration car fonction récursive indirecte.
625
626
627 function Terminateur(Objet : Mot) return Boolean is -- Vrai si OBJET indique la fin de la saisie. Ex : '.' suivi d'un <CR>
628 begin
629 if Symbole(Objet) then
630 for I in Terminat'range loop
631 if Egalite_Mot(Objet, Terminat(I)) then return True; end if;
632 end loop;
633 end if;
634 return False;
635 end Terminateur;
636
637
638 function Delimiteur(Objet : Mot) return Boolean is -- Vrai si OBJET est un délimiteur. Ex : ')' ']' '|'
639 begin
640 if Symbole(Objet) then
641 for I in Delimit'range loop
642 if Egalite_Mot(Objet, Delimit(I)) then return True; end if;
643 end loop;
644 end if;
645 return Terminateur(Objet);
646 end Delimiteur;
647
648
649 procedure Recherche_Operateur(Objet : Mot) is -- Recherche les caractéristiques de l'opérateur OBJET.
650 begin
651 for I in Carac_Op'range loop -- Pour chaque type PREFIXE, INFIXE et POSTFIXE
652 Carac_Op(I).Op := Objet; -- L'opérateur étudié est OBJET
653 Carac_Op(I).Type_Op := Libre; -- Pour l'instant, il n'est d'aucun type connu.
654 end loop;
655 if Topop /= Table_Op'First then -- Si table non vide
656 for I in Table_Op'First..Topop-1 loop -- Parcourt la table pour voir si OBJET y existe
657 if Table_Op(I).Type_Op /= Libre and then Egalite_Mot(Objet, Table_Op(I).Op) then
658 Carac_Op(Table_Op(I).Type_Op) := Table_Op(I);
659 end if;
660 end loop;
661 end if;
662 end Recherche_Operateur;
663
664
665 function Op_Prefixe(Objet : Mot) return Boolean is -- Vrai si OBJET est un opérateur préfixé.
666 begin
667 if not Symbole(Objet) then return False; end if;
668 if not Egalite_Mot(Objet, Carac_Op(Prefixe).Op) then
669 Recherche_Operateur(Objet);
670 end if;
671 return Carac_Op(Prefixe).Type_Op /= Libre;
672 end Op_Prefixe;
673
674
675 function Op_Infixe(Objet : Mot) return Boolean is -- Vrai si OBJET est un opérateur infixé.
676 begin
677 if not Symbole(Objet) then return False; end if;
678 if not Egalite_Mot(Objet, Carac_Op(Infixe).Op) then
679 Recherche_Operateur(Objet);
680 end if;
681 return Carac_Op(Infixe).Type_Op /= Libre;
682 end Op_Infixe;
683
684
685 function Op_Postfixe(Objet : Mot) return Boolean is -- Vrai si OBJET est un opérateur postfixé.
686 begin
687 if not Symbole(Objet) then return False; end if;
688 if not Egalite_Mot(Objet, Carac_Op(Postfixe).Op) then
689 Recherche_Operateur(Objet);
690 end if;
691 return Carac_Op(Postfixe).Type_Op /= Libre;
692 end Op_Postfixe;
693
694
695 function Renvoie_Coef_Gauche(Objet : Mot; Type_Op : Type_Operateur) return Priorite is -- Coef gauche de l'opérateur OBJET.
696 begin
697 if not Egalite_Mot(Objet, Carac_Op(Type_Op).Op) then
698 Recherche_Operateur(Objet);
699 end if;
700 if Carac_Op(Type_Op).Type_Op /= Libre then
701 return Carac_Op(Type_Op).Prio_G;
702 else
703 return 0;
704 end if;
705 end Renvoie_Coef_Gauche;
706
707
708 function Renvoie_Coef_Droit(Objet : Mot; Type_Op : Type_Operateur) return Priorite is -- Coef droit de l'opérateur OBJET.
709 begin
710 if not Egalite_Mot(Objet, Carac_Op(Type_Op).Op) then
711 Recherche_Operateur(Objet);
712 end if;
713 if Carac_Op(Type_Op).Type_Op /= Libre then
714 return Carac_Op(Type_Op).Prio_D;
715 else
716 return 0;
717 end if;
718 end Renvoie_Coef_Droit;
719
720
721 function Multarg(Objet : Mot) return Boolean is -- Renvoie vrai si l'opérateur accepte un nbre quelconque d'arguments.
722 begin
723 if not Symbole(Objet) then return False; end if;
724 if not Egalite_Mot(Objet, Carac_Op(Infixe).Op) then -- Seuls les opérateurs infixés peuvent avoir cette propriété.
725 Recherche_Operateur(Objet);
726 end if;
727 if Carac_Op(Infixe).Type_Op /= Libre then
728 return Carac_Op(Infixe).Multiple;
729 else
730 return False;
731 end if;
732 end Multarg;
733
734
735 function Associe(Objet, Delim : Mot) return Mot is -- Renvoie le vecteur des expressions rencontrées jusqu'à DELIM.
736 Obj : Mot;
737 begin
738 Token := Objet;
739 if Egalite_Mot(Token, Delim) then -- Si on a trouvé le délimiteur.
740 Token := Lit_Token; -- Saute le délimiteur.
741 return Vecteur_Vide; -- Pas d'expression rencontrée avant le délimiteur.
742 elsif Delimiteur(Token) then -- On a trouvé un délimiteur, mais ce n'est pas le bon.
743 Syntaxe(Delim, Not_Found);
744 return Vecteur_Vide; -- Pour éviter warning
745 else
746 Obj := Analyse(Token, 0);
747 if Egalite_Mot(Token, Delim) then -- Si on a trouvé le délimiteur.
748 Token := Lit_Token; -- Saute le délimiteur.
749 if Doublet_V(Obj) then
750 return Obj; -- Si vecteur alors renvoie tel quel.
751 else
752 return Cree_Vecteur(Obj); -- Sinon renvoie <expression>.
753 end if;
754 else
755 Syntaxe(Delim, Or_Operator_Not_Found); -- On n'a pas trouvé le délimiteur.
756 return Vecteur_Vide; -- Pour éviter warning
757 end if;
758 end if;
759 end Associe;
760
761
762 function Analyse_Liste return Mot is -- On vient de lire le token '['.
763 Objet1, Objet2 : Mot;
764 begin
765 if Egalite_Mot(Lit_Token, S_Crochet_Droit) then -- Si déjà ']' alors...
766 Token := Lit_Token; -- ...saute le ']' et...
767 return Liste_Vide; -- ...renvoie [].
768 else
769 Objet1 := Analyse(Token, 0);
770 if Doublet_V(Objet1) then
771 Objet1 := Vecteur_Liste(Objet1); -- Convertit physiquement le vecteur en liste.
772 else
773 Objet1 := Cree_Liste(Objet1);
774 end if;
775 if Egalite_Mot(Token, S_Barre_V) then -- Si '|' rencontré alors...
776 Objet2 := Analyse(Lit_Token, -- ...lit l'expression suivante
777 Renvoie_Coef_Droit(S_Barre_V, Infixe));
778 else
779 Objet2 := Liste_Vide; -- sinon assume la queue de la liste à [].
780 end if;
781 if Egalite_Mot(Token, S_Crochet_Droit) then -- Si on a rencontré ']' alors c'est correct.
782 Token := Lit_Token; -- Saute le ']'.
783 return Concatene(Objet1, Objet2); -- Rattache la queue de la liste.
784 else
785 Syntaxe(S_Crochet_Droit, Not_Found);
786 return Liste_Vide; -- Pour éviter warning
787 end if;
788 end if;
789 end Analyse_Liste;
790
791
792 function Op_Prefixe_Special(Objet : Mot) return Boolean is-- Renvoie VRAI si OBJET est un opérateur préfixé spécial.
793 begin
794 return Egalite_Mot(Objet, S_Moins) or else -- -expr
795 Egalite_Mot(Objet, S_Plus) or else -- +expr
796 Egalite_Mot(Objet, S_Par_Gauche) or else -- (expr
797 Egalite_Mot(Objet, S_Crochet_Gauche); -- [expr
798 end Op_Prefixe_Special;
799
800
801 function Analyse_Prefixe_Special(Op : Mot; Coef_Droit : Priorite) return Mot is -- Renvoie résultat du traitement spécial.
802 -- Précise les traitements particuliers lorsque les coefs de priorité ne suffisent pas pour coder l'expression.
803 Objet : Mot;
804 begin
805 if Egalite_Mot(Op, S_Moins) then -- Le 'moins' unaire.
806 Objet := Analyse(Lit_Token, Priorite_Prefixe_Unaire);
807 if Entier(Objet) then
808 return Cree_Entier(- Entier_Val(Objet));
809 elsif Doublet_V(Objet) or else
810 Egalite_Mot(Objet, Vecteur_Vide) then -- Si '-' utilisé comme functor. Ex : -(a,b).
811 return Cree_Doublet_F(S_Moins, Objet);
812 else -- C'est vraiment le '-' unaire.
813 return Cree_Doublet_F(S_Moins, Cree_Vecteur(Objet));
814 end if;
815 elsif Egalite_Mot(Op, S_Plus) then -- Le 'plus' unaire.
816 Objet := Analyse(Lit_Token, Priorite_Prefixe_Unaire);
817 if Entier(Objet) then
818 return Objet;
819 elsif Doublet_V(Objet) or else
820 Egalite_Mot(Objet, Vecteur_Vide) then -- Si '+' utilisé comme functor. Ex : +(a,b).
821 return Cree_Doublet_F(S_Plus, Objet);
822 else -- C'est vraiment le '+' unaire.
823 return Cree_Doublet_F(S_Plus, Cree_Vecteur(Objet));
824 end if;
825 elsif Egalite_Mot(Op, S_Par_Gauche) then -- La parenthese en utilisation préfixée.
826 if Egalite_Mot(Lit_Token, S_Par_Droite) then
827 Token := Lit_Token; -- Saute la ')'.
828 return Vecteur_Vide;
829 else
830 Objet := Analyse(Token, 0);
831 if Egalite_Mot(Token, S_Par_Droite) then
832 Token := Lit_Token; -- Saute la ')'.
833 if Doublet_V(Objet) then
834 return Objet;
835 else
836 return Cree_Vecteur(Objet);
837 end if;
838 else
839 Syntaxe(S_Par_Droite, Not_Found);
840 end if;
841 end if;
842 elsif Egalite_Mot(Op, S_Crochet_Gauche) then -- Le '[' de début de liste.
843 return Analyse_Liste;
844 end if;
845 return Vecteur_Vide; -- To avoid warning
846 end Analyse_Prefixe_Special;
847
848
849 function Op_Infixe_Special(Objet : Mot) return Boolean is -- Renvoie vrai si OBJET est un opérateur infixé spécial.
850 begin
851 return Egalite_Mot(Objet, S_Par_Gauche) or else -- E1 ( E2
852 Egalite_Mot(Objet, S_Virgule); -- E1 , E2
853 end Op_Infixe_Special;
854
855
856 function Analyse_Infixe_Special(Expr_Gauche, Op : Mot) return Mot is --Renvoie expression résultant du traitement spécial.
857 -- Précise les traitements particuliers lorsque les coefs de priorité ne suffisent pas pour coder l'expression.
858 Objet : Mot;
859 begin
860 if Egalite_Mot(Op, S_Par_Gauche) then -- Transforme f(a,b...) en (f a b ...)
861 if Symbole(Expr_Gauche) or else Variable(Expr_Gauche) then -- Autorise f(...), 9(...) et X(...)
862 return Cree_Doublet_F(Expr_Gauche, Associe(Lit_Token, S_Par_Droite));
863 else
864 Syntaxe(Operator_Not_Found);
865 return Vecteur_Vide; -- Pour éviter warning
866 end if;
867 elsif Egalite_Mot(Op, S_Virgule) then -- La virgule est l'opérateur de création de vecteur.
868 Objet := Analyse(Lit_Token, Renvoie_Coef_Droit(S_Virgule, Infixe));
869 if Doublet_V(Objet) and not Sortie_Analyse_Passe1 then
870 return Cree_Doublet_V(Expr_Gauche, Objet);
871 else
872 return Cree_Doublet_V(Expr_Gauche, Cree_Vecteur(Objet));
873 end if;
874 end if;
875 return Vecteur_Vide; -- Pour éviter warning
876 end Analyse_Infixe_Special;
877
878
879 function Op_Postfixe_Special(Objet : Mot) return Boolean is -- Renvoie vrai si OBJET est un opérateur postfixé spécial.
880 begin
881 return False;
882 end Op_Postfixe_Special;
883
884
885 function Analyse_Postfixe_Special(Expr_Gauche, Op : Mot) return Mot is -- Renvoie expression résultant du traitement spécial.
886 -- Précise les traitements particuliers lorsque les coefs de priorité ne suffisent pas pour coder l'expression.
887 begin
888 return Vecteur_Vide;
889 end Analyse_Postfixe_Special;
890
891
892 function Analyse(Objet : Mot; Coef_Droit : Priorite) return Mot is
893 Objet1 : Mot := Objet; -- L'expression de gauche courante.
894 Objet2 : Mot; -- L'opérateur infixé ou préfixé courant.
895 begin
896 if Delimiteur(Objet1) then
897 Syntaxe(Objet1, Used_As_Argument);
898 elsif Op_Prefixe_Special(Objet1) then -- Par exemple : +expr..., -expr... , (expr..., [expr...
899 Objet1 := Analyse_Prefixe_Special(Objet1, Coef_Droit);
900 else
901 Token := Lit_Token;
902 if not Egalite_Mot(Token, S_Par_Gauche) then
903 if Op_Prefixe(Objet1) then
904 -- Ici OBJET1 est un opérateur préfixé.
905 Objet1 := Cree_Doublet_F(Objet1,
906 Cree_Vecteur(Analyse(Token,
907 Renvoie_Coef_Droit(Objet1, Prefixe))));
908 elsif Op_Infixe(Objet1) or else Op_Postfixe(Objet1) then
909 -- Erreur car ici on ne peut avoir qu'un opérateur préfixé.
910 Syntaxe(Objet1, Used_As_Prefix_Operator);
911 end if;
912 end if;
913 end if;
914 -- Ici on s'occupe des expressions de la forme ...op E1 opA E2 opB E3 opC...
915 -- L'analyse a debuté à partir de E1 en connaissant le coef à droite de op.
916 -- Dans la boucle : COEF_DROIT = coef à droite de op
917 -- OBJET1 = E1, puis E1 opA E2, puis (E1 opA E2) opB E3 etc...
918 -- OBJET2 = l'opérateur infixé ou postfixé opX courant
919 -- Les opérateurs à arguments multiples sont codés sous la forme (op E1 E2...En) plutot que (op...(op (op E1 E2) E3)...En)
920 Sortie_Analyse_Passe1 := True; -- Pour savoir si résultat sans opérateur infixe ou postfixe
921 loop
922 Objet2 := Token;
923 if Delimiteur(Objet2) then return Objet1;
924 elsif (Op_Infixe(Objet2) and then Renvoie_Coef_Gauche(Objet2, Infixe) <= Coef_Droit) or else
925 (Op_Postfixe(Objet2) and then Renvoie_Coef_Gauche(Objet2, Postfixe) <= Coef_Droit) then return Objet1;
926 elsif Op_Infixe_Special(Objet2) then -- Par exemple : E1 ( E2
927 Objet1 := Analyse_Infixe_Special(Objet1, Objet2);
928 elsif Op_Infixe(Objet2) then
929 -- Ici OBJET2 est un opérateur infixé.
930 if Doublet_F(Objet1)
931 and then Egalite_Mot(Objet2, Premier(Objet1)) -- Si associativité...
932 and then Multarg(Objet2) then -- ...et opérateur à arguments multiples...
933 Call(Concatene(Objet1, -- alors regroupe les arguments
934 Cree_Vecteur(Analyse(Lit_Token,
935 Renvoie_Coef_Droit(Objet2, Infixe)))));
936 else -- Ici opérateur infixé à deux arguments : (op E1 E2)
937 Objet1 := Cree_Doublet_F(Objet2,
938 Cree_Vecteur(Objet1,
939 Analyse(Lit_Token,
940 Renvoie_Coef_Droit(Objet2, Infixe))));
941 end if;
942 elsif Op_Postfixe_Special(Objet2) then
943 Objet1 := Analyse_Postfixe_Special(Objet2, Objet1);
944 elsif Op_Postfixe(Objet2) then
945 -- Ici OBJET2 est un opérateur postfixé, donc il s'applique à l'expression de gauche OBJET1.
946 Objet1 := Cree_Doublet_F(Objet2, Cree_Vecteur(Objet1));
947 Call(Lit_Token);
948 elsif Op_Prefixe(Objet2) then
949 -- Ici OBJET2 est un opérateur préfixé, donc ne peut pas s'appliquer à l'expression de gauche.
950 Syntaxe(Operator_Not_Found);
951 else
952 -- Ici OBJET2 n'est pas un opérateur, donc on a deux expressions sans opérateur entre elles.
953 Syntaxe(Operator_Not_Found);
954 end if;
955 Sortie_Analyse_Passe1 := False;
956 end loop;
957 end Analyse;
958
959
960 function Analyse_Complete(Objet : Mot) return Mot is -- La fonction d'analyse d'une expression PROLOG. On part d'un token lu
961 Obj : Mot;
962 begin
963 Obj := Analyse(Objet, 0);
964 if not Terminateur(Token) then Syntaxe(Operator_Not_Found); end if;
965 return Obj;
966 end Analyse_Complete;
967
968
969 begin
970
971 --------------------------
972 -- Pour la mise au point :
973 --------------------------
974
975 --PUT_LINE("Elaboration du package ES_PROLOG----------------------------------");
976
977 ------------------------------------------------------------------
978 -- Recherche la premiere ligne libre dans la table des opérateurs.
979 ------------------------------------------------------------------
980
981 if Table_Op(Table_Op'Last).Type_Op /= Libre then -- Teste le cas extreme ou la table serait déjà pleine.
982 raise Table_Op_Pleine;
983 end if;
984 for I in Table_Op'range loop
985 if Table_Op(I).Type_Op = Libre then
986 Topop := I;
987 exit;
988 end if;
989 end loop;
990
991
992 end Es_Prolog