/*
================================================================================
  RPL/2 (R) version 4.1.13
  Copyright (C) 1989-2013 Dr. BERTRAND Joël

  This file is part of RPL/2.

  RPL/2 is free software; you can redistribute it and/or modify it
  under the terms of the CeCILL V2 License as published by the french
  CEA, CNRS and INRIA.
 
  RPL/2 is distributed in the hope that it will be useful, but WITHOUT
  ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  FITNESS FOR A PARTICULAR PURPOSE.  See the CeCILL V2 License
  for more details.
 
  You should have received a copy of the CeCILL License
  along with RPL/2. If not, write to info@cecill.info.
================================================================================
*/


#include "rpl-conv.h"


/*
================================================================================
  Procédure d'estimation de la longueur du tampon
================================================================================
  Entrée :
--------------------------------------------------------------------------------
  Sortie :
--------------------------------------------------------------------------------
  Effets de bord : néant
================================================================================
*/

static inline void
estimation_taille_pile_systeme(struct_processus *s_etat_processus)
{
	(*s_etat_processus).estimation_taille_pile_systeme_tampon =
			((*s_etat_processus).estimation_taille_pile_systeme_tampon *
			((double) 0.9)) + ((*s_etat_processus)
			.hauteur_pile_systeme * ((double) 0.1));
	return;
}


/*
================================================================================
  Procédure d'empilement d'un nouvel élément
================================================================================
  Entrée :
--------------------------------------------------------------------------------
  Sortie :
--------------------------------------------------------------------------------
  Effets de bord : néant
================================================================================
*/

void
empilement_pile_systeme(struct_processus *s_etat_processus)
{
	struct_liste_pile_systeme		*l_ancienne_base_liste;
	struct_liste_pile_systeme		*l_nouvelle_base_liste;

	l_ancienne_base_liste = (*s_etat_processus).l_base_pile_systeme;

	if ((*s_etat_processus).debug == d_vrai)
		if (((*s_etat_processus).type_debug &
				d_debug_pile_systeme) != 0)
	{
		if (strlen((*s_etat_processus).instruction_courante) != 0)
		{
			if ((*s_etat_processus).langue == 'F')
			{
				printf("[%d] Empilement sur la pile système à la suite de "
						"l'instruction %s\n", (int) getpid(),
						(*s_etat_processus).instruction_courante);
			}
			else
			{
				printf("[%d] Pushing on system stack (instruction %s)\n",
						(int) getpid(),
						(*s_etat_processus).instruction_courante);
			}
		}
		else
		{
			if ((*s_etat_processus).langue == 'F')
			{
				printf("[%d] Empilement sur la pile système\n",
						(int) getpid());
			}
			else
			{
				printf("[%d] Pushing on system stack\n", (int) getpid());
			}
		}

		fflush(stdout);
	}

	if ((*s_etat_processus).pile_systeme_tampon == NULL)
	{
		// Tampon vide, on alloue un élément.

		if ((l_nouvelle_base_liste = malloc(sizeof(struct_liste_pile_systeme)))
				== NULL)
		{
			(*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
			return;
		}
	}
	else
	{
		// Tampon utilisable, on retire un élément du tampon.

		l_nouvelle_base_liste = (*s_etat_processus).pile_systeme_tampon;
		(*s_etat_processus).pile_systeme_tampon =
				(*l_nouvelle_base_liste).suivant;
		(*s_etat_processus).taille_pile_systeme_tampon--;
	}

	(*s_etat_processus).hauteur_pile_systeme++;
	(*s_etat_processus).l_base_pile_systeme = l_nouvelle_base_liste;
	(*(*s_etat_processus).l_base_pile_systeme).suivant =
			l_ancienne_base_liste;

	(*(*s_etat_processus).l_base_pile_systeme).type_cloture = ' ';
	(*(*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 =
			(*s_etat_processus).niveau_courant;
	(*(*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;
	(*(*s_etat_processus).l_base_pile_systeme).objet_de_test = NULL;
	(*(*s_etat_processus).l_base_pile_systeme).nom_variable = NULL;
	(*(*s_etat_processus).l_base_pile_systeme).pointeur_objet_retour = NULL;
	(*(*s_etat_processus).l_base_pile_systeme)
			.origine_routine_evaluation = 'N';
	(*(*s_etat_processus).l_base_pile_systeme).arret_si_exception =
			(*s_etat_processus).arret_si_exception;
	(*(*s_etat_processus).l_base_pile_systeme).creation_variables_statiques
			= (*s_etat_processus).creation_variables_statiques;
	(*(*s_etat_processus).l_base_pile_systeme).creation_variables_partagees
			= (*s_etat_processus).creation_variables_partagees;
	(*(*s_etat_processus).l_base_pile_systeme).evaluation_expression =
			d_faux;

	(*s_etat_processus).erreur_systeme = d_es;
	(*s_etat_processus).creation_variables_statiques = d_faux;
	(*s_etat_processus).creation_variables_partagees = d_faux;

	return;
}


/*
================================================================================
  Procédure de dépilement d'un élément
================================================================================
  Entrée :
--------------------------------------------------------------------------------
  Sortie :
--------------------------------------------------------------------------------
  Effets de bord : néant
================================================================================
*/

void
depilement_pile_systeme(struct_processus *s_etat_processus)
{
	struct_liste_pile_systeme		*l_ancienne_base_liste;
	struct_liste_pile_systeme		*l_nouvelle_base_liste;

	if ((*s_etat_processus).debug == d_vrai)
		if (((*s_etat_processus).type_debug &
				d_debug_pile_systeme) != 0)
	{
		if (strlen((*s_etat_processus).instruction_courante) != 0)
		{
			if ((*s_etat_processus).langue == 'F')
			{
				printf("[%d] Dépilement de la pile système à la suite "
						"de l'instruction %s\n", (int) getpid(),
						(*s_etat_processus).instruction_courante);
			}
			else
			{
				printf("[%d] Pulling from system stack (instruction %s)\n",
						(int) getpid(),
						(*s_etat_processus).instruction_courante);
			}
		}
		else
		{
			if ((*s_etat_processus).langue == 'F')
			{
				printf("[%d] Dépilement de la pile système\n",
						(int) getpid());
			}
			else
			{
				printf("[%d] Pulling from system stack\n", (int) getpid());
			}
		}

		fflush(stdout);
	}

	if ((*s_etat_processus).l_base_pile_systeme == NULL)
	{
		(*s_etat_processus).erreur_systeme = d_es_pile_vide;
	}
	else
	{
		(*s_etat_processus).hauteur_pile_systeme--;
		l_ancienne_base_liste = (*s_etat_processus).l_base_pile_systeme;
		l_nouvelle_base_liste = (*l_ancienne_base_liste).suivant;

		(*s_etat_processus).l_base_pile_systeme = l_nouvelle_base_liste;
		(*s_etat_processus).erreur_systeme = d_es;

		// On positionne le drapeau de création des variables statiques.

		(*s_etat_processus).creation_variables_statiques =
				 (*l_ancienne_base_liste).creation_variables_statiques;
		(*s_etat_processus).creation_variables_partagees =
				 (*l_ancienne_base_liste).creation_variables_partagees;

		if ((*l_ancienne_base_liste).nom_variable != NULL)
		{
			free((*l_ancienne_base_liste).nom_variable);
		}

		liberation(s_etat_processus, (*l_ancienne_base_liste).indice_boucle);
		liberation(s_etat_processus,
				(*l_ancienne_base_liste).limite_indice_boucle);
		liberation(s_etat_processus, (*l_ancienne_base_liste).objet_de_test);

		if ((*s_etat_processus).taille_pile_systeme_tampon <= (10 *
				((*s_etat_processus).estimation_taille_pile_systeme_tampon
				+ 1)))
		{
			// Enregistrement de la structure pour un usage ultérieur.

			(*l_ancienne_base_liste).suivant =
					(*s_etat_processus).pile_systeme_tampon;
			(*s_etat_processus).pile_systeme_tampon = l_ancienne_base_liste;
			(*s_etat_processus).taille_pile_systeme_tampon++;
		}
		else
		{
			// Libération car le tampon est plein.

			free(l_ancienne_base_liste);
		}
	}

	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)
{
	int								candidat;
	int								j;
	int								nb_variables;

	integer8						i;
	integer8						candidat8;
	integer8						delta;

	struct_liste_chainee			*l_element_expression;

	struct_liste_pile_systeme		*l_element_courant;

	struct_tableau_variables		*tableau;

	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);

	nb_variables = nombre_variables(s_etat_processus);

	if ((tableau = malloc(nb_variables * sizeof(struct_tableau_variables)))
			== NULL)
	{
		(*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
		return;
	}

	liste_variables(s_etat_processus, tableau);

	if ((flux == stderr) || (flux == stdout))
	{
		fprintf(flux, "+++Backtrace\n");
	}

	while(l_element_courant != NULL)
	{
		fprintf(flux, "%lld : address # %016Xh\n", i--, l_element_courant);

		if ((*l_element_courant).creation_variables_statiques == d_vrai)
		{
			fprintf(flux, "    Variables         = static\n");
		}
		else if ((*l_element_courant).creation_variables_partagees == d_vrai)
		{
			fprintf(flux, "    Variables         = shared\n");
		}
		else
		{
			fprintf(flux, "    Variables         = automatic\n");
		}

		if ((*l_element_courant).arret_si_exception == d_vrai)
		{
			fprintf(flux, "    In exception      = abort\n");
		}
		else
		{
			fprintf(flux, "    In exception      = catch\n");
		}

		if ((*l_element_courant).clause != ' ')
		{
			fprintf(flux, "    Structure         = ");

			switch((*l_element_courant).clause)
			{
				case 'I':
					fprintf(flux, "IF\n");
					break;

				case 'R':
					fprintf(flux, "IFERR\n");
					break;

				case 'X':
					fprintf(flux, "exception caught by IFERR\n");
					break;

				case 'T':
					fprintf(flux, "THEN\n");
					break;
				
				case 'E':
					fprintf(flux, "ELSE\n");
					break;

				case 'Z':
					fprintf(flux, "ELSE (false condition)\n");
					break;

				case 'D':
					fprintf(flux, "DO\n");
					break;

				case 'U':
					fprintf(flux, "UNTIL\n");
					break;

				case 'W':
					fprintf(flux, "WHILE\n");
					break;

				case 'M':
					fprintf(flux, "WHILE (false condition)\n");
					break;

				case 'S':
					fprintf(flux, "SELECT\n");
					break;

				case 'K':
					fprintf(flux, "CASE (no true condition)\n");
					break;

				case 'C':
					fprintf(flux, "CASE (one or more true conditions)\n");
					break;

				case 'Q':
					fprintf(flux, "CASE (treatment of a true condition)\n");
					break;

				case 'F':
					fprintf(flux, "CASE (treatment of default case)\n");
					break;
			}
		}

		if ((*l_element_courant).type_cloture != ' ')
		{
			fprintf(flux, "    Next close        = ");

			switch((*l_element_courant).type_cloture)
			{
				case 'C':
					fprintf(flux, "SELECT\n");
					break;

				case 'D':
					fprintf(flux, "DO\n");
					break;

				case 'I':
					fprintf(flux, "IF\n");
					break;

				case 'J':
					fprintf(flux, "IFERR\n");
					break;

				case 'K':
					fprintf(flux, "CASE\n");
					break;

				case 'W':
					fprintf(flux, "WHILE\n");
					break;

				case 'Q':
					fprintf(flux, "CRITICAL\n");
					break;

				case 'F':
					fprintf(flux, "FOR\n");
					break;

				case 'S':
					fprintf(flux, "START\n");
					break;

				case 'L':
					fprintf(flux, "internal loop\n");
					break;

				case 'A':
					fprintf(flux, "FORALL\n");
					break;
			}
		}

		fprintf(flux, "    Level             = %d\n",
				(*l_element_courant).niveau_courant);

		if (((*l_element_courant).retour_definition == 'Y') ||
				((*l_element_courant).origine_routine_evaluation == 'Y'))
		{
			fprintf(flux, "    Return            = yes\n");

			if ((*l_element_courant).origine_routine_evaluation == 'Y')
			{
				if ((*l_element_courant).pointeur_objet_retour != NULL)
				{
					fprintf(flux, "    Come from         = compiled code ");
					fprintf(flux, "(address # %016Xh)\n", (*l_element_courant)
							.pointeur_objet_retour);

					// Calcul de la routine de départ

					candidat = -1;

					for(j = 0; j < nb_variables; j++)
					{
						if (((*(tableau[j].objet)).type == RPN) ||
								((*(tableau[j].objet)).type == ALG))
						{
							l_element_expression = (*(tableau[j].objet)).objet;

							while(l_element_expression != NULL)
							{
								if (l_element_expression == (*l_element_courant)
										.pointeur_objet_retour)
								{
									candidat = j;
									break;
								}

								l_element_expression =
										(*l_element_expression).suivant;
							}

							if (candidat != -1)
							{
								break;
							}
						}
					}

					if (candidat != -1)
					{
						fprintf(flux, "                      = %s [",
								tableau[candidat].nom);
					   
						if ((*(tableau[candidat].objet)).type == RPN)
						{
							fprintf(flux, "definition");
						}
						else if ((*(tableau[candidat].objet)).type == ALG)
						{
							fprintf(flux, "algebraic");
						}
						else if ((*(tableau[candidat].objet)).type == NOM)
						{
							fprintf(flux, "name");
						}
						else
						{
							fprintf(flux, "unknown");
						}

						fprintf(flux, "]\n");
					}
					else
					{
						fprintf(flux, "                      = "
								"optimized definition\n");
					}
				}
				else
				{
					fprintf(flux, "    Come from         = compiled code\n");
					fprintf(flux, "                      = "
							"optimized definition\n");
				}
			}
			else
			{
				fprintf(flux, "    Come from         = interpreted code ");

				if ((*l_element_courant).adresse_retour != 0)
				{
					fprintf(flux, "(offset # %016Xh)\n", (*l_element_courant)
							.adresse_retour);

					// Calcul de la routine de départ

					candidat8 = (*s_etat_processus)
							.longueur_definitions_chainees;
					candidat = -1;

					for(j = 0; j < nb_variables; j++)
					{
						if ((*(tableau[j].objet)).type == ADR)
						{
							delta = (*l_element_courant).adresse_retour
									- (*((unsigned long *)
									(*(tableau[j].objet)).objet));

							if ((delta >= 0) && (delta < candidat8))
							{
								candidat8 = delta;
								candidat = j;
							}
						}
					}

					if (candidat != -1)
					{
						fprintf(flux, "                      = %s\n",
								tableau[candidat].nom);
					}
					else
					{
						fprintf(flux, "                      = "
								"unknown definition\n");
					}
				}
				else
				{
					fprintf(flux, "\n");
					fprintf(flux, "                      = RPL/2 "
							"initialization\n");
				}
			}
		}
		else
		{
			fprintf(flux, "    Return            = no\n");
		}

		if ((*l_element_courant).indice_boucle != NULL)
		{
			tampon = formateur(s_etat_processus, 24,
					(*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, 24,
					(*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, 24,
					(*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);
		}

		fprintf(flux, "\n");

		l_element_courant = (*l_element_courant).suivant;
	}

	fprintf(flux, "\n");
	funlockfile(flux);

	free(tableau);

	return;
}

// vim: ts=4