File : objets_prolog.adb
1 -- Fichier OBJETS.ADB
2 -- Package de manipulation des objets de base PROLOG.
3
4
5 --with TRACE;
6 with Text_Io; use Text_Io;
7 with Int32_Io; use Int32_Io;
8 with Infos;
9
10 ----------------------------------------------------------------------------------------------------------------------------------
11
12
13 package body Objets_Prolog is
14
15
16 --TRACE1 : INTEGER := TRACE("Declaration de la table des doublets");
17 ------------------------------------------------
18 -- Déclaration de la table des doublets (nodes).
19 ------------------------------------------------
20 Taille_Table_Doublets : constant := 16300;
21 subtype Indice_Table_Doublets is Mot_Valeur range 0..Taille_Table_Doublets-1;
22
23 type T_Table_Doublets is array(Indice_Table_Doublets) of Mot;
24 type A_Table_Doublets is access T_Table_Doublets;
25 First : constant A_Table_Doublets := new T_Table_Doublets; -- FIRST est un pointeur sur un tableau.
26 Rest : constant A_Table_Doublets := new T_Table_Doublets; -- REST est un pointeur sur un tableau.
27
28 Topnod : Indice_Table_Doublets := T_Table_Doublets'First; -- Adresse du 1er doublet (node) libre.
29
30
31 --TRACE2 : INTEGER := TRACE("Declaration de la table des caracteres");
32 ------------------------------------------------------
33 -- Déclaration de la table des caracteres des p-names.
34 ------------------------------------------------------
35 Taille_Table_Carac : constant := 32767;
36 subtype Indice_Table_Carac is Positive range 1..Taille_Table_Carac;
37
38 subtype T_Table_Carac is String(Indice_Table_Carac); -- Si déclaré array(INDICE_TABLE_CARAC) of CHARACTER, erreur compil.
39 type A_Table_Carac is access T_Table_Carac;
40 Table_Carac : constant A_Table_Carac := new T_Table_Carac; -- TABLE_CARAC est un pointeur sur un tableau de caracteres.
41
42 Topcarac : Indice_Table_Carac := Table_Carac'First;
43
44
45 --TRACE3 : INTEGER := TRACE("Description d'un p-name");
46 --------------------------------------------------------
47 -- Description de la représentation interne d'un p-name.
48 --------------------------------------------------------
49 type R_Pname is record
50 Long : Natural range 0..Longmax_Pname := 0;
51 Ind_Carac : Indice_Table_Carac;
52 Print_Quote : Boolean;
53 end record;
54
55 --pragma PACK(R_PNAME); -- Le but étant de le faire loger sur 4 octets.
56
57
58 --TRACE4 : INTEGER := TRACE("Declaration de la table des symboles");
59 ----------------------------------------
60 -- Déclaration de la table des symboles.
61 ----------------------------------------
62 Nbre_Max_Symboles : constant := 2000;
63 subtype Indice_Table_Symb is Mot_Valeur range 0..Nbre_Max_Symboles-1;
64
65 subtype Symbole_Suivant is Mot_Valeur range -1..Nbre_Max_Symboles-1; -- -1 indique fin de liste.
66
67 type Struct_Symbole is record
68 Liste_Regles : Mot;
69 Pname : R_Pname;
70 Hash_Link : Symbole_Suivant;
71 end record;
72
73 type T_Table_Symb is array(Indice_Table_Symb) of Struct_Symbole;
74 type A_Table_Symb is access T_Table_Symb;
75 Table_Symb : constant A_Table_Symb := new T_Table_Symb; -- TABLE_SYMB est un pointeur sur un tableau.
76
77 Topsymb : Indice_Table_Symb := Table_Symb'First;
78
79
80 --TRACE5 : INTEGER := TRACE("Declaration de la table des hash-codes");
81 ------------------------------------------
82 -- Déclaration de la table des hash-codes.
83 ------------------------------------------
84 -- Table des entrées dans les listes chainées des symboles de meme hash-code.
85 -- Elle sera initialisée lors de l'élaboration du package.
86
87 subtype Hash_Code is Natural range 0..255;
88
89 type T_Table_Hashcode is array(Hash_Code) of Symbole_Suivant;
90 type A_Table_Hashcode is access T_Table_Hashcode;
91 Table_Hashcode : constant A_Table_Hashcode := new T_Table_Hashcode; -- TABLE_HASHCODE est un pointeur sur un tableau.
92
93
94 --TRACE6 : INTEGER := TRACE("Declaration de la table des variables");
95 -----------------------------------------
96 -- Declaration de la table des variables.
97 -----------------------------------------
98 subtype Indice_Table_Var is Mot_Valeur range 1..Nbre_Max_Var_Par_Regle; -- Les variables sont numérotées à partir de 1 (sauf _)
99
100 type T_Table_Var is array(Indice_Table_Var) of Indice_Table_Symb;
101 type A_Table_Var is access T_Table_Var;
102 Table_Var : constant A_Table_Var := new T_Table_Var; -- TABLE_VAR est un pointeur sur un tableau.
103
104 Topvar : Indice_Table_Var := Table_Var'First;
105
106
107 --TRACE7 : INTEGER := TRACE("Declaration [] et ()");
108 ---------------------------------------------------
109 -- Déclaration de la liste vide et du vecteur vide.
110 ---------------------------------------------------
111 Liste_Vide : constant Mot := (Symbole, Table_Symb'First); -- Le symbole '[]' sera le 1er symbole fabriqué (voir fin du package)
112 Vecteur_Vide : constant Mot := (Symbole, Table_Symb'First + 1); -- Le symbole '()' sera le 2nd symbole fabriqué.
113
114
115 ------------------------------------
116 -- Comparaison de deux mots mémoire.
117 ------------------------------------
118
119 function Egalite_Mot(Obj1, Obj2 : Mot) return Boolean is
120 begin
121 return Obj1.T = Obj2.T and then Obj1.Val = Obj2.Val;
122 end Egalite_Mot;
123
124
125 -------------------------------
126 -- Procédures de mise au point.
127 -------------------------------
128
129 procedure Put_Mot(Arg : Mot) is
130 begin
131 Put('(');
132 Put(Contenu_Memoire'Image(Arg.T));
133 Put(", ");
134 Put(Arg.Val, 4);
135 Put(')');
136 end;
137
138
139 procedure Put_String(Arg : String) is
140 begin
141 Put('"');
142 Put(Arg);
143 Put('"');
144 end;
145
146
147 procedure Put_R_Pname(Arg : R_Pname) is
148 begin
149 Put('(');
150 Put(Arg.Long, 2);
151 Put(", ");
152 Put_String(Table_Carac(Arg.Ind_Carac..
153 Arg.Ind_Carac+Arg.Long-1)); -- Il ne faut pas que le 1er p-name soit "".
154 Put(", ");
155 Put(Boolean'Image(Arg.Print_Quote));
156 Put(')');
157 end;
158
159
160 procedure Put_Struct_Symbole(Arg : Struct_Symbole) is
161 begin
162 Put('<');
163 Put_Mot(Arg.Liste_Regles);
164 Put(", ");
165 Put_R_Pname(Arg.Pname);
166 Put('>');
167 end;
168
169
170 procedure Dump_Table_Symb is
171 begin
172 New_Line;
173 Put_Line("----- TABLE DES SYMBOLES -----");
174 Put("TOPSYMB = "); Put(Topsymb); New_Line;
175 for I in Table_Symb'First..Topsymb-1 loop
176 Set_Col(5);
177 Put(I, 3); Put(" - ");
178 Put_Struct_Symbole(Table_Symb(I));
179 New_Line;
180 end loop;
181 end;
182
183
184 procedure Dump_Table_Doublets is
185 begin
186 New_Line;
187 Put_Line("----- TABLE DES DOUBLETS -----");
188 Put("TOPNOD = "); Put(Topnod); New_Line;
189 for I in T_Table_Doublets'First..Topnod-1 loop
190 Set_Col(5);
191 Put(I, 4); Put(" - ");
192 Put_Mot(First(I));
193 Put(' ');
194 Put_Mot(Rest(I));
195 New_Line;
196 end loop;
197 end;
198
199
200 procedure Dump_Table_Var is
201 begin
202 New_Line;
203 Put_Line("----- TABLE DES VARIABLES -----");
204 Put("TOPVAR = "); Put(Topvar); New_Line;
205 for I in Table_Var'First..Topvar-1 loop
206 Set_Col(5);
207 Put(I, 3); Put(" - ");
208 Put(Table_Var(I));
209 New_Line;
210 end loop;
211 end;
212
213
214 procedure Debug is
215 C : Character;
216 begin
217 loop
218 New_Line;
219 Put_Line("Utilitaire de mise au point.");
220 Put_Line("----------------------------");
221 Put_Line("(D) --> Dump doublets (S) --> Dump symboles (V) --> Dump variables");
222 Put_Line("(Q) --> Retour au programme");
223 Put("Votre choix ? ");
224 Get(C);
225 case C is
226 when 'D' | 'd' => Dump_Table_Doublets;
227 when 'S' | 's' => Dump_Table_Symb;
228 when 'V' | 'v' => Dump_Table_Var;
229 when 'Q' | 'q' => New_Line; return;
230 when others => null;
231 end case;
232 end loop;
233 end;
234
235
236 --------------------------------------------------------------------------------------------
237 -- Procédure utilitaire pour appeler une fonction renvoyant un MOT sans récupérer sa valeur.
238 --------------------------------------------------------------------------------------------
239
240 procedure Call(V : Mot) is
241 begin
242 null;
243 end;
244
245
246 -----------------------------------------
247 -- Procédure d'information sur les types.
248 -----------------------------------------
249
250 procedure Types_Informations is
251 begin
252 Put("Mot_Valeur'Size = "); Set_Col(20); Put(Int32(Mot_Valeur'Size / 8)); New_Line;
253 Put("Mot'Size = "); Set_Col(20); Put(Int32(Mot'Size / 8)); New_Line;
254 New_Line;
255 end;
256
257
258 ------------------------------------------
259 -- Procédure d'information sur les tables.
260 ------------------------------------------
261
262 procedure Informations is
263 Taille : Integer;
264 begin
265 Taille := Struct_Symbole'Size / 8;
266 Infos("Zone des symboles",
267 Int32(Taille), Int32(Topsymb), -1, Int32(Nbre_Max_Symboles), Int32(Nbre_Max_Symboles) * Int32(Taille));
268 Taille := Character'Size / 8;
269 Infos("Pnames associes aux symboles",
270 Int32(Taille), Int32(Topcarac), -1, Int32(Taille_Table_Carac), Int32(Taille_Table_Carac) * Int32(Taille));
271 Taille := Symbole_Suivant'Size / 8;
272 Infos("Table des hash-codes pour symboles",
273 Int32(Taille), -1, -1, Int32(Table_Hashcode'Length), Int32(Table_Hashcode'Length) * Int32(Taille));
274 Taille := Indice_Table_Symb'Size / 8;
275 Infos("Table association variable-symbole",
276 Int32(Taille), -1, -1, Int32(Nbre_Max_Var_Par_Regle), Int32(Nbre_Max_Var_Par_Regle) * Int32(Taille));
277 Taille := Mot'Size / 8;
278 Infos("Zone des doublets, FIRST",
279 Int32(Taille), Int32(Topnod), -1, Int32(Taille_Table_Doublets), Int32(Taille_Table_Doublets) * Int32(Taille));
280 Infos("Zone des doublets, REST",
281 Int32(Taille), Int32(Topnod), -1, Int32(Taille_Table_Doublets), Int32(Taille_Table_Doublets) * Int32(Taille));
282 end Informations;
283
284
285 ---------------------------------------------------------
286 -- Fonctions de reconnaissance du type d'un objet PROLOG.
287 ----------------------------------------------------------
288
289 function Entier(Obj : Mot) return Boolean is
290 begin
291 return Obj.T = Entier;
292 end Entier;
293
294
295 function Caractere_De_Symbole(C : Character) return Boolean is -- Caracteres autorisés dans un symbole non quoté
296 begin
297 return C in 'A'..'Z' or else
298 C in 'a'..'z' or else
299 C in '0'..'9' or else
300 C = '_' or else
301 Character'Pos(C) in 129..154; -- Tous les caracteres accentués
302 end Caractere_De_Symbole;
303
304
305 function Symbole(Obj : Mot) return Boolean is
306 begin
307 return Obj.T = Symbole;
308 end Symbole;
309
310
311 function Atome(Obj : Mot) return Boolean is
312 begin
313 return Obj.T in Symbole..Entier;
314 end Atome;
315
316
317 function Doublet(Obj : Mot) return Boolean is
318 begin
319 return Obj.T in Doublet_V..Doublet_L;
320 end Doublet;
321
322
323 function Doublet_V(Obj : Mot) return Boolean is
324 begin
325 return Obj.T = Doublet_V;
326 end Doublet_V;
327
328
329 function Doublet_F(Obj : Mot) return Boolean is
330 begin
331 return Obj.T = Doublet_F;
332 end Doublet_F;
333
334
335 function Doublet_L(Obj : Mot) return Boolean is
336 begin
337 return Obj.T = Doublet_L;
338 end Doublet_L;
339
340
341 function Variable(Obj : Mot) return Boolean is
342 begin
343 return Obj.T = Variable;
344 end Variable;
345
346
347 function Vect1(Obj : Mot) return Boolean is
348 begin
349 return Obj.T = Doublet_V and then Egalite_Mot(Reste(Obj), Vecteur_Vide);
350 end Vect1;
351
352
353 function Vect2(Obj : Mot) return Boolean is
354 begin
355 return Obj.T = Doublet_V and then Vect1(Reste(Obj));
356 end Vect2;
357
358
359 function Func1(Obj : Mot) return Boolean is
360 begin
361 return Doublet_F(Obj) and then Vect1(Reste(Obj));
362 end Func1;
363
364
365 function Func2(Obj : Mot) return Boolean is
366 begin
367 return Doublet_F(Obj) and then Vect2(Reste(Obj));
368 end Func2;
369
370
371 ------------------------------------------------
372 -- Garbage collecting : récupération de mémoire.
373 ------------------------------------------------
374 -- Pas encore implémenté : Quand la mémoire est pleine, c'est fini.
375
376
377 function Pname_Libre(Longueur : Natural) return Indice_Table_Carac is -- Renvoie adresse zone de LONGUEUR caracteres libres.
378 Adresse : Indice_Table_Carac;
379 begin
380 if Table_Carac'Last - Topcarac < Longueur then raise Table_Carac_Pleine;
381 else
382 Adresse := Topcarac;
383 Topcarac := Topcarac + Longueur;
384 return Adresse;
385 end if;
386 end Pname_Libre;
387
388
389 function Symbole_Libre return Indice_Table_Symb is -- Renvoie l'adresse d'un symbole libre.
390 Adresse : Indice_Table_Symb;
391 begin
392 if Topsymb = Table_Symb'Last then raise Table_Symb_Pleine;
393 else
394 Adresse := Topsymb;
395 Topsymb := Topsymb + 1;
396 return Adresse;
397 end if;
398 end Symbole_Libre;
399
400
401 function Doublet_Libre return Indice_Table_Doublets is -- Renvoie l'adresse d'un doublet libre.
402 Adresse : Indice_Table_Doublets;
403 begin
404 if Topnod = T_Table_Doublets'Last then raise Table_Doublets_Pleine;
405 else
406 Adresse := Topnod;
407 Topnod := Topnod + 1;
408 return Adresse;
409 end if;
410 end Doublet_Libre;
411
412
413 ---------------------------------------
414 -- Fonctions d'acces aux objets PROLOG.
415 ---------------------------------------
416
417 function Mot_Nul return Mot is
418 begin
419 return (Libre, 0); -- Valeur retournée en interne quand pas de résultat
420 end;
421
422
423 procedure Symbole_Chaine(Obj : in Mot;
424 Chaine : out String; Long : out Natural;
425 Print_Quote : out Boolean) is -- Représentation externe d'un symbole.
426 Pname : R_Pname;
427 begin
428 if not Symbole(Obj) then Long := 0; Print_Quote := False; return;
429 else
430 Pname := Table_Symb(Obj.Val).Pname;
431 Long := Pname.Long;
432 Chaine(Chaine'First..Pname.Long) := Table_Carac(Pname.Ind_Carac..
433 Pname.Ind_Carac+Pname.Long-1); -- 1er p-name ne doit pas etre ""
434 Print_Quote := Pname.Print_Quote;
435 end if;
436 end Symbole_Chaine;
437
438
439 function Entier_Val(Obj : Mot) return Type_Nombre is -- Renvoie la valeur numérique d'un entier.
440 begin
441 return Obj.Val;
442 end Entier_Val;
443
444
445 function Variable_Rang(Obj : Mot) return Type_Nombre is -- Renvoie le rang d'une variable.
446 begin
447 return Obj.Val;
448 end Variable_Rang;
449
450
451 function Variable_Nom(Ind : Type_Nombre) return Mot is -- Renvoie le symbole correspondant au nom d'une variable.
452 begin
453 return (Symbole, Table_Var(Ind));
454 end Variable_Nom;
455
456
457 function Premier(Obj : Mot) return Mot is -- Correspond au CAR de LISP.
458 begin
459 if Doublet(Obj) then return First(Obj.Val);
460 else return Liste_Vide;
461 end if;
462 end Premier;
463
464
465 function Reste(Obj : Mot) return Mot is -- Correspond au CDR de LISP. Le CDR d'un n-uplet est un n-uplet.
466 begin
467 if Doublet(Obj) then return Rest(Obj.Val);
468 else return Liste_Vide;
469 end if;
470 end Reste;
471
472
473 function Id_Liste_Regles(Symb : Mot) return Mot is -- Renvoie la liste des regles rattachées au symbole SYMB.
474 begin
475 if Symbole(Symb) then
476 return Table_Symb(Symb.Val).Liste_Regles;
477 else
478 return Liste_Vide;
479 end if;
480 end Id_Liste_Regles;
481
482
483 function Nbre_De_Variables return Natural is -- Renvoie le nbre de variables crées depuis le dernier RAZ_VARIABLES.
484 begin
485 return Topvar - 1;
486 end Nbre_De_Variables;
487
488
489 function Decompose_Entier(N, un_Entier : Mot) return Mot is
490 -- si N=0, Item = longueur(un_Entier'Image)
491 -- si N≠0, Item = nième caractère de un_Entier'Image.
492 -- Ada RM: The image of an integer value is the corresponding decimal literal,
493 -- without underlines, leading zeros, exponent, or trailing spaces, but
494 -- with a single leading character that is either a minus sign or a space.
495 Index : Type_Nombre := Entier_Val(N);
496 Nombre : Type_Nombre := Entier_Val(un_Entier);
497 Nombre_Image : String := Type_Nombre'Image(Nombre);
498 Length : Type_Nombre := Nombre_Image'Length;
499 begin
500 if Index = 0 then return Cree_Entier(Length); end if;
501 if Index > 0 and Index <= Length then
502 return Cree_Symbole(Nombre_Image(Index..Index),
503 not Caractere_De_Symbole(Nombre_Image(Index)));
504 end if;
505 return Mot_Nul;
506 end Decompose_Entier;
507
508
509 function Decompose_Symbole(N, un_Symbole : Mot) return Mot is
510 -- si N=0, Item = longueur(un_Symbole.pname)
511 -- si N≠0, Item = nième caractère de un_Symbole.pname.
512 Index : Type_Nombre := Entier_Val(N);
513 begin
514 Symbole_Chaine(un_Symbole, Pname_Buffer, Pname_Long, Pname_Print_Quote);
515 if Index = 0 then return Cree_Entier(Pname_Long); end if;
516 if Index > 0 and Index <= Pname_Long then
517 return Cree_Symbole(Pname_Buffer(Index..Index),
518 not Caractere_De_Symbole(Pname_Buffer(Index)));
519 end if;
520 return Mot_Nul;
521 end Decompose_Symbole;
522
523
524 function Decompose_Doublet(N, un_Doublet : Mot) return Mot is
525 -- si N=0, Item = nombre d'éléments de la liste ou du vecteur ou de la fonction
526 -- si N≠0, Item = nième élément de la liste ou du vecteur ou de la fonction
527 Index : Type_Nombre := Entier_Val(N);
528 Obj : Mot := un_Doublet;
529 begin
530 if Index = 0 then
531 loop
532 Index := Index + 1;
533 Obj := Reste(Obj);
534 exit when not Doublet(Obj);
535 end loop;
536 return Cree_Entier(Index);
537 end if;
538 if Index > 0 then
539 loop
540 Index := Index - 1;
541 if Index = 0 then return Premier(Obj); end if;
542 Obj := Reste(Obj);
543 exit when not Doublet(Obj);
544 end loop;
545 end if;
546 return Mot_Nul;
547 end Decompose_Doublet;
548
549 ----------------------------------------------
550 -- Fonctions de fabrication des objets PROLOG.
551 ----------------------------------------------
552
553 function Egal_Pname_Chaine(Pname : R_Pname; Chaine : String) return Boolean is
554 begin
555 return Pname.Long = Chaine'Length and then
556 Table_Carac(Pname.Ind_Carac..Pname.Ind_Carac + Pname.Long - 1) = Chaine(Chaine'range);
557 end Egal_Pname_Chaine;
558
559
560 function Cree_Pname(Str : String; Print_Quote : Boolean := False) return R_Pname is
561 -- En entrée : Une chaine, en sortie un record (long, ind_carac, flag).
562 Longueur : Natural := Str'Length;
563 Pname : R_Pname;
564 Adresse : Indice_Table_Carac;
565 begin
566 if Longueur > Longmax_Pname then
567 Longueur := Longmax_Pname; -- Si chaine trop longue alors on tronque.
568 end if;
569 Pname.Long := Longueur;
570 Pname.Ind_Carac := Topcarac;
571 Pname.Print_Quote := Print_Quote;
572 Adresse := Pname_Libre(Longueur);
573 Table_Carac(Adresse..Adresse+Longueur-1) := Str(Str'First..Str'First+Longueur-1);
574 return Pname;
575 end Cree_Pname;
576
577
578 function Cree_Symbole(Str : String; Print_Quote : Boolean := False) return Mot is
579 -- En entree : La représentation externe du symbole, en sortie : l'objet symbole.
580 Indice_Symb : Indice_Table_Symb;
581 Symb_Suiv : Symbole_Suivant;
582 H : Hash_Code;
583 begin
584 if Str'Length = 0 then
585 H := 0;
586 else
587 H := Character'Pos(Str(Str'First));
588 end if;
589 Symb_Suiv := Table_Hashcode(H);
590 while Symb_Suiv /= -1 loop
591 if Egal_Pname_Chaine(Table_Symb(Symb_Suiv).Pname, Str) then
592 return (Symbole, Symb_Suiv);
593 end if;
594 Symb_Suiv := Table_Symb(Symb_Suiv).Hash_Link;
595 end loop;
596 Indice_Symb := Symbole_Libre;
597 Table_Symb(Indice_Symb) := (Liste_Vide, Cree_Pname(Str, Print_Quote), Table_Hashcode(H));
598 Table_Hashcode(H) := Indice_Symb;
599 return (Symbole, Indice_Symb);
600 end Cree_Symbole;
601
602
603 function Cree_Variable(Str : String) return Mot is -- Renvoie l'objet 'variable' correspondant
604 Indice_Symb : Indice_Table_Symb;
605 Indice_Var : Indice_Table_Var;
606 begin
607 if Str = "_" then return (Variable, 0); end if; -- Variable muette pour optimiser les unifications.
608 Indice_Symb := Cree_Symbole(Str).Val;
609 if Topvar /= Table_Var'First then -- Si table non vide
610 for I in Table_Var'First..Topvar-1 loop
611 if Indice_Symb = Table_Var(I) then
612 return (Variable, I);
613 end if;
614 end loop;
615 end if;
616 Table_Var(Topvar) := Indice_Symb;
617 Indice_Var := Topvar;
618 if Topvar = Table_Var'Last then raise Table_Var_Pleine; end if;
619 Topvar := Topvar + 1;
620 return (Variable, Indice_Var);
621 end Cree_Variable;
622
623
624 function Cree_Variable(Num : Natural) return Mot is -- Création d'une variable à partir de son numéro.
625 begin
626 return (Variable, Num);
627 end Cree_Variable;
628
629
630 procedure Raz_Variables is -- Vide la table des variables (nécessaire lorsqu'on change de regle)
631 begin
632 Topvar := Table_Var'First;
633 end Raz_Variables;
634
635
636 function Cree_Entier(Nombre: Type_Nombre) return Mot is
637 begin
638 return (Entier, Nombre);
639 end Cree_Entier;
640
641
642 function Cree_Doublet_V(Car, Cdr : Mot) return Mot is -- Renvoie le doublet [CAR | CDR] étiqueté 'VECTEUR'.
643 Adresse : Indice_Table_Doublets := Doublet_Libre;
644 begin
645 First(Adresse) := Car;
646 Rest(Adresse) := Cdr;
647 return (Doublet_V, Adresse);
648 end Cree_Doublet_V;
649
650
651 function Cree_Doublet_F(Car, Cdr : Mot) return Mot is -- Renvoie le doublet [CAR | CDR] étiqueté 'FONCTION'.
652 Adresse : Indice_Table_Doublets := Doublet_Libre;
653 begin
654 First(Adresse) := Car;
655 Rest(Adresse) := Cdr;
656 return (Doublet_F, Adresse);
657 end Cree_Doublet_F;
658
659
660 function Cree_Doublet_L(Car, Cdr : Mot) return Mot is -- Renvoie le doublet [CAR | CDR] étiqueté 'LISTE'.
661 Adresse : Indice_Table_Doublets := Doublet_Libre;
662 begin
663 First(Adresse) := Car;
664 Rest(Adresse) := Cdr;
665 return (Doublet_L, Adresse);
666 end Cree_Doublet_L;
667
668
669 function Concatene(Obj1, Obj2 : Mot) return Mot is -- Concatene le vecteur, la fonction ou la liste OBJ1 avec OBJ2.
670 Dernier_Doublet : Mot := Obj1; -- Le résultat sera du meme type que OBJ1 (vecteur, fonction ou liste)
671 begin
672 if not Doublet(Obj1) then return Obj1;
673 else
674 while Doublet(Reste(Dernier_Doublet)) loop
675 Dernier_Doublet := Reste(Dernier_Doublet);
676 end loop;
677 Rest(Dernier_Doublet.Val) := Obj2; -- Fait pointer le dernier doublet sur OBJ2.
678 return Obj1;
679 end if;
680 end Concatene;
681
682
683 function Cree_Liste(Obj1 : Mot) return Mot is -- Renvoie la liste [OBJ1]
684 begin
685 return Cree_Doublet_L(Obj1, Liste_Vide);
686 end Cree_Liste;
687
688
689 function Cree_Liste(Obj1, Obj2 : Mot) return Mot is -- Renvoie la liste [OBJ1, OBJ2]
690 begin
691 return Cree_Doublet_L(Obj1, Cree_Doublet_L(Obj2, Liste_Vide));
692 end Cree_Liste;
693
694
695 function Cree_Liste(Obj1, Obj2, Obj3 : Mot) return Mot is -- Renvoie la liste [OBJ1, OBJ2, OBJ3]
696 begin
697 return Cree_Doublet_L(Obj1, Cree_Doublet_L(Obj2, Cree_Doublet_L(Obj3, Liste_Vide)));
698 end Cree_Liste;
699
700
701 function Cree_Vecteur(Obj1 : Mot) return Mot is -- Renvoie le vecteur <OBJ1>
702 begin
703 return Cree_Doublet_V(Obj1, Vecteur_Vide);
704 end Cree_Vecteur;
705
706
707 function Cree_Vecteur(Obj1, Obj2 : Mot) return Mot is -- Renvoie le vecteur <OBJ1, OBJ2>
708 begin
709 return Cree_Doublet_V(Obj1, Cree_Doublet_V(Obj2, Vecteur_Vide));
710 end Cree_Vecteur;
711
712
713 function Cree_Vecteur(Obj1, Obj2, Obj3 : Mot) return Mot is -- Renvoie le vecteur <OBJ1, OBJ2, OBJ3>
714 begin
715 return Cree_Doublet_V(Obj1, Cree_Doublet_V(Obj2, Cree_Doublet_V(Obj3, Vecteur_Vide)));
716 end Cree_Vecteur;
717
718
719 function Vecteur_Liste(Obj : Mot) return Mot is -- Transforme physiquement un vecteur en liste.
720 Objet : Mot := Obj;
721 begin
722 if not Doublet_V(Obj) then return Obj;
723 else
724 while Doublet_V(Reste(Objet)) loop
725 Rest(Objet.Val).T := Doublet_L; -- Modifie physiquement le type du reste de OBJET.
726 Objet := Reste(Objet); -- Maintenant c'est un doublet liste.
727 end loop;
728 return (Doublet_L, Obj.Val); -- Ne pas oublier de modifier le type du pointeur initial.
729 end if;
730 end Vecteur_Liste;
731
732
733 procedure Id_Liste_Regles(Symb, Liste : Mot) is -- Rattache la liste de regles LISTE au symbole SYMB.
734 begin
735 if Symbole(Symb) then
736 Table_Symb(Symb.Val).Liste_Regles := Liste;
737 end if;
738 end Id_Liste_Regles;
739
740
741 begin
742
743 ---------------------------
744 -- Pour la mise au point :
745 ---------------------------
746
747 --PUT_LINE("Elaboration du package OBJETS_PROLOG------------------------------");
748 --PUT("MOT = "); PUT(MOT'SIZE); NEW_LINE;
749 --PUT("R_PNAME = "); PUT(R_PNAME'SIZE); NEW_LINE;
750 --PUT("STRUCT_SYMBOLE = "); PUT(STRUCT_SYMBOLE'SIZE); NEW_LINE;
751
752 ---------------------------------------------
753 -- Initialisation de la table des hash-codes.
754 ---------------------------------------------
755
756 for I in Table_Hashcode'range loop
757 Table_Hashcode(I) := -1; -- La fin de la liste est indiquée par -1.
758 end loop;
759
760 -------------------------------------------------------------------------
761 -- Fabrication des symboles représentant la liste vide et le vecteur vide.
762 --------------------------------------------------------------------------
763
764 Call(Cree_Symbole("[]")); -- Le symbole '[]' doit etre impérativement le 1er symbole fabriqué.
765 Call(Cree_Symbole("()")); -- Le symbole '()' doit etre impérativement le 2nd symbole fabriqué.
766
767
768 end Objets_Prolog;