--- rpl/src/gestion_pile_systeme.c	2010/03/04 10:17:48	1.4
+++ rpl/src/gestion_pile_systeme.c	2012/10/01 11:05:01	1.46
@@ -1,7 +1,7 @@
 /*
 ================================================================================
-  RPL/2 (R) version 4.0.12
-  Copyright (C) 1989-2010 Dr. BERTRAND Joël
+  RPL/2 (R) version 4.1.11
+  Copyright (C) 1989-2012 Dr. BERTRAND Joël
 
   This file is part of RPL/2.
 
@@ -20,7 +20,7 @@
 */
 
 
-#include "rpl.conv.h"
+#include "rpl-conv.h"
 
 
 /*
@@ -131,6 +131,7 @@ empilement_pile_systeme(struct_processus
 	(*(*s_etat_processus).l_base_pile_systeme).clause = ' ';
 	(*(*s_etat_processus).l_base_pile_systeme).adresse_retour = 0;
 	(*(*s_etat_processus).l_base_pile_systeme).niveau_courant = 0;
+	(*(*s_etat_processus).l_base_pile_systeme).pointeur_adresse_retour = NULL;
 	(*(*s_etat_processus).l_base_pile_systeme).retour_definition = 'N';
 	(*(*s_etat_processus).l_base_pile_systeme).indice_boucle = NULL;
 	(*(*s_etat_processus).l_base_pile_systeme).limite_indice_boucle = NULL;
@@ -260,5 +261,254 @@ depilement_pile_systeme(struct_processus
 
 	return;
 }
+
+
+/*
+================================================================================
+  Procédure d'effacement de la pile système
+================================================================================
+  Entrée :
+--------------------------------------------------------------------------------
+  Sortie :
+--------------------------------------------------------------------------------
+  Effets de bord : néant
+================================================================================
+*/
+
+void
+effacement_pile_systeme(struct_processus *s_etat_processus)
+{
+	while((*s_etat_processus).l_base_pile_systeme != NULL)
+	{
+		depilement_pile_systeme(s_etat_processus);
+	}
+
+	return;
+}
+
+
+/*
+================================================================================
+  Procédure d'affichage de la pile système
+================================================================================
+  Entrée :
+--------------------------------------------------------------------------------
+  Sortie :
+--------------------------------------------------------------------------------
+  Effets de bord : néant
+================================================================================
+*/
+
+void
+trace(struct_processus *s_etat_processus, FILE *flux)
+{
+	integer8						i;
+	integer8						candidat;
+
+	long							delta;
+
+	struct_liste_chainee			*l_variable;
+	struct_liste_chainee			*l_candidat;
+
+	struct_liste_pile_systeme		*l_element_courant;
+
+	unsigned char					*tampon;
+
+	l_element_courant = (*s_etat_processus).l_base_pile_systeme;
+	i = 0;
+
+	while(l_element_courant != NULL)
+	{
+		i++;
+		l_element_courant = (*l_element_courant).suivant;
+	}
+
+	l_element_courant = (*s_etat_processus).l_base_pile_systeme;
+	flockfile(flux);
+
+	if ((flux == stderr) || (flux == stdout))
+	{
+		fprintf(flux, "+++Backtrace\n");
+	}
+
+	while(l_element_courant != NULL)
+	{
+		fprintf(flux, "%d : (%016X) D=", i--, l_element_courant);
+
+		fprintf(flux, ((*l_element_courant).creation_variables_statiques
+				== d_vrai) ? "1" : "0");
+		fprintf(flux, ((*l_element_courant).creation_variables_partagees
+				== d_vrai) ? "1" : "0");
+		fprintf(flux, ((*l_element_courant).arret_si_exception == d_vrai)
+				? "1" : "0");
+		fprintf(flux, ((*l_element_courant).evaluation_expression == d_vrai)
+				? "1" : "0");
+
+		fprintf(flux, " F=%c%c L=%lu ",
+				((*l_element_courant).clause == ' ') ? '-' :
+				(*l_element_courant).clause,
+				((*l_element_courant).type_cloture == ' ') ? '-' :
+				(*l_element_courant).type_cloture,
+				(*l_element_courant).niveau_courant);
+
+		if ((*l_element_courant).retour_definition == 'Y')
+		{
+			fprintf(flux, "RTN ");
+
+			if ((*l_element_courant).origine_routine_evaluation == 'Y')
+			{
+				fprintf(flux, "EVL ");
+			}
+			else
+			{
+				fprintf(flux, "SEQ ");
+
+				if ((*l_element_courant).adresse_retour != 0)
+				{
+					fprintf(flux, "P=%016X", (*l_element_courant)
+							.adresse_retour);
+
+					// Calcul de la routine de départ
+
+					l_variable = (struct_liste_chainee *)
+							(*(*(*s_etat_processus)
+							.l_liste_variables_par_niveau).precedent).liste;
+					candidat = (*s_etat_processus)
+							.longueur_definitions_chainees;
+					l_candidat = NULL;
+
+					// l_variable balaie les variables de niveau 0.
+
+					while(l_variable != NULL)
+					{
+						if ((*(*((struct_variable *) (*l_variable).donnee))
+								.objet).type == ADR)
+						{
+							delta = (*l_element_courant).adresse_retour
+									- (*((unsigned long *)
+									(*(*((struct_variable *) (*l_variable)
+									.donnee)).objet).objet));
+
+							if ((delta > 0) && (delta < candidat))
+							{
+								candidat = delta;
+								l_candidat = l_variable;
+							}
+						}
+
+						l_variable = (*l_variable).suivant;
+					}
+
+					if (l_candidat != NULL)
+					{
+						fprintf(flux, "\n  Call from %s",
+								(*((struct_variable *) (*l_candidat).donnee))
+								.nom);
+					}
+					else
+					{
+						fprintf(flux, "\n  Call from RPL/2 initialization");
+					}
+				}
+				else
+				{
+					fprintf(flux, "RPL/2 initialization");
+				}
+			}
+		}
+		else
+		{
+			fprintf(flux, "NONE ");
+
+			if ((*l_element_courant).origine_routine_evaluation == 'Y')
+			{
+				fprintf(flux, "EVL ");
+			}
+			else
+			{
+				fprintf(flux, "SEQ ");
+
+				if ((*l_element_courant).pointeur_adresse_retour != NULL)
+				{
+					fprintf(flux, "A=%016X ", (*l_element_courant)
+							.pointeur_adresse_retour);
+
+					// Calcul de la routine de départ
+
+					l_variable = (struct_liste_chainee *)
+							(*(*(*s_etat_processus)
+							.l_liste_variables_par_niveau).precedent).liste;
+					candidat = (*s_etat_processus)
+							.longueur_definitions_chainees;
+					l_candidat = NULL;
+
+					// l_variable balaie les variables de niveau 0.
+
+					while(l_variable != NULL)
+					{
+						if ( (*(*l_variable).donnee).objet ==
+								(*l_element_courant).pointeur_adresse_retour)
+						{
+							l_candidat = l_variable;
+							break;
+						}
+
+						l_variable = (*l_variable).suivant;
+					}
+
+					if (l_candidat != NULL)
+					{
+						fprintf(flux, "\n  Branch to %s",
+								(*((struct_variable *) (*l_candidat).donnee))
+								.nom);
+					}
+					else
+					{
+						fprintf(flux, "\n  Branch to evaluation subroutine");
+					}
+				}
+			}
+		}
+
+		fprintf(flux, "\n");
+
+		if ((*l_element_courant).indice_boucle != NULL)
+		{
+			tampon = formateur(s_etat_processus, 0,
+					(*l_element_courant).indice_boucle);
+			fprintf(flux, "  Index         = %s\n", tampon);
+			free(tampon);
+		}
+
+		if ((*l_element_courant).limite_indice_boucle != NULL)
+		{
+			tampon = formateur(s_etat_processus, 0,
+					(*l_element_courant).limite_indice_boucle);
+			fprintf(flux, "  Limit         = %s\n", tampon);
+			free(tampon);
+		}
+
+		if ((*l_element_courant).objet_de_test != NULL)
+		{
+			tampon = formateur(s_etat_processus, 0,
+					(*l_element_courant).objet_de_test);
+			fprintf(flux, "  Test object   = %s\n", tampon);
+			free(tampon);
+		}
+
+		if ((*l_element_courant).nom_variable != NULL)
+		{
+			fprintf(flux, "  Variable name = %s\n",
+					(*l_element_courant).nom_variable);
+		}
+
+		l_element_courant = (*l_element_courant).suivant;
+	}
+
+	fprintf(flux, "\n");
+	funlockfile(flux);
+
+	return;
+}
 
 // vim: ts=4