/*
================================================================================
  RPL/2 (R) version 4.1.32
  Copyright (C) 1989-2020 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"


/*
================================================================================
  Fonction 'rsd'
================================================================================
  Entrées : pointeur sur une structure struct_processus
--------------------------------------------------------------------------------
  Sorties :
--------------------------------------------------------------------------------
  Effets de bord : néant
================================================================================
*/

void
instruction_rsd(struct_processus *s_etat_processus)
{
	struct_liste_chainee					*l_element_courant;
	struct_liste_chainee					*registre_pile_last;

	(*s_etat_processus).erreur_execution = d_ex;

	if ((*s_etat_processus).affichage_arguments == 'Y')
	{
		printf("\n  RSD ");

		if ((*s_etat_processus).langue == 'F')
		{
			printf("(calcul d'un tableau résiduel)\n\n");
		}
		else
		{
			printf("(compute a resudial array)\n\n");
		}

		printf("    3: %s, %s, %s\n", d_VIN, d_VRL, d_VCX);
		printf("    2: %s, %s, %s\n", d_MIN, d_MRL, d_MCX);
		printf("    1: %s, %s, %s\n", d_VIN, d_VRL, d_VCX);
		printf("->  1: %s, %s ,%s\n\n", d_VIN, d_VRL, d_VCX);

		printf("    3: %s, %s, %s\n", d_MIN, d_MRL, d_MCX);
		printf("    2: %s, %s, %s\n", d_MIN, d_MRL, d_MCX);
		printf("    1: %s, %s, %s\n", d_MIN, d_MRL, d_MCX);
		printf("->  1: %s, %s, %s\n", d_MIN, d_MRL, d_MCX);

		return;
	}
	else if ((*s_etat_processus).test_instruction == 'Y')
	{
		(*s_etat_processus).nombre_arguments = -1;
		return;
	}

	/*
	 * Test du type et du nombre des arguments
	 */

	if ((*s_etat_processus).hauteur_pile_operationnelle < 3)
	{
		(*s_etat_processus).erreur_execution = d_ex_manque_argument;
		return;
	}

	l_element_courant = (*s_etat_processus).l_base_pile;

	if (((*(*l_element_courant).donnee).type != VIN) &&
			((*(*l_element_courant).donnee).type != VRL) &&
			((*(*l_element_courant).donnee).type != VCX) &&
			((*(*l_element_courant).donnee).type != MIN) &&
			((*(*l_element_courant).donnee).type != MRL) &&
			((*(*l_element_courant).donnee).type != MCX))
	{
		(*s_etat_processus).erreur_execution = d_ex_erreur_type_argument;
		return;
	}

	l_element_courant = (*l_element_courant).suivant;

	if (((*(*l_element_courant).donnee).type != MIN) &&
			((*(*l_element_courant).donnee).type != MRL) &&
			((*(*l_element_courant).donnee).type != MCX))
	{
		(*s_etat_processus).erreur_execution = d_ex_erreur_type_argument;
		return;
	}

	l_element_courant = (*l_element_courant).suivant;

	if (((*(*l_element_courant).donnee).type != VIN) &&
			((*(*l_element_courant).donnee).type != VRL) &&
			((*(*l_element_courant).donnee).type != VCX) &&
			((*(*l_element_courant).donnee).type != MIN) &&
			((*(*l_element_courant).donnee).type != MRL) &&
			((*(*l_element_courant).donnee).type != MCX))
	{
		(*s_etat_processus).erreur_execution = d_ex_erreur_type_argument;
		return;
	}

	/*
	 * Sauvegarde de la pile LAST courante
	 */

	registre_pile_last = NULL;

	if (test_cfsf(s_etat_processus, 31) == d_vrai)
	{
		if (empilement_pile_last(s_etat_processus, 3) == d_erreur)
		{
			return;
		}

		registre_pile_last = (*s_etat_processus).l_base_pile_last;
		(*s_etat_processus).l_base_pile_last = NULL;
	}

	instruction_multiplication(s_etat_processus);

	if (((*s_etat_processus).erreur_systeme != d_es) ||
			((*s_etat_processus).erreur_execution != d_ex) ||
			((*s_etat_processus).exception != d_ep))
	{
		if (test_cfsf(s_etat_processus, 31) == d_vrai)
		{
			if (empilement_pile_last(s_etat_processus, 0) == d_erreur)
			{
				return;
			}
		}

		(*s_etat_processus).l_base_pile_last = registre_pile_last;

		return;
	}

	instruction_moins(s_etat_processus);

	/*
	 * Restauration de la pile LAST
	 */

	if (test_cfsf(s_etat_processus, 31) == d_vrai)
	{
		/*
		 * Astuce pour libérer l'ancienne pile last...
		 */

		if (empilement_pile_last(s_etat_processus, 0) == d_erreur)
		{
			return;
		}

		(*s_etat_processus).l_base_pile_last = registre_pile_last;
	}

	return;
}


/*
================================================================================
  Fonction 'regv'
================================================================================
  Entrées : pointeur sur une structure struct_processus
--------------------------------------------------------------------------------
  Sorties :
--------------------------------------------------------------------------------
  Effets de bord : néant
================================================================================
*/

void
instruction_regv(struct_processus *s_etat_processus)
{
	struct_objet				*s_objet_argument;
	struct_objet				*s_objet_resultat_1;
	struct_objet				*s_objet_resultat_2;

	(*s_etat_processus).erreur_execution = d_ex;

	if ((*s_etat_processus).affichage_arguments == 'Y')
	{
		printf("\n  REGV ");
		
		if ((*s_etat_processus).langue == 'F')
		{
			printf("(valeurs et vecteurs propres droits)\n\n");
		}
		else
		{
			printf("(eigenvalues and right eigenvectors)\n\n");
		}

		printf("    1: %s, %s, %s\n", d_MIN, d_MRL, d_MCX);
		printf("->  2: %s\n", d_MCX);
		printf("    1: %s\n", d_VCX);

		return;
	}
	else if ((*s_etat_processus).test_instruction == 'Y')
	{
		(*s_etat_processus).nombre_arguments = -1;
		return;
	}

	if (test_cfsf(s_etat_processus, 31) == d_vrai)
	{
		if (empilement_pile_last(s_etat_processus, 1) == d_erreur)
		{
			return;
		}
	}

	if (depilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
			&s_objet_argument) == d_erreur)
	{
		(*s_etat_processus).erreur_execution = d_ex_manque_argument;
		return;
	}

/*
--------------------------------------------------------------------------------
  L'argument est une matrice carrée
--------------------------------------------------------------------------------
*/

	if (((*s_objet_argument).type == MIN) ||
			((*s_objet_argument).type == MRL) ||
			((*s_objet_argument).type == MCX))
	{
		if ((*((struct_matrice *) (*s_objet_argument).objet)).nombre_lignes !=
				(*((struct_matrice *) (*s_objet_argument).objet))
				.nombre_colonnes)
		{
			liberation(s_etat_processus, s_objet_argument);

			(*s_etat_processus).erreur_execution = d_ex_dimensions_invalides;
			return;
		}

		if ((s_objet_resultat_1 = allocation(s_etat_processus, VCX)) == NULL)
		{
			(*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
			return;
		}

		if ((s_objet_resultat_2 = allocation(s_etat_processus, MCX)) == NULL)
		{
			(*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
			return;
		}

		valeurs_propres(s_etat_processus,
				(struct_matrice *) (*s_objet_argument).objet,
				(struct_vecteur *) (*s_objet_resultat_1).objet,
				NULL, (struct_matrice *) (*s_objet_resultat_2).objet);

		if ((*s_etat_processus).erreur_systeme != d_es)
		{
			return;
		}

		if (((*s_etat_processus).exception != d_ep) ||
				((*s_etat_processus).erreur_execution != d_ex))
		{
			liberation(s_etat_processus, s_objet_argument);
			liberation(s_etat_processus, s_objet_resultat_1);
			liberation(s_etat_processus, s_objet_resultat_2);
			return;
		}
	}

/*
--------------------------------------------------------------------------------
  Type incompatible
--------------------------------------------------------------------------------
*/

	else
	{
		liberation(s_etat_processus, s_objet_argument);

		(*s_etat_processus).erreur_execution = d_ex_erreur_type_argument;
		return;
	}

	liberation(s_etat_processus, s_objet_argument);

	if (empilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
			s_objet_resultat_2) == d_erreur)
	{
		return;
	}

	if (empilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
			s_objet_resultat_1) == d_erreur)
	{
		return;
	}

	return;
}


/*
================================================================================
  Fonction 'rnrm'
================================================================================
  Entrées : pointeur sur une structure struct_processus
--------------------------------------------------------------------------------
  Sorties :
--------------------------------------------------------------------------------
  Effets de bord : néant
================================================================================
*/

void
instruction_rnrm(struct_processus *s_etat_processus)
{
	logical1					depassement;
	logical1					erreur_memoire;

	real8						cumul_reel;
	real8						registre;

	integer8					cumul_entier;
	integer8					entier_courant;
	integer8					tampon;

	struct_objet				*s_objet_argument;
	struct_objet				*s_objet_resultat;

	integer8					i;
	integer8					j;

	void						*accumulateur;

	(*s_etat_processus).erreur_execution = d_ex;

	if ((*s_etat_processus).affichage_arguments == 'Y')
	{
		printf("\n  RNRM ");

		if ((*s_etat_processus).langue == 'F')
		{
			printf("(norme de ligne)\n\n");
		}
		else
		{
			printf("(row norm)\n\n");
		}

		printf("    1: %s, %s\n", d_VIN, d_MIN);
		printf("->  1: %s, %s\n\n", d_INT, d_REL);

		printf("    1: %s, %s, %s, %s\n", d_VRL, d_VCX, d_MRL, d_MCX);
		printf("->  1: %s\n", d_REL);

		return;
	}
	else if ((*s_etat_processus).test_instruction == 'Y')
	{
		(*s_etat_processus).nombre_arguments = -1;
		return;
	}

	if (test_cfsf(s_etat_processus, 31) == d_vrai)
	{
		if (empilement_pile_last(s_etat_processus, 1) == d_erreur)
		{
			return;
		}
	}

	if (depilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
			&s_objet_argument) == d_erreur)
	{
		(*s_etat_processus).erreur_execution = d_ex_manque_argument;
		return;
	}

/*
--------------------------------------------------------------------------------
  Traitement des vecteurs
--------------------------------------------------------------------------------
*/

	if ((*s_objet_argument).type == VIN)
	{
		depassement = d_faux;

		for(i = 0; i < (*((struct_vecteur *) (*s_objet_argument).objet)).taille;
				i++)
		{
			if (((integer8 *) (*((struct_vecteur *) (*s_objet_argument)
					.objet)).tableau)[i] == INT64_MIN)
			{
				depassement = d_vrai;
				break;
			}
		}

		if (depassement == d_faux)
		{
			if ((s_objet_resultat = allocation(s_etat_processus, INT)) == NULL)
			{
				(*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
				return;
			}

			(*((integer8 *) (*s_objet_resultat).objet)) = abs(((integer8 *)
					(*((struct_vecteur *) (*s_objet_argument).objet))
					.tableau)[0]);

			for(i = 1; i < (*((struct_vecteur *) (*s_objet_argument).objet))
					.taille; i++)
			{
				if (abs(((integer8 *) (*((struct_vecteur *) (*s_objet_argument)
						.objet)).tableau)[i]) > (*((integer8 *)
						(*s_objet_resultat).objet)))
				{
					(*((integer8 *) (*s_objet_resultat).objet)) =
							abs(((integer8 *) (*((struct_vecteur *)
							(*s_objet_argument).objet)).tableau)[i]);
				}
			}
		}
		else
		{
			if ((s_objet_resultat = allocation(s_etat_processus, REL)) == NULL)
			{
				(*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
				return;
			}

			(*((real8 *) (*s_objet_resultat).objet)) = abs((real8) ((integer8 *)
					(*((struct_vecteur *) (*s_objet_argument).objet))
					.tableau)[0]);

			for(i = 1; i < (*((struct_vecteur *) (*s_objet_argument).objet))
					.taille; i++)
			{
				if (abs((real8) ((integer8 *) (*((struct_vecteur *)
						(*s_objet_argument).objet)).tableau)[i]) > (*((real8 *)
						(*s_objet_resultat).objet)))
				{
					(*((real8 *) (*s_objet_resultat).objet)) =
							abs((real8) ((integer8 *) (*((struct_vecteur *)
							(*s_objet_argument).objet)).tableau)[i]);
				}
			}
		}
	}
	else if ((*s_objet_argument).type == VRL)
	{
		if ((s_objet_resultat = allocation(s_etat_processus, REL)) == NULL)
		{
			(*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
			return;
		}

		(*((real8 *) (*s_objet_resultat).objet)) = fabs(((real8 *)
				(*((struct_vecteur *) (*s_objet_argument).objet)).tableau)[0]);

		for(i = 1; i < (*((struct_vecteur *) (*s_objet_argument).objet)).taille;
				i++)
		{
			if (fabs(((real8 *) (*((struct_vecteur *) (*s_objet_argument)
					.objet)).tableau)[i]) > (*((real8 *)
					(*s_objet_resultat).objet)))
			{
				(*((real8 *) (*s_objet_resultat).objet)) =
						fabs(((real8 *) (*((struct_vecteur *)
						(*s_objet_argument).objet)).tableau)[i]);
			}
		}
	}
	else if ((*s_objet_argument).type == VCX)
	{
		if ((s_objet_resultat = allocation(s_etat_processus, REL)) == NULL)
		{
			(*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
			return;
		}

		f77absc_(&(((struct_complexe16 *) (*((struct_vecteur *)
				(*s_objet_argument).objet)).tableau)[0]), (real8 *)
				(*s_objet_resultat).objet);

		for(i = 1; i < (*((struct_vecteur *) (*s_objet_argument).objet)).taille;
				i++)
		{
			f77absc_(&(((struct_complexe16 *) (*((struct_vecteur *)
					(*s_objet_argument).objet)).tableau)[i]), &registre);

			if (registre > (*((real8 *) (*s_objet_resultat).objet)))
			{
				(*((real8 *) (*s_objet_resultat).objet)) = registre;
			}
		}
	}

/*
--------------------------------------------------------------------------------
  Traitement des matrices
--------------------------------------------------------------------------------
*/

	else if ((*s_objet_argument).type == MIN)
	{
		if ((s_objet_resultat = allocation(s_etat_processus, INT)) == NULL)
		{
			(*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
			return;
		}

		cumul_entier = 0;
		depassement = d_faux;
		
		for(j = 0; j < (*((struct_matrice *) (*s_objet_argument).objet))
				.nombre_colonnes; j++)
		{
			if (((integer8 **) (*((struct_matrice *) (*s_objet_argument).objet))
					.tableau)[0][j] == INT64_MIN)
			{
				depassement = d_vrai;
				break;
			}

			entier_courant = abs(((integer8 **)
					(*((struct_matrice *) (*s_objet_argument).objet))
					.tableau)[0][j]);

			if (depassement_addition(&cumul_entier, &entier_courant, &tampon)
					== d_erreur)
			{
				depassement = d_vrai;
				break;
			}
		}

		if (depassement == d_faux)
		{
			(*((integer8 *) (*s_objet_resultat).objet)) = cumul_entier;

			for(i = 1; i < (*((struct_matrice *) (*s_objet_argument).objet))
					.nombre_lignes; i++)
			{
				cumul_entier = 0;

				for(j = 0; j < (*((struct_matrice *) (*s_objet_argument).objet))
						.nombre_colonnes; j++)
				{
					if (((integer8 **) (*((struct_matrice *)
							(*s_objet_argument).objet)).tableau)[i][j]
							== INT64_MIN)
					{
						depassement = d_vrai;
						break;
					}

					entier_courant = abs(((integer8 **) (*((struct_matrice *)
							(*s_objet_argument).objet)).tableau)[i][j]);

					if (depassement_addition(&cumul_entier, &entier_courant,
							&tampon) == d_erreur)
					{
						depassement = d_vrai;
						break;
					}

					cumul_entier = tampon;
				}

				if (depassement == d_vrai)
				{
					break;
				}

				if (cumul_entier > (*((integer8 *) (*s_objet_resultat).objet)))
				{
					(*((integer8 *) (*s_objet_resultat).objet)) = cumul_entier;
				}
			}
		}

		if (depassement == d_vrai)
		{
			/*
			 * Dépassement : il faut refaire le calcul en real*8...
			 */

			free((*s_objet_resultat).objet);
			(*s_objet_resultat).type = REL;

			if (((*s_objet_resultat).objet = malloc(sizeof(real8))) == NULL)
			{
				(*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
				return;
			}

			if ((accumulateur = malloc(((size_t) (*((struct_matrice *)
					(*s_objet_argument).objet)).nombre_colonnes) *
					sizeof(real8))) == NULL)
			{
				(*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
				return;
			}

			(*((real8 *) (*s_objet_resultat).objet)) = 0;
			
			for(i = 0; i < (*((struct_matrice *) (*s_objet_argument).objet))
					.nombre_lignes; i++)
			{
				for(j = 0; j < (*((struct_matrice *) (*s_objet_argument).objet))
						.nombre_colonnes; j++)
				{
					((real8 *) accumulateur)[j] = fabs((real8) ((integer8 **)
							(*((struct_matrice *) (*s_objet_argument).objet))
							.tableau)[i][j]);
				}

				cumul_reel = sommation_vecteur_reel(accumulateur,
						&((*((struct_matrice *) (*s_objet_argument).objet))
						.nombre_colonnes), &erreur_memoire);

				if (erreur_memoire == d_vrai)
				{
					(*s_etat_processus).erreur_systeme =
							d_es_allocation_memoire;
					return;
				}

				if (cumul_reel > (*((real8 *) (*s_objet_resultat).objet)))
				{
					(*((real8 *) (*s_objet_resultat).objet)) = cumul_reel;
				}
			}

			free(accumulateur);
		}
	}
	else if ((*s_objet_argument).type == MRL)
	{
		if ((s_objet_resultat = allocation(s_etat_processus, REL)) == NULL)
		{
			(*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
			return;
		}

		if ((accumulateur = malloc(((size_t) (*((struct_matrice *)
				(*s_objet_argument).objet)).nombre_colonnes) * sizeof(real8)))
				== NULL)
		{
			(*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
			return;
		}

		(*((real8 *) (*s_objet_resultat).objet)) = 0;
		
		for(i = 0; i < (*((struct_matrice *) (*s_objet_argument).objet))
				.nombre_lignes; i++)
		{
			for(j = 0; j < (*((struct_matrice *) (*s_objet_argument).objet))
					.nombre_colonnes; j++)
			{
				((real8 *) accumulateur)[j] = fabs(((real8 **)
						(*((struct_matrice *) (*s_objet_argument).objet))
						.tableau)[i][j]);
			}

			cumul_reel = sommation_vecteur_reel(accumulateur,
					&((*((struct_matrice *) (*s_objet_argument).objet))
					.nombre_colonnes), &erreur_memoire);

			if (erreur_memoire == d_vrai)
			{
				(*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
				return;
			}

			if (cumul_reel > (*((real8 *) (*s_objet_resultat).objet)))
			{
				(*((real8 *) (*s_objet_resultat).objet)) = cumul_reel;
			}
		}

		free(accumulateur);
	}
	else if ((*s_objet_argument).type == MCX)
	{
		if ((s_objet_resultat = allocation(s_etat_processus, REL)) == NULL)
		{
			(*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
			return;
		}

		if ((accumulateur = malloc(((size_t) (*((struct_matrice *)
				(*s_objet_argument).objet)).nombre_colonnes) * sizeof(real8)))
				== NULL)
		{
			(*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
			return;
		}

		(*((real8 *) (*s_objet_resultat).objet)) = 0;
		
		for(i = 0; i < (*((struct_matrice *) (*s_objet_argument).objet))
				.nombre_lignes; i++)
		{
			for(j = 0; j < (*((struct_matrice *) (*s_objet_argument).objet))
					.nombre_colonnes; j++)
			{
				f77absc_(&(((struct_complexe16 **) (*((struct_matrice *)
						(*s_objet_argument).objet)).tableau)[i][j]),
						&(((real8 *) accumulateur)[j]));
			}

			cumul_reel = sommation_vecteur_reel(accumulateur,
					&((*((struct_matrice *) (*s_objet_argument).objet))
					.nombre_colonnes), &erreur_memoire);

			if (erreur_memoire == d_vrai)
			{
				(*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
				return;
			}

			if (cumul_reel > (*((real8 *) (*s_objet_resultat).objet)))
			{
				(*((real8 *) (*s_objet_resultat).objet)) = cumul_reel;
			}
		}

		free(accumulateur);
	}
/*
--------------------------------------------------------------------------------
  Traitement impossible du fait du type de l'argument
--------------------------------------------------------------------------------
*/

	else
	{
		liberation(s_etat_processus, s_objet_argument);

		(*s_etat_processus).erreur_execution = d_ex_erreur_type_argument;
		return;
	}

	if (empilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
			s_objet_resultat) == d_erreur)
	{
		return;
	}

	liberation(s_etat_processus, s_objet_argument);

	return;
}


/*
================================================================================
  Fonction 'rceq'
================================================================================
  Entrées : pointeur sur une structure struct_processus
--------------------------------------------------------------------------------
  Sorties :
--------------------------------------------------------------------------------
  Effets de bord : néant
================================================================================
*/

void
instruction_rceq(struct_processus *s_etat_processus)
{
	struct_objet			*s_objet_variable;

	(*s_etat_processus).erreur_execution = d_ex;

	if ((*s_etat_processus).affichage_arguments == 'Y')
	{
		printf("\n  RCEQ ");

		if ((*s_etat_processus).langue == 'F')
		{
			printf("(rappel de la variable EQ)\n\n");
		}
		else
		{
			printf("(recall EQ variable)\n\n");
		}

		printf("->  1: %s, %s, %s, %s, %s, %s,\n"
				"       %s, %s, %s, %s, %s,\n"
				"       %s, %s, %s, %s, %s,\n"
				"       %s, %s, %s, %s,\n"
				"       %s, %s, %s\n",
				d_INT, d_REL, d_CPL, d_VIN, d_VRL, d_VCX, d_MIN, d_MRL, d_MCX,
				d_TAB, d_BIN, d_NOM, d_CHN, d_LST, d_ALG, d_RPN, d_FCH, d_SCK,
				d_SQL, d_SLB, d_PRC, d_MTX, d_REC);

		return;
	}
	else if ((*s_etat_processus).test_instruction == 'Y')
	{
		(*s_etat_processus).nombre_arguments = -1;
		return;
	}

	if (test_cfsf(s_etat_processus, 31) == d_vrai)
	{
		if (empilement_pile_last(s_etat_processus, 0) == d_erreur)
		{
			return;
		}
	}

	if (recherche_variable_globale(s_etat_processus, "EQ") == d_faux)
	{
		(*s_etat_processus).erreur_systeme = d_es;

		if ((*s_etat_processus).erreur_execution == d_ex)
		{
			(*s_etat_processus).erreur_execution = d_ex_variable_non_definie;
		}

		return;
	}

	if ((s_objet_variable = copie_objet(s_etat_processus,
			(*(*s_etat_processus).pointeur_variable_courante).objet, 'P'))
			== NULL)
	{
		(*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
		return;
	}

	if (empilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
			s_objet_variable) == d_erreur)
	{
		return;
	}

	return;
}


/*
================================================================================
  Fonction 'res'
================================================================================
  Entrées : pointeur sur une structure struct_processus
--------------------------------------------------------------------------------
  Sorties :
--------------------------------------------------------------------------------
  Effets de bord : néant
================================================================================
*/

void
instruction_res(struct_processus *s_etat_processus)
{
	struct_objet				*s_objet;

	(*s_etat_processus).erreur_execution = d_ex;

	if ((*s_etat_processus).affichage_arguments == 'Y')
	{
		printf("\n  RES ");

		if ((*s_etat_processus).langue == 'F')
		{
			printf("(résolution)\n\n");
		}
		else
		{
			printf("(resolution)\n\n");
		}

		printf("    1: %s, %s\n", d_INT, d_REL);

		return;
	}
	else if ((*s_etat_processus).test_instruction == 'Y')
	{
		(*s_etat_processus).nombre_arguments = -1;
		return;
	}

	if (test_cfsf(s_etat_processus, 31) == d_vrai)
	{
		if (empilement_pile_last(s_etat_processus, 1) == d_erreur)
		{
			return;
		}
	}

	if (depilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
			&s_objet) == d_erreur)
	{
		(*s_etat_processus).erreur_execution = d_ex_manque_argument;
		return;
	}

	if ((*s_objet).type == INT)
	{
		if ((*((integer8 *) (*s_objet).objet)) <= 0)
		{
			liberation(s_etat_processus, s_objet);

			(*s_etat_processus).erreur_execution = d_ex_erreur_type_argument;
			return;
		}

		(*s_etat_processus).resolution = (real8) (*((integer8 *)
				(*s_objet).objet));
	}
	else if ((*s_objet).type == REL)
	{
		if ((*((real8 *) (*s_objet).objet)) <= 0)
		{
			liberation(s_etat_processus, s_objet);

			(*s_etat_processus).erreur_execution = d_ex_argument_invalide;
			return;
		}

		(*s_etat_processus).resolution = (*((real8 *) (*s_objet).objet));
	}
	else
	{
		liberation(s_etat_processus, s_objet);

		(*s_etat_processus).erreur_execution = d_ex_erreur_type_argument;
		return;
	}

	liberation(s_etat_processus, s_objet);
	return;
}


/*
================================================================================
  Fonction 'recall'
================================================================================
  Entrées : pointeur sur une structure struct_processus
--------------------------------------------------------------------------------
  Sorties :
--------------------------------------------------------------------------------
  Effets de bord : néant
================================================================================
*/

void
instruction_recall(struct_processus *s_etat_processus)
{
	file					*pipe;
	file					*fichier;

	int						caractere;
	int						ios;

	logical1				drapeau_fin;
	logical1				indicateur_48;
	logical1				presence_chaine;

	long					i;
	long					nombre_caracteres_source;

	struct_objet			*s_objet;

	unsigned char			autorisation_empilement_programme;
	unsigned char			*chaine;
	unsigned char			*commande;
	unsigned char			*executable_candidat;

#	ifndef OS2
	unsigned char			*instructions = "%s/bin/rpliconv %s "
									"`%s/bin/rplfile "
									"-m %s/share/rplfiles -i %s | "
									"%s/bin/rplawk "
									"'{ print $3; }' | %s/bin/rplawk -F= '{ if "
									"($2 != \"\") printf(\"-f %%s\", $2); }'` "
									"-t `locale charmap` | %s/bin/%s -o %s";
#	else
	unsigned char			*instructions = BOURNE_SHELL
									" -c \"%s/bin/rpliconv %s "
									"`%s/bin/rplfile "
									"-m %s/share/rplfiles -i %s | "
									"%s/bin/rplawk "
									"'{ print $3; }' | %s/bin/rplawk -F= '{ if "
									"($2 != \\\"\\\") printf(\\\"-f %%s\\\", "
									"$2); }'` -t `" d_locale
									"` | %s/bin/%s -o %s\"";
#	endif

	unsigned char			*nom_fichier_temporaire;
	unsigned char			*tampon_definitions_chainees;
	unsigned char			*tampon_instruction_courante;

	integer8				position_courante;

	(*s_etat_processus).erreur_execution = d_ex;

	if ((*s_etat_processus).affichage_arguments == 'Y')
	{
		printf("\n  RECALL ");

		if ((*s_etat_processus).langue == 'F')
		{
			printf("(rappel d'une variable stockée sur disque)\n\n");
		}
		else
		{
			printf("(recall a variable stored on disk)\n\n");
		}

		printf("    1: %s\n", d_CHN);
		printf("->  1: %s, %s, %s, %s, %s, %s,\n"
				"       %s, %s, %s, %s, %s,\n"
				"       %s, %s, %s, %s, %s\n",
				d_INT, d_REL, d_CPL, d_VIN, d_VRL, d_VCX, d_MIN, d_MRL, d_MCX,
				d_TAB, d_BIN, d_NOM, d_CHN, d_LST, d_ALG, d_RPN);

		return;
	}
	else if ((*s_etat_processus).test_instruction == 'Y')
	{
		(*s_etat_processus).nombre_arguments = -1;
		return;
	}

	if (test_cfsf(s_etat_processus, 31) == d_vrai)
	{
		if (empilement_pile_last(s_etat_processus, 1) == d_erreur)
		{
			return;
		}
	}

	if (depilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
			&s_objet) == d_erreur)
	{
		(*s_etat_processus).erreur_execution = d_ex_manque_argument;
		return;
	}

	if ((*s_objet).type == CHN)
	{
		if ((fichier = fopen((unsigned char *) (*s_objet).objet, "r")) == NULL)
		{
			liberation(s_etat_processus, s_objet);

			(*s_etat_processus).erreur_execution = d_ex_erreur_fichier;
			return;
		}

		if (fclose(fichier) != 0)
		{
			(*s_etat_processus).erreur_systeme = d_es_erreur_fichier;
			return;
		}

		if ((nom_fichier_temporaire = creation_nom_fichier(s_etat_processus,
				(*s_etat_processus).chemin_fichiers_temporaires)) == NULL)
		{
			(*s_etat_processus).erreur_systeme = d_es_erreur_fichier;
			return;
		}

		if ((*s_etat_processus).rpl_home == NULL)
		{
			if ((commande = malloc((strlen(ds_preprocesseur) +
					(2 * strlen((unsigned char *) (*s_objet).objet)) +
					(6 * strlen(d_exec_path)) + 
					strlen(nom_fichier_temporaire) + strlen(instructions) - 19)
					* sizeof(unsigned char))) == NULL)
			{
				(*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
				return;
			}

			sprintf(commande, instructions, d_exec_path,
					(unsigned char *) (*s_objet).objet,
					d_exec_path, d_exec_path,
					(unsigned char *) (*s_objet).objet,
					d_exec_path, d_exec_path,
					d_exec_path, ds_preprocesseur, nom_fichier_temporaire);

			if (alsprintf(s_etat_processus, &executable_candidat,
					"%s/bin/rpliconv", d_exec_path) < 0)
			{
				(*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
				return;
			}

			if (controle_integrite(s_etat_processus, executable_candidat,
					"rpliconv") != d_vrai)
			{
				(*s_etat_processus).erreur_systeme = d_es_somme_controle;
				return;
			}

			free(executable_candidat);

			if (alsprintf(s_etat_processus, &executable_candidat,
					"%s/bin/rplfile", d_exec_path) < 0)
			{
				(*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
				return;
			}

			if (controle_integrite(s_etat_processus, executable_candidat,
					"rplfile") != d_vrai)
			{
				(*s_etat_processus).erreur_systeme = d_es_somme_controle;
				return;
			}

			free(executable_candidat);

			if (alsprintf(s_etat_processus, &executable_candidat,
					"%s/bin/rplpp", d_exec_path) < 0)
			{
				(*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
				return;
			}

			if (controle_integrite(s_etat_processus, executable_candidat,
					"rplpp") != d_vrai)
			{
				(*s_etat_processus).erreur_systeme = d_es_somme_controle;
				return;
			}

			free(executable_candidat);

			if (alsprintf(s_etat_processus, &executable_candidat,
					"%s/bin/rplawk", d_exec_path) < 0)
			{
				(*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
				return;
			}

			if (controle_integrite(s_etat_processus, executable_candidat,
					"rplawk") != d_vrai)
			{
				(*s_etat_processus).erreur_systeme = d_es_somme_controle;
				return;
			}

			free(executable_candidat);
		}
		else
		{
			if ((commande = malloc((strlen(ds_preprocesseur) +
					(2 * strlen((unsigned char *) (*s_objet).objet)) +
					(6 * strlen((*s_etat_processus).rpl_home)) + 
					strlen(nom_fichier_temporaire) + strlen(instructions) - 19)
					* sizeof(unsigned char))) == NULL)
			{
				(*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
				return;
			}

			sprintf(commande, instructions, (*s_etat_processus).rpl_home,
					(unsigned char *) (*s_objet).objet,
					(*s_etat_processus).rpl_home, (*s_etat_processus).rpl_home,
					(unsigned char *) (*s_objet).objet,
					(*s_etat_processus).rpl_home, (*s_etat_processus).rpl_home,
					(*s_etat_processus).rpl_home, ds_preprocesseur,
					nom_fichier_temporaire);

			if (alsprintf(s_etat_processus, &executable_candidat,
					"%s/bin/rpliconv", (*s_etat_processus).rpl_home) < 0)
			{
				(*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
				return;
			}

			if (controle_integrite(s_etat_processus, executable_candidat,
					"rpliconv") != d_vrai)
			{
				(*s_etat_processus).erreur_systeme = d_es_somme_controle;
				return;
			}

			free(executable_candidat);

			if (alsprintf(s_etat_processus, &executable_candidat,
					"%s/bin/rplfile", (*s_etat_processus).rpl_home) < 0)
			{
				(*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
				return;
			}

			if (controle_integrite(s_etat_processus, executable_candidat,
					"rplfile") != d_vrai)
			{
				(*s_etat_processus).erreur_systeme = d_es_somme_controle;
				return;
			}

			free(executable_candidat);

			if (alsprintf(s_etat_processus, &executable_candidat,
					"%s/bin/rplpp", (*s_etat_processus).rpl_home) < 0)
			{
				(*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
				return;
			}

			if (controle_integrite(s_etat_processus, executable_candidat,
					"rplpp") != d_vrai)
			{
				(*s_etat_processus).erreur_systeme = d_es_somme_controle;
				return;
			}

			free(executable_candidat);

			if (alsprintf(s_etat_processus, &executable_candidat,
					"%s/bin/rplawk", d_exec_path) < 0)
			{
				(*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
				return;
			}

			if (controle_integrite(s_etat_processus, executable_candidat,
					"rplawk") != d_vrai)
			{
				(*s_etat_processus).erreur_systeme = d_es_somme_controle;
				return;
			}

			free(executable_candidat);
		}

		if ((pipe = popen(commande, "r")) == NULL)
		{
			(*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
			return;
		}

		if ((ios = pclose(pipe)) != EXIT_SUCCESS)
		{
			liberation(s_etat_processus, s_objet);
			free(commande);

			(*s_etat_processus).erreur_execution = d_ex_erreur_fichier;
			return;
		}
		else if (ios == -1)
		{
			(*s_etat_processus).erreur_systeme = d_es_processus;
			return;
		}

		free(commande);

		nombre_caracteres_source = 0;

		if ((pipe = fopen(nom_fichier_temporaire, "r")) == NULL)
		{
			(*s_etat_processus).erreur_systeme = d_es_erreur_fichier;
			return;
		}

		while(getc(pipe) != EOF)
		{
			nombre_caracteres_source++;
		}

		if (nombre_caracteres_source == 0)
		{
			if (fclose(pipe) == -1)
			{
				(*s_etat_processus).erreur_systeme = d_es_processus;
				return;
			}

			liberation(s_etat_processus, s_objet);

			if (destruction_fichier(nom_fichier_temporaire) == d_erreur)
			{
				(*s_etat_processus).erreur_systeme = d_es_erreur_fichier;
				return;
			}

			free(nom_fichier_temporaire);

			(*s_etat_processus).erreur_execution = d_ex_fichier_vide;
			return;
		}

		if ((chaine = malloc((((size_t) nombre_caracteres_source) + 1)
				* sizeof(unsigned char))) == NULL)
		{
			(*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
			return;
		}

		rewind(pipe);

		i = 0;
		drapeau_fin = d_faux;
		presence_chaine = d_faux;

		while(drapeau_fin == d_faux)
		{
			if ((caractere = getc(pipe)) != EOF)
			{
				if ((caractere == d_code_retour_chariot) ||
						(caractere == d_code_tabulation) ||
						((caractere == d_code_espace) &&
						(presence_chaine == d_faux)))
				{
					do
					{
						caractere = getc(pipe);
					} while(((caractere == d_code_retour_chariot) ||
							(caractere == d_code_tabulation) ||
							((caractere == d_code_espace) &&
							(presence_chaine == d_faux))) &&
							(caractere != EOF));

					if (caractere != EOF)
					{
						chaine[i++] = d_code_espace;
					}
					else
					{
						drapeau_fin = d_vrai;
					}
				}

				if ((chaine[i] = (unsigned char) caractere) == '\"')
				{
					if (i > 0)
					{
						if (chaine[i - 1] != '\\')
						{
							presence_chaine = (presence_chaine == d_faux)
									? d_vrai : d_faux;
						}
					}

					i++;
				}
				else
				{
					i++;
				}
			}
			else
			{
				drapeau_fin = d_vrai;
			}
		}

		if ((caractere == EOF) && (i > 0))
		{
			i--;
		}

		chaine[i] = d_code_fin_chaine;

		if (fclose(pipe) != 0)
		{
			(*s_etat_processus).erreur_systeme = d_es_erreur_fichier;
			return;
		}

		indicateur_48 = test_cfsf(s_etat_processus, 48);
		cf(s_etat_processus, 48);

		tampon_definitions_chainees = (*s_etat_processus).definitions_chainees;
		tampon_instruction_courante = (*s_etat_processus).instruction_courante;
		position_courante = (*s_etat_processus).position_courante;
		autorisation_empilement_programme = (*s_etat_processus)
				.autorisation_empilement_programme;

		(*s_etat_processus).instruction_courante = NULL;

		if (((*s_etat_processus).definitions_chainees = transliteration(
				s_etat_processus, chaine, "UTF-8", d_locale)) == NULL)
		{
			if (indicateur_48 == d_vrai)
			{
				sf(s_etat_processus, 48);
			}
			else
			{
				cf(s_etat_processus, 48);
			}

			if (destruction_fichier(nom_fichier_temporaire) == d_erreur)
			{
				(*s_etat_processus).erreur_systeme = d_es_erreur_fichier;
				return;
			}

			free(nom_fichier_temporaire);
			free((*s_etat_processus).instruction_courante);
			free(chaine);

			(*s_etat_processus).position_courante = position_courante;
			(*s_etat_processus).instruction_courante =
					tampon_instruction_courante;
			(*s_etat_processus).definitions_chainees =
					tampon_definitions_chainees;
			(*s_etat_processus).autorisation_empilement_programme =
					autorisation_empilement_programme;

			liberation(s_etat_processus, s_objet);
			return;
		}

		(*s_etat_processus).autorisation_empilement_programme = 'Y';
		(*s_etat_processus).position_courante = 0;

		if (analyse_syntaxique(s_etat_processus) == d_erreur)
		{
			if (indicateur_48 == d_vrai)
			{
				sf(s_etat_processus, 48);
			}
			else
			{
				cf(s_etat_processus, 48);
			}

			if (destruction_fichier(nom_fichier_temporaire) == d_erreur)
			{
				(*s_etat_processus).erreur_systeme = d_es_erreur_fichier;
				return;
			}

			free(nom_fichier_temporaire);
			free((*s_etat_processus).instruction_courante);
			free((*s_etat_processus).definitions_chainees);
			free(chaine);

			(*s_etat_processus).position_courante = position_courante;
			(*s_etat_processus).instruction_courante =
					tampon_instruction_courante;
			(*s_etat_processus).definitions_chainees =
					tampon_definitions_chainees;
			(*s_etat_processus).autorisation_empilement_programme =
					autorisation_empilement_programme;

			liberation(s_etat_processus, s_objet);
			return;
		}

		(*s_etat_processus).position_courante = 0;

		if (recherche_instruction_suivante(s_etat_processus) !=
				d_absence_erreur)
		{
			if (indicateur_48 == d_vrai)
			{
				sf(s_etat_processus, 48);
			}
			else
			{
				cf(s_etat_processus, 48);
			}

			if (destruction_fichier(nom_fichier_temporaire) == d_erreur)
			{
				(*s_etat_processus).erreur_systeme = d_es_erreur_fichier;
				return;
			}

			free(nom_fichier_temporaire);
			free((*s_etat_processus).instruction_courante);
			free((*s_etat_processus).definitions_chainees);
			free(chaine);

			(*s_etat_processus).position_courante = position_courante;
			(*s_etat_processus).instruction_courante =
					tampon_instruction_courante;
			(*s_etat_processus).definitions_chainees =
					tampon_definitions_chainees;
			(*s_etat_processus).autorisation_empilement_programme =
					autorisation_empilement_programme;

			liberation(s_etat_processus, s_objet);
			return;
		}

		(*s_etat_processus).type_en_cours = NON;
		recherche_type(s_etat_processus);

		while((*s_etat_processus).definitions_chainees
				[(*s_etat_processus).position_courante] != d_code_fin_chaine)
		{
			if ((*s_etat_processus).definitions_chainees
					[(*s_etat_processus).position_courante++] != d_code_espace)
			{
				(*s_etat_processus).erreur_execution = d_ex_syntaxe;
			}
		}

		free((*s_etat_processus).instruction_courante);
		free((*s_etat_processus).definitions_chainees);
		free(chaine);

		(*s_etat_processus).position_courante = position_courante;
		(*s_etat_processus).instruction_courante =
				tampon_instruction_courante;
		(*s_etat_processus).definitions_chainees =
				tampon_definitions_chainees;
		(*s_etat_processus).autorisation_empilement_programme =
				autorisation_empilement_programme;

		if (indicateur_48 == d_vrai)
		{
			sf(s_etat_processus, 48);
		}
		else
		{
			cf(s_etat_processus, 48);
		}

		if (destruction_fichier(nom_fichier_temporaire) == d_erreur)
		{
			(*s_etat_processus).erreur_systeme = d_es_erreur_fichier;
			return;
		}

		free(nom_fichier_temporaire);
	}
	else
	{
		liberation(s_etat_processus, s_objet);

		(*s_etat_processus).erreur_execution = d_ex_erreur_type_argument;
		return;
	}

	liberation(s_etat_processus, s_objet);
	return;
}


/*
================================================================================
  Fonction 'rcws'
================================================================================
  Entrées : pointeur sur une structure struct_processus
--------------------------------------------------------------------------------
  Sorties :
--------------------------------------------------------------------------------
  Effets de bord : néant
================================================================================
*/

void
instruction_rcws(struct_processus *s_etat_processus)
{
	struct_objet				*s_objet_resultat;

	integer8					i;
	integer8					j;
	integer8					longueur;

	(*s_etat_processus).erreur_execution = d_ex;

	if ((*s_etat_processus).affichage_arguments == 'Y')
	{
		printf("\n  RCWS ");

		if ((*s_etat_processus).langue == 'F')
		{
			printf("(rappel de la longueur des entiers binaires)\n\n");
		}
		else
		{
			printf("(recall the length of the binary integers)\n\n");
		}

		printf("->  1: %s\n", d_INT);

		return;
	}
	else if ((*s_etat_processus).test_instruction == 'Y')
	{
		(*s_etat_processus).nombre_arguments = -1;
		return;
	}

	if (test_cfsf(s_etat_processus, 31) == d_vrai)
	{
		if (empilement_pile_last(s_etat_processus, 0) == d_erreur)
		{
			return;
		}
	}

	if ((s_objet_resultat = allocation(s_etat_processus, INT)) == NULL)
	{
		(*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
		return;
	}

	longueur = 1;
	j = 1;

	for(i = 37; i <= 42; i++)
	{
		longueur += (test_cfsf(s_etat_processus, (unsigned char) i)
				== d_vrai) ? j : 0;
		j *= 2;
	}

	(*((integer8 *) (*s_objet_resultat).objet)) = longueur;

	if (empilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
			s_objet_resultat) == d_erreur)
	{
		return;
	}

	return;
}


/*
================================================================================
  Fonction 'rcls'
================================================================================
  Entrées : pointeur sur une structure struct_processus
--------------------------------------------------------------------------------
  Sorties :
--------------------------------------------------------------------------------
  Effets de bord : néant
================================================================================
*/

void
instruction_rcls(struct_processus *s_etat_processus)
{
	struct_objet			*s_objet_variable;

	(*s_etat_processus).erreur_execution = d_ex;

	if ((*s_etat_processus).affichage_arguments == 'Y')
	{
		printf("\n  RCLS ");

		if ((*s_etat_processus).langue == 'F')
		{
			printf("(rappel de la variable %s)\n\n", ds_sdat);
		}
		else
		{
			printf("(recall %s variable)\n\n", ds_sdat);
		}

		printf("->  1: %s, %s, %s, %s, %s, %s,\n"
				"       %s, %s, %s, %s, %s,\n"
				"       %s, %s, %s, %s, %s,\n"
				"       %s\n",
				d_INT, d_REL, d_CPL, d_VIN, d_VRL, d_VCX, d_MIN, d_MRL, d_MCX,
				d_BIN, d_NOM, d_CHN, d_LST, d_ALG, d_RPN, d_FCH, d_SLB);

		return;
	}
	else if ((*s_etat_processus).test_instruction == 'Y')
	{
		(*s_etat_processus).nombre_arguments = -1;
		return;
	}

	if (test_cfsf(s_etat_processus, 31) == d_vrai)
	{
		if (empilement_pile_last(s_etat_processus, 0) == d_erreur)
		{
			return;
		}
	}

	if (recherche_variable_globale(s_etat_processus, ds_sdat) == d_faux)
	{
		(*s_etat_processus).erreur_systeme = d_es;

		if ((*s_etat_processus).erreur_execution == d_ex)
		{
			(*s_etat_processus).erreur_execution = d_ex_variable_non_definie;
		}

		return;
	}

	if ((s_objet_variable = copie_objet(s_etat_processus,
			(*(*s_etat_processus).pointeur_variable_courante).objet, 'O'))
			== NULL)
	{
		(*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
		return;
	}

	if (empilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
			s_objet_variable) == d_erreur)
	{
		return;
	}

	return;
}

// vim: ts=4