/*
================================================================================
  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 'until'
================================================================================
  Entrées : pointeur sur une structure struct_processus
--------------------------------------------------------------------------------
  Sorties :
--------------------------------------------------------------------------------
  Effets de bord : néant
================================================================================
*/

void
instruction_until(struct_processus *s_etat_processus)
{
	(*s_etat_processus).erreur_execution = d_ex;

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

		if ((*s_etat_processus).langue == 'F')
		{
			printf("(structure de contrôle)\n\n");
			printf("  Utilisation :\n\n");
		}
		else
		{
			printf("(control statement)\n\n");
			printf("  Usage:\n\n");
		}

		printf("    DO\n");
		printf("        (expression 1)\n");
		printf("        EXIT\n");
		printf("        (expression 2)\n");
		printf("    UNTIL\n");
		printf("        (clause)\n");
		printf("    END\n\n");

		printf("    DO\n");
		printf("        (expression)\n");
		printf("    UNTIL\n");
		printf("        (clause)\n");
		printf("    END\n");

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

	(*(*s_etat_processus).l_base_pile_systeme).clause = 'U';

	return;
}


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

void
instruction_utpc(struct_processus *s_etat_processus)
{
	integer8					n;

	real8						x;

	struct_objet				*s_objet_argument_1;
	struct_objet				*s_objet_argument_2;
	struct_objet				*s_objet_resultat;

	(*s_etat_processus).erreur_execution = d_ex;

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

		if ((*s_etat_processus).langue == 'F')
		{
			printf("(loi du Xhi carrée cumulé à droite)\n\n");
		}
		else
		{
			printf("(upper-tail probability chi-square distribution)\n\n");
		}

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

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

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

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

	if (depilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
			&s_objet_argument_2) == d_erreur)
	{
		liberation(s_etat_processus, s_objet_argument_1);

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

	if (((*s_objet_argument_2).type == INT) &&
			(((*s_objet_argument_1).type == REL) ||
			((*s_objet_argument_1).type == INT)))
	{
		n = (integer4) (*((integer8 *) (*s_objet_argument_2).objet));

		if (n <= 0)
		{
			liberation(s_etat_processus, s_objet_argument_1);
			liberation(s_etat_processus, s_objet_argument_2);

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

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

		if ((*s_objet_argument_1).type == INT)
		{
			x = (real8) (*((integer8 *) (*s_objet_argument_1).objet));
		}
		else
		{
			x = (*((real8 *) (*s_objet_argument_1).objet));
		}

		if (x < 0)
		{
			(*((real8 *) (*s_objet_resultat).objet)) = 1;
		}
		else
		{
			f90x2cd(&x, &n, (real8 *) (*s_objet_resultat).objet);
		}
	}
	else
	{
		liberation(s_etat_processus, s_objet_argument_1);
		liberation(s_etat_processus, s_objet_argument_2);

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

	liberation(s_etat_processus, s_objet_argument_1);
	liberation(s_etat_processus, s_objet_argument_2);

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

	return;
}


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

void
instruction_utpn(struct_processus *s_etat_processus)
{
	real8						moyenne;
	real8						variance;
	real8						x;

	struct_objet				*s_objet_argument_1;
	struct_objet				*s_objet_argument_2;
	struct_objet				*s_objet_argument_3;
	struct_objet				*s_objet_resultat;

	(*s_etat_processus).erreur_execution = d_ex;

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

		if ((*s_etat_processus).langue == 'F')
		{
			printf("(loi normale cumulée à droite)\n\n");
		}
		else
		{
			printf("(upper-tail probability normal distribution)\n\n");
		}

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

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

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

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

	if (depilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
			&s_objet_argument_2) == d_erreur)
	{
		liberation(s_etat_processus, s_objet_argument_1);

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

	if (depilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
			&s_objet_argument_3) == d_erreur)
	{
		liberation(s_etat_processus, s_objet_argument_1);
		liberation(s_etat_processus, s_objet_argument_2);

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

	if ((((*s_objet_argument_1).type == INT) ||
			((*s_objet_argument_1).type == REL)) &&
			(((*s_objet_argument_2).type == INT) ||
			((*s_objet_argument_2).type == REL)) &&
			(((*s_objet_argument_3).type == INT) ||
			((*s_objet_argument_3).type == REL)))
	{
		if ((s_objet_resultat = allocation(s_etat_processus, REL))
				== NULL)
		{
			(*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
			return;
		}

		if ((*s_objet_argument_1).type == INT)
		{
			x = (real8) (*((integer8 *) (*s_objet_argument_1).objet));
		}
		else
		{
			x = (*((real8 *) (*s_objet_argument_1).objet));
		}

		if ((*s_objet_argument_3).type == INT)
		{
			moyenne = (real8) (*((integer8 *) (*s_objet_argument_3).objet));
		}
		else
		{
			moyenne = (*((real8 *) (*s_objet_argument_3).objet));
		}

		if ((*s_objet_argument_2).type == INT)
		{
			variance = (real8) (*((integer8 *) (*s_objet_argument_2).objet));
		}
		else
		{
			variance = (*((real8 *) (*s_objet_argument_2).objet));
		}


		if (variance == 0)
		{
			(*((real8 *) (*s_objet_resultat).objet)) = 0;
		}
		else if (variance > 0)
		{
			f90gausscd(&x, &moyenne, &variance,
					(real8 *) (*s_objet_resultat).objet);
		}
		else
		{
			liberation(s_etat_processus, s_objet_argument_1);
			liberation(s_etat_processus, s_objet_argument_2);
			liberation(s_etat_processus, s_objet_argument_3);
			liberation(s_etat_processus, s_objet_resultat);

			(*s_etat_processus).erreur_execution = d_ex_erreur_type_argument;
			return;
		}
	}
	else
	{
		liberation(s_etat_processus, s_objet_argument_1);
		liberation(s_etat_processus, s_objet_argument_2);
		liberation(s_etat_processus, s_objet_argument_3);

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

	liberation(s_etat_processus, s_objet_argument_1);
	liberation(s_etat_processus, s_objet_argument_2);
	liberation(s_etat_processus, s_objet_argument_3);

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

	return;
}


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

void
instruction_utpf(struct_processus *s_etat_processus)
{
	integer8					n1;
	integer8					n2;

	real8						x;

	struct_objet				*s_objet_argument_1;
	struct_objet				*s_objet_argument_2;
	struct_objet				*s_objet_argument_3;
	struct_objet				*s_objet_resultat;

	(*s_etat_processus).erreur_execution = d_ex;

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

		if ((*s_etat_processus).langue == 'F')
		{
			printf("(loi F cumulée à droite)\n\n");
		}
		else
		{
			printf("(upper-tail probability F distribution)\n\n");
		}

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

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

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

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

	if (depilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
			&s_objet_argument_2) == d_erreur)
	{
		liberation(s_etat_processus, s_objet_argument_1);

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

	if (depilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
			&s_objet_argument_3) == d_erreur)
	{
		liberation(s_etat_processus, s_objet_argument_1);
		liberation(s_etat_processus, s_objet_argument_2);

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

	if ((((*s_objet_argument_1).type == INT) ||
			((*s_objet_argument_1).type == REL)) &&
			((*s_objet_argument_2).type == INT) &&
			((*s_objet_argument_3).type == INT))
	{
		n1 = (integer4) (*((integer8 *) (*s_objet_argument_3).objet));
		n2 = (integer4) (*((integer8 *) (*s_objet_argument_2).objet));

		if ((n1 <= 0) || (n2 <= 0))
		{
			liberation(s_etat_processus, s_objet_argument_1);
			liberation(s_etat_processus, s_objet_argument_2);
			liberation(s_etat_processus, s_objet_argument_3);

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

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

		if ((*s_objet_argument_1).type == INT)
		{
			x = (real8) (*((integer8 *) (*s_objet_argument_1).objet));
		}
		else
		{
			x = (*((real8 *) (*s_objet_argument_1).objet));
		}

		if (x < 0)
		{
			(*((real8 *) (*s_objet_resultat).objet)) = 1;
		}
		else
		{
			f90fcd(&x, &n1, &n2, (real8 *) (*s_objet_resultat).objet);
		}
	}
	else
	{
		liberation(s_etat_processus, s_objet_argument_1);
		liberation(s_etat_processus, s_objet_argument_2);
		liberation(s_etat_processus, s_objet_argument_3);

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

	liberation(s_etat_processus, s_objet_argument_1);
	liberation(s_etat_processus, s_objet_argument_2);
	liberation(s_etat_processus, s_objet_argument_3);

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

	return;
}


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

void
instruction_utpt(struct_processus *s_etat_processus)
{
	integer8					n;

	real8						x;

	struct_objet				*s_objet_argument_1;
	struct_objet				*s_objet_argument_2;
	struct_objet				*s_objet_resultat;

	(*s_etat_processus).erreur_execution = d_ex;

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

		if ((*s_etat_processus).langue == 'F')
		{
			printf("(loi du t de Student cumulée à droite)\n\n");
		}
		else
		{
			printf("(upper-tail probability Student's t  distribution)\n\n");
		}

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

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

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

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

	if (depilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
			&s_objet_argument_2) == d_erreur)
	{
		liberation(s_etat_processus, s_objet_argument_1);

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

	if (((*s_objet_argument_2).type == INT) &&
			(((*s_objet_argument_1).type == REL) ||
			((*s_objet_argument_1).type == INT)))
	{
		n = (integer4) (*((integer8 *) (*s_objet_argument_2).objet));

		if (n <= 0)
		{
			liberation(s_etat_processus, s_objet_argument_1);
			liberation(s_etat_processus, s_objet_argument_2);

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

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

		if ((*s_objet_argument_1).type == INT)
		{
			x = (real8) (*((integer8 *) (*s_objet_argument_1).objet));
		}
		else
		{
			x = (*((real8 *) (*s_objet_argument_1).objet));
		}

		f90tcd(&x, &n, (real8 *) (*s_objet_resultat).objet);
	}
	else
	{
		liberation(s_etat_processus, s_objet_argument_1);
		liberation(s_etat_processus, s_objet_argument_2);

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

	liberation(s_etat_processus, s_objet_argument_1);
	liberation(s_etat_processus, s_objet_argument_2);

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

	return;
}


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

void
instruction_use(struct_processus *s_etat_processus)
{
	logical1						existence;
	logical1						ouverture;

	struct_objet					*s_objet_argument;
	struct_objet					*s_objet_resultat;

	unsigned char					*tampon;

	unsigned long					unite;

	void							*bibliotheque;

	(*s_etat_processus).erreur_execution = d_ex;

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

		if ((*s_etat_processus).langue == 'F')
		{
			printf("(insertion d'une bibliothèque dynamique)\n\n");
			printf("Si le chemin ne commence pas par '/', la bibliothèque "
					"est recherchée\n");
			printf("successivement dans le répertoire courant puis dans %s."
					"\n\n", d_exec_path);
		}
		else
		{
			printf("(insert a shared library)\n\n");
			printf("If this path does not begin with '/', RPL/2 tries to find "
					"it in current\n");
			printf("directory or %s in this order.\n\n", d_exec_path);
		}

		printf("    1: %s\n", d_CHN);
		printf("->  1: %s\n", 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, 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;
	}

	if ((*s_objet_argument).type == CHN)
	{
		/*
		 * Si le nom commence par un '/', il est traité comme un chemin
		 * absolu. Dans le cas contraire, on essaye successivement
		 * './' puis le répertoire lib de l'installation du langage.
		 */

		if (((unsigned char *) (*s_objet_argument).objet)[0] != '/')
		{
			if ((tampon = malloc((strlen((unsigned char *) (*s_objet_argument)
					.objet) + 3) * sizeof(unsigned char))) == NULL)
			{
				(*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
				return;
			}

			sprintf(tampon, "./%s", (unsigned char *)
					(*s_objet_argument).objet);

			caracteristiques_fichier(s_etat_processus, tampon,
					&existence, &ouverture, &unite);

			if (existence != d_faux)
			{
				free((unsigned char *) (*s_objet_argument).objet);
				(*s_objet_argument).objet = tampon;
			}
			else
			{
				free(tampon);

				if ((*s_etat_processus).rpl_home == NULL)
				{
					if ((tampon = malloc((strlen((unsigned char *)
							(*s_objet_argument).objet) + strlen(d_exec_path)
							+ 7) * sizeof(unsigned char))) == NULL)
					{
						(*s_etat_processus).erreur_systeme =
								d_es_allocation_memoire;
						return;
					}

					sprintf(tampon, "/%s/lib/%s", d_exec_path, (unsigned char *)
							(*s_objet_argument).objet);
				}
				else
				{
					if ((tampon = malloc((strlen((unsigned char *)
							(*s_objet_argument).objet) +
							strlen((*s_etat_processus).rpl_home)
							+ 7) * sizeof(unsigned char))) == NULL)
					{
						(*s_etat_processus).erreur_systeme =
								d_es_allocation_memoire;
						return;
					}

					sprintf(tampon, "/%s/lib/%s", (*s_etat_processus).rpl_home,
							(unsigned char *) (*s_objet_argument).objet);
				}

				// Si la chaîne commence par '//', on supprime un '/'.
				// tampon[1] existe toujours.

				if (tampon[1] == '/')
				{
					memmove(tampon, tampon + 1, strlen(tampon));
				}

				caracteristiques_fichier(s_etat_processus, tampon,
						&existence, &ouverture, &unite);

				if (existence != d_faux)
				{
					free((unsigned char *) (*s_objet_argument).objet);
					(*s_objet_argument).objet = tampon;
				}
				else
				{
					free(tampon);
				}
			}
		}

		if ((bibliotheque = chargement_bibliotheque(s_etat_processus,
				(unsigned char *) (*s_objet_argument).objet)) == NULL)
		{
			liberation(s_etat_processus, s_objet_argument);
			return;
		}

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

		(*((struct_bibliotheque *) (*s_objet_resultat).objet)).descripteur =
				bibliotheque;
		(*((struct_bibliotheque *) (*s_objet_resultat).objet)).pid = getpid();
		(*((struct_bibliotheque *) (*s_objet_resultat).objet)).tid =
				pthread_self();

		if (((*((struct_bibliotheque *) (*s_objet_resultat).objet)).nom =
				malloc((strlen((unsigned char *) (*s_objet_argument).objet)
				+ 1) * sizeof(unsigned char))) == NULL)
		{
			(*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
			return;
		}

		strcpy((*((struct_bibliotheque *) (*s_objet_resultat).objet)).nom,
				(unsigned char *) (*s_objet_argument).objet);

		liberation(s_etat_processus, s_objet_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;
	}

	return;
}


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

void
instruction_uchol(struct_processus *s_etat_processus)
{
	struct_objet				*s_copie_objet;
	struct_objet				*s_objet;

	(*s_etat_processus).erreur_execution = d_ex;

	if ((*s_etat_processus).affichage_arguments == 'Y')
	{
		printf("\n  UCHOL ");
		
		if ((*s_etat_processus).langue == 'F')
		{
			printf("(décomposition de Cholevski à droite)\n\n");
		}
		else
		{
			printf("(right Cholevski decomposition)\n\n");
		}

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

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

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


/*
--------------------------------------------------------------------------------
  Résultat sous la forme de matrices réelles
--------------------------------------------------------------------------------
*/

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

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

		if ((s_copie_objet = copie_objet(s_etat_processus, s_objet, 'Q'))
				== NULL)
		{
			(*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
			return;
		}

		liberation(s_etat_processus, s_objet);
		s_objet = s_copie_objet;

		factorisation_cholesky(s_etat_processus, (*s_objet).objet, 'U');
		(*s_objet).type = MRL;

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

		if (((*s_etat_processus).exception != d_ep) ||
				((*s_etat_processus).erreur_execution != d_ex))
		{
			if ((*s_etat_processus).exception == d_ep_domaine_definition)
			{
				(*s_etat_processus).exception =
						d_ep_matrice_non_definie_positive;
			}

			liberation(s_etat_processus, s_objet);
			return;
		}
	}

/*
--------------------------------------------------------------------------------
  Résultat sous la forme de matrices complexes
--------------------------------------------------------------------------------
*/

	else if ((*s_objet).type == MCX)
	{
		if ((*((struct_matrice *) (*s_objet).objet)).nombre_lignes !=
				(*((struct_matrice *) (*s_objet).objet)).nombre_colonnes)
		{
			liberation(s_etat_processus, s_objet);

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

		if ((s_copie_objet = copie_objet(s_etat_processus, s_objet, 'Q'))
				== NULL)
		{
			(*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
			return;
		}

		liberation(s_etat_processus, s_objet);
		s_objet = s_copie_objet;

		factorisation_cholesky(s_etat_processus, (*s_objet).objet, 'U');

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

		if (((*s_etat_processus).exception != d_ep) ||
				((*s_etat_processus).erreur_execution != d_ex))
		{
			if ((*s_etat_processus).exception == d_ep_domaine_definition)
			{
				(*s_etat_processus).exception =
						d_ep_matrice_non_definie_positive;
			}

			liberation(s_etat_processus, s_objet);
			return;
		}
	}

/*
--------------------------------------------------------------------------------
  Type d'argument invalide
--------------------------------------------------------------------------------
*/

	else
	{
		liberation(s_etat_processus, s_objet);

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

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

	return;
}


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

void
instruction_unlock(struct_processus *s_etat_processus)
{
	struct flock				lock;

	struct_descripteur_fichier	*descripteur;

	struct_objet				*s_objet;

	(*s_etat_processus).erreur_execution = d_ex;

	if ((*s_etat_processus).affichage_arguments == 'Y')
	{
		printf("\n  UNLOCK ");
		
		if ((*s_etat_processus).langue == 'F')
		{
			printf("(déverrouillage d'un fichier)\n\n");
		}
		else
		{
			printf("(file unlock)\n\n");
		}

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

		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 == FCH)
	{
		lock.l_type = F_UNLCK;
		lock.l_whence = SEEK_SET;
		lock.l_start = 0;
		lock.l_len = 0;
		lock.l_pid = getpid();

		if ((descripteur = descripteur_fichier(s_etat_processus,
				(struct_fichier *) (*s_objet).objet)) == NULL)
		{
			return;
		}

		if (fcntl(fileno((*descripteur).descripteur_c), F_SETLK, &lock)
				== -1)
		{
			liberation(s_etat_processus, s_objet);

			(*s_etat_processus).erreur_execution = d_ex_fichier_verrouille;
			return;
		}
	}
	else
	{
		liberation(s_etat_processus, s_objet);

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

	return;
}


/*
================================================================================
  Fonction 'unprotect'
================================================================================
  Entrées :
--------------------------------------------------------------------------------
  Sorties :
--------------------------------------------------------------------------------
  Effets de bord : néant
================================================================================
*/

void
instruction_unprotect(struct_processus *s_etat_processus)
{
	struct_liste_chainee				*l_element_courant;

	struct_objet						*s_objet;

	(*s_etat_processus).erreur_execution = d_ex;

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

		if ((*s_etat_processus).langue == 'F')
		{
			printf("(déverrouille une variable)\n\n");
		}
		else
		{
			printf("(unlock a variable)\n\n");
		}

		printf("    1: %s, %s\n", d_NOM, d_LST);

		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 == NOM)
	{
		if (recherche_variable(s_etat_processus, ((*((struct_nom *)
				(*s_objet).objet)).nom)) == d_faux)
		{
			liberation(s_etat_processus, s_objet);

			(*s_etat_processus).erreur_systeme = d_es;
			(*s_etat_processus).erreur_execution = d_ex_variable_non_definie;
			return;
		}

		(*(*s_etat_processus).pointeur_variable_courante)
				.variable_verrouillee = d_faux;
	}
	else if ((*s_objet).type == LST)
	{
		l_element_courant = (struct_liste_chainee *) (*s_objet).objet;

		while(l_element_courant != NULL)
		{
			if ((*(*l_element_courant).donnee).type != NOM)
			{
				liberation(s_etat_processus, s_objet);

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

			if (recherche_variable(s_etat_processus, (*((struct_nom *)
					(*(*l_element_courant).donnee).objet)).nom) == d_faux)
			{
				liberation(s_etat_processus, s_objet);

				(*s_etat_processus).erreur_systeme = d_es;
				(*s_etat_processus).erreur_execution =
						d_ex_variable_non_definie;
				return;
			}

			(*(*s_etat_processus).pointeur_variable_courante)
					.variable_verrouillee = d_faux;

			l_element_courant = (*l_element_courant).suivant;
		}
	}
	else
	{
		liberation(s_etat_processus, s_objet);

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

	liberation(s_etat_processus, s_objet);

	return;
}


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

void
instruction_ucase(struct_processus *s_etat_processus)
{
	struct_objet			*s_objet_argument;
	struct_objet			*s_objet_resultat;

	(*s_etat_processus).erreur_execution = d_ex;

	if ((*s_etat_processus).affichage_arguments == 'Y')
	{
		printf("\n  UCASE ");
		
		if ((*s_etat_processus).langue == 'F')
		{
			printf("(converison d'une chaîne de caractères en majuscules)\n\n");
		}
		else
		{
			printf("(convert string to upper case)\n\n");
		}

		printf("    1: %s\n", d_CHN);
		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;
	}

	if ((*s_objet_argument).type == CHN)
	{
		if ((s_objet_resultat = copie_objet(s_etat_processus,
				s_objet_argument, 'O')) == NULL)
		{
			(*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
			return;
		}

		liberation(s_etat_processus, s_objet_argument);
		conversion_chaine(s_etat_processus, (unsigned char *)
				(*s_objet_resultat).objet, 'M');

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

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

	return;
}

// vim: ts=4