/* ================================================================================ RPL/2 (R) version 4.1.0.prerelease.4 Copyright (C) 1989-2011 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 'bin' ================================================================================ Entrées : -------------------------------------------------------------------------------- Sorties : -------------------------------------------------------------------------------- Effets de bord : néant ================================================================================ */ void instruction_bin(struct_processus *s_etat_processus) { (*s_etat_processus).erreur_execution = d_ex; if ((*s_etat_processus).affichage_arguments == 'Y') { printf("\n BIN "); if ((*s_etat_processus).langue == 'F') { printf("(base binaire)\n\n"); printf(" Aucun argument\n"); } else { printf("(binary base)\n\n"); printf(" No argument\n"); } 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; } } cf(s_etat_processus, 43); sf(s_etat_processus, 44); return; } /* ================================================================================ Fonction 'beep' ================================================================================ Entrées : -------------------------------------------------------------------------------- Sorties : -------------------------------------------------------------------------------- Effets de bord : néant ================================================================================ */ void instruction_beep(struct_processus *s_etat_processus) { (*s_etat_processus).erreur_execution = d_ex; if ((*s_etat_processus).affichage_arguments == 'Y') { printf("\n BEEP "); if ((*s_etat_processus).langue == 'F') { printf("(son d'avertissement)\n\n"); printf(" Aucun argument\n"); } else { printf("(warning bell)\n\n"); printf(" No argument\n"); } 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 (test_cfsf(s_etat_processus, 51) == d_faux) { printf("%s", ds_beep); } return; } /* ================================================================================ Fonction 'b->r' ================================================================================ Entrées : pointeur sur une structure struct_processus -------------------------------------------------------------------------------- Sorties : -------------------------------------------------------------------------------- Effets de bord : néant ================================================================================ */ void instruction_b_vers_r(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 B->R "); if ((*s_etat_processus).langue == 'F') { printf("(binaire vers réel)\n\n"); } else { printf("(binary to real)\n\n"); } printf(" 1: %s\n", d_BIN); 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, 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 == BIN) { 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)) = (*((logical8 *) (*s_objet_argument).objet)); } 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 'backspace' ================================================================================ Entrées : -------------------------------------------------------------------------------- Sorties : -------------------------------------------------------------------------------- Effets de bord : néant ================================================================================ */ void instruction_backspace(struct_processus *s_etat_processus) { struct_descripteur_fichier *descripteur; integer8 position_finale; integer8 position_initiale; logical1 presence_chaine; logical1 presence_indicateur; long pointeur; long niveau; size_t longueur_effective; size_t longueur_questure; struct flock lock; struct_objet *s_objet_argument; unsigned char *tampon_lecture; (*s_etat_processus).erreur_execution = d_ex; if ((*s_etat_processus).affichage_arguments == 'Y') { printf("\n BACKSPACE "); if ((*s_etat_processus).langue == 'F') { printf("(retour à l'enregistrement précédent)\n\n"); } else { printf("(return to the previous record)\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_argument) == d_erreur) { (*s_etat_processus).erreur_execution = d_ex_manque_argument; return; } if ((*s_objet_argument).type == FCH) { /* * Fichiers à accès séquentiel */ if ((*((struct_fichier *) (*s_objet_argument).objet)).acces == 'S') { /* * Vérification des verrous */ lock.l_type = F_RDLCK; 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_argument).objet)) == NULL) { liberation(s_etat_processus, s_objet_argument); return; } if (fcntl(fileno((*descripteur).descripteur_c), F_GETLK, &lock) == -1) { liberation(s_etat_processus, s_objet_argument); (*s_etat_processus).erreur_systeme = d_es_erreur_fichier; return; } if (lock.l_type != F_UNLCK) { liberation(s_etat_processus, s_objet_argument); (*s_etat_processus).erreur_execution = d_ex_fichier_verrouille; return; } if ((*((struct_fichier *) (*s_objet_argument).objet)).binaire == 'N') { /* * Fichiers formatés */ if ((position_finale = ftell((*descripteur).descripteur_c)) == -1) { liberation(s_etat_processus, s_objet_argument); (*s_etat_processus).erreur_systeme = d_es_erreur_fichier; return; } longueur_questure = 256; if ((tampon_lecture = malloc(longueur_questure * sizeof(unsigned char))) == NULL) { (*s_etat_processus).erreur_systeme = d_es_allocation_memoire; return; } do { if ((position_initiale = (position_finale - longueur_questure)) < 0) { position_initiale = 0; longueur_effective = position_finale + 1; } else { longueur_effective = longueur_questure; } if (fseek((*descripteur).descripteur_c, position_initiale, SEEK_SET) != 0) { (*s_etat_processus).erreur_systeme = d_es_erreur_fichier; return; } longueur_effective = fread(tampon_lecture, (size_t) sizeof(unsigned char), longueur_effective, (*descripteur).descripteur_c); pointeur = longueur_effective - 1; presence_indicateur = d_faux; while((pointeur >= 0) && (presence_indicateur == d_faux)) { if (tampon_lecture[pointeur] == '}') { presence_indicateur = d_vrai; } else { position_finale--; pointeur--; } } } while((longueur_effective == longueur_questure) && (presence_indicateur == d_faux)); if (presence_indicateur == d_faux) { /* * Le début du fichier est atteint. */ if (fseek((*descripteur).descripteur_c, 0, SEEK_SET) != 0) { liberation(s_etat_processus, s_objet_argument); free(tampon_lecture); (*s_etat_processus).erreur_systeme = d_es_erreur_fichier; return; } (*s_etat_processus).erreur_execution = d_ex_debut_de_fichier_atteint; liberation(s_etat_processus, s_objet_argument); free(tampon_lecture); return; } position_finale = position_finale - 1; presence_chaine = d_faux; niveau = 1; if (position_finale < 0) { liberation(s_etat_processus, s_objet_argument); free(tampon_lecture); (*s_etat_processus).erreur_execution = d_ex_debut_de_fichier_atteint; return; } do { if ((position_initiale = (position_finale - longueur_questure)) < 0) { position_initiale = 0; longueur_effective = position_finale + 1; } else { longueur_effective = longueur_questure; position_finale--; } if (fseek((*descripteur).descripteur_c, position_initiale, SEEK_SET) != 0) { (*s_etat_processus).erreur_systeme = d_es_erreur_fichier; return; } longueur_effective = fread(tampon_lecture, (size_t) sizeof(unsigned char), longueur_effective, (*descripteur).descripteur_c); pointeur = longueur_effective - 1; presence_indicateur = d_faux; while((pointeur >= 0) && (presence_indicateur == d_faux)) { if (tampon_lecture[pointeur] == '"') { presence_chaine = (presence_chaine == d_vrai) ? d_faux : d_vrai; } else { if (tampon_lecture[pointeur] == '}') { niveau++; } else if (tampon_lecture[pointeur] == '{') { niveau--; } } if (niveau == 0) { presence_indicateur = d_vrai; } else { position_finale--; pointeur--; } } } while((longueur_effective == longueur_questure) && (presence_indicateur == d_faux)); if (presence_indicateur == d_faux) { liberation(s_etat_processus, s_objet_argument); free(tampon_lecture); (*s_etat_processus).erreur_execution = d_ex_fin_de_fichier_atteinte; return; } if (fseek((*descripteur).descripteur_c, position_finale, SEEK_SET) != 0) { liberation(s_etat_processus, s_objet_argument); free(tampon_lecture); (*s_etat_processus).erreur_systeme = d_es_erreur_fichier; return; } free(tampon_lecture); } else { /* * Fichiers non formatés */ } } else { liberation(s_etat_processus, s_objet_argument); (*s_etat_processus).erreur_execution = d_ex_erreur_type_fichier; return; } } 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); return; } /* ================================================================================ Fonction 'bessel' ================================================================================ Entrées : -------------------------------------------------------------------------------- Sorties : -------------------------------------------------------------------------------- Effets de bord : néant ================================================================================ */ void instruction_bessel(struct_processus *s_etat_processus) { logical1 creation_expression; struct_liste_chainee *l_element_atome; struct_liste_chainee *l_element_courant; struct_liste_chainee *l_element_precedent; struct_objet *s_copie_argument_1; struct_objet *s_copie_argument_2; struct_objet *s_copie_argument_3; struct_objet *s_objet_argument_1; struct_objet *s_objet_argument_2; struct_objet *s_objet_argument_3; struct_objet *s_objet_resultat; unsigned long i; (*s_etat_processus).erreur_execution = d_ex; if ((*s_etat_processus).affichage_arguments == 'Y') { printf("\n BESSEL "); if ((*s_etat_processus).langue == 'F') { printf("(fonctions de Bessel)\n\n"); } else { printf("(Bessel functions)\n\n"); } printf(" 3: \"J\", \"Y\", \"I\", \"K\", \"j\", \"y\", " "\"i\", \"k\"\n"); printf(" 2: %s, %s\n", d_INT, d_REL); printf(" 1: %s, %s\n", d_INT, d_REL); printf("-> 1: %s\n\n", d_REL); printf(" 3: \"J\", \"Y\", \"I\", \"K\", \"j\", \"y\", " "\"i\", \"k\"\n"); printf(" 2: %s, %s\n", d_INT, d_REL); printf(" 1: %s, %s\n", d_NOM, d_ALG); printf("-> 1: %s\n\n", d_ALG); printf(" 3: \"J\", \"Y\", \"I\", \"K\", \"j\", \"y\", " "\"i\", \"k\"\n"); printf(" 2: %s, %s\n", d_INT, d_REL); printf(" 1: %s\n", d_RPN); printf("-> 1: %s\n", d_RPN); 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; } } /* * Jn fonction cylindrique régulière * Yn fonction cylindrique irrégulière * In fonction cylindrique régulière modifiée * Kn fonction cylindrique irrégulière modifiée * jn fonction sphérique régulière * yn fonction sphérique irrégulière * in fonction sphérique régulière modifiée * kn fonction sphérique irrégulière modifiée * * Attention : Ordre fractionnaire uniquement pour les * fonctions cylindriques */ creation_expression = d_faux; 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_3).type == CHN) { if ((strcmp((unsigned char *) (*s_objet_argument_3).objet, "J") == 0) || (strcmp((unsigned char *) (*s_objet_argument_3).objet, "Y") == 0) || (strcmp((unsigned char *) (*s_objet_argument_3).objet, "I") == 0) || (strcmp((unsigned char *) (*s_objet_argument_3) .objet, "K") == 0) || (strcmp((unsigned char *) (*s_objet_argument_3).objet, "j") == 0) || (strcmp( (unsigned char *) (*s_objet_argument_3).objet, "y") == 0) || (strcmp((unsigned char *) (*s_objet_argument_3).objet, "i") == 0) || (strcmp((unsigned char *) (*s_objet_argument_3).objet, "k") == 0)) { if ((*s_objet_argument_2).type == INT) { if ((*s_objet_argument_1).type == INT) { if ((s_objet_resultat = allocation(s_etat_processus, REL)) == NULL) { (*s_etat_processus).erreur_systeme = d_es_allocation_memoire; return; } switch((*((unsigned char *) (*s_objet_argument_3).objet))) { case 'J' : { (*((real8 *) (*s_objet_resultat).objet)) = gsl_sf_bessel_Jn((int) ((*((integer8 *) (*s_objet_argument_2).objet))), (double) ((*((integer8 *) (*s_objet_argument_1).objet)))); break; } case 'Y' : { if ((*((integer8 *) (*s_objet_argument_1).objet)) <= 0) { (*s_etat_processus).exception = d_ep_resultat_indefini; 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); return; } (*((real8 *) (*s_objet_resultat).objet)) = gsl_sf_bessel_Yn((int) ((*((integer8 *) (*s_objet_argument_2).objet))), (double) ((*((integer8 *) (*s_objet_argument_1).objet)))); break; } case 'I' : { (*((real8 *) (*s_objet_resultat).objet)) = gsl_sf_bessel_In((int) ((*((integer8 *) (*s_objet_argument_2).objet))), (double) ((*((integer8 *) (*s_objet_argument_1).objet)))); break; } case 'K' : { if ((*((integer8 *) (*s_objet_argument_1).objet)) <= 0) { (*s_etat_processus).exception = d_ep_resultat_indefini; 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); return; } (*((real8 *) (*s_objet_resultat).objet)) = gsl_sf_bessel_Kn((int) ((*((integer8 *) (*s_objet_argument_2).objet))), (double) ((*((integer8 *) (*s_objet_argument_1).objet)))); break; } case 'j' : { if (((*((integer8 *) (*s_objet_argument_1).objet)) < 0) || ((*((integer8 *) (*s_objet_argument_2).objet)) < 0)) { (*s_etat_processus).exception = d_ep_resultat_indefini; 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); return; } (*((real8 *) (*s_objet_resultat).objet)) = gsl_sf_bessel_jl((int) ((*((integer8 *) (*s_objet_argument_2).objet))), (double) ((*((integer8 *) (*s_objet_argument_1).objet)))); break; } case 'y' : { if (((*((integer8 *) (*s_objet_argument_1).objet)) <= 0) || ((*((integer8 *) (*s_objet_argument_2).objet)) < 0)) { (*s_etat_processus).exception = d_ep_resultat_indefini; 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); return; } (*((real8 *) (*s_objet_resultat).objet)) = gsl_sf_bessel_yl((int) ((*((integer8 *) (*s_objet_argument_2).objet))), (double) ((*((integer8 *) (*s_objet_argument_1).objet)))); break; } case 'i' : { if ((*((integer8 *) (*s_objet_argument_2).objet)) < 0) { (*s_etat_processus).exception = d_ep_resultat_indefini; 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); return; } (*((real8 *) (*s_objet_resultat).objet)) = exp(fabs((double) (*((integer8 *) (*s_objet_argument_1).objet)))) * gsl_sf_bessel_il_scaled( (int) ((*((integer8 *) (*s_objet_argument_2).objet))), (double) ((*((integer8 *) (*s_objet_argument_1).objet)))); break; } case 'k' : { if (((*((integer8 *) (*s_objet_argument_1).objet)) <= 0) || ((*((integer8 *) (*s_objet_argument_2).objet)) < 0)) { (*s_etat_processus).exception = d_ep_resultat_indefini; 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); return; } (*((real8 *) (*s_objet_resultat).objet)) = exp(fabs((double) (*((integer8 *) (*s_objet_argument_1).objet)))) * gsl_sf_bessel_kl_scaled( (int) ((*((integer8 *) (*s_objet_argument_2).objet))), (double) ((*((integer8 *) (*s_objet_argument_1).objet)))); break; } } } else if ((*s_objet_argument_1).type == REL) { if ((s_objet_resultat = allocation(s_etat_processus, REL)) == NULL) { (*s_etat_processus).erreur_systeme = d_es_allocation_memoire; return; } switch((*((unsigned char *) (*s_objet_argument_3).objet))) { case 'J' : { (*((real8 *) (*s_objet_resultat).objet)) = gsl_sf_bessel_Jn((int) ((*((integer8 *) (*s_objet_argument_2).objet))), (double) ((*((real8 *) (*s_objet_argument_1).objet)))); break; } case 'Y' : { if ((*((real8 *) (*s_objet_argument_1).objet)) <= 0) { (*s_etat_processus).exception = d_ep_resultat_indefini; 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); return; } (*((real8 *) (*s_objet_resultat).objet)) = gsl_sf_bessel_Yn((int) ((*((integer8 *) (*s_objet_argument_2).objet))), (double) ((*((real8 *) (*s_objet_argument_1).objet)))); break; } case 'I' : { (*((real8 *) (*s_objet_resultat).objet)) = gsl_sf_bessel_In((int) ((*((integer8 *) (*s_objet_argument_2).objet))), (double) ((*((real8 *) (*s_objet_argument_1).objet)))); break; } case 'K' : { if ((*((real8 *) (*s_objet_argument_1).objet)) <= 0) { (*s_etat_processus).exception = d_ep_resultat_indefini; 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); return; } (*((real8 *) (*s_objet_resultat).objet)) = gsl_sf_bessel_Kn((int) ((*((integer8 *) (*s_objet_argument_2).objet))), (double) ((*((real8 *) (*s_objet_argument_1).objet)))); break; } case 'j' : { if (((*((integer8 *) (*s_objet_argument_1).objet)) < 0) || ((*((integer8 *) (*s_objet_argument_2).objet)) < 0)) { (*s_etat_processus).exception = d_ep_resultat_indefini; 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); return; } (*((real8 *) (*s_objet_resultat).objet)) = gsl_sf_bessel_jl((int) ((*((integer8 *) (*s_objet_argument_2).objet))), (double) ((*((real8 *) (*s_objet_argument_1).objet)))); break; } case 'y' : { if (((*((integer8 *) (*s_objet_argument_1).objet)) <= 0) || ((*((integer8 *) (*s_objet_argument_2).objet)) < 0)) { (*s_etat_processus).exception = d_ep_resultat_indefini; 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); return; } (*((real8 *) (*s_objet_resultat).objet)) = gsl_sf_bessel_yl((int) ((*((integer8 *) (*s_objet_argument_2).objet))), (double) ((*((real8 *) (*s_objet_argument_1).objet)))); break; } case 'i' : { if ((*((integer8 *) (*s_objet_argument_2).objet)) < 0) { (*s_etat_processus).exception = d_ep_resultat_indefini; 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); return; } (*((real8 *) (*s_objet_resultat).objet)) = exp(fabs((double) (*((real8 *) (*s_objet_argument_1).objet)))) * gsl_sf_bessel_il_scaled( (int) ((*((integer8 *) (*s_objet_argument_2).objet))), (double) ((*((real8 *) (*s_objet_argument_1).objet)))); break; } case 'k' : { if (((*((integer8 *) (*s_objet_argument_1).objet)) <= 0) || ((*((integer8 *) (*s_objet_argument_2).objet)) < 0)) { (*s_etat_processus).exception = d_ep_resultat_indefini; 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); return; } (*((real8 *) (*s_objet_resultat).objet)) = exp(fabs((double) (*((real8 *) (*s_objet_argument_1).objet)))) * gsl_sf_bessel_kl_scaled( (int) ((*((integer8 *) (*s_objet_argument_2).objet))), (double) ((*((real8 *) (*s_objet_argument_1).objet)))); break; } } } else if (((*s_objet_argument_1).type == NOM) || ((*s_objet_argument_1).type == RPN) || ((*s_objet_argument_1).type == ALG)) { creation_expression = d_vrai; } 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; } } else if ((*s_objet_argument_2).type == REL) { if ((*s_objet_argument_1).type == INT) { if ((s_objet_resultat = allocation(s_etat_processus, REL)) == NULL) { (*s_etat_processus).erreur_systeme = d_es_allocation_memoire; return; } switch((*((unsigned char *) (*s_objet_argument_3).objet))) { case 'J' : { if (((*((integer8 *) (*s_objet_argument_1).objet)) < 0) || ((*((real8 *) (*s_objet_argument_2).objet)) < 0)) { (*s_etat_processus).exception = d_ep_resultat_indefini; 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); return; } (*((real8 *) (*s_objet_resultat).objet)) = gsl_sf_bessel_Jnu((double) ((*((real8 *) (*s_objet_argument_2).objet))), (double) ((*((integer8 *) (*s_objet_argument_1).objet)))); break; } case 'Y' : { if (((*((integer8 *) (*s_objet_argument_1).objet)) <= 0) || ((*((real8 *) (*s_objet_argument_2).objet)) < 0)) { (*s_etat_processus).exception = d_ep_resultat_indefini; 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); return; } (*((real8 *) (*s_objet_resultat).objet)) = gsl_sf_bessel_Ynu((double) ((*((real8 *) (*s_objet_argument_2).objet))), (double) ((*((integer8 *) (*s_objet_argument_1).objet)))); break; } case 'I' : { if (((*((integer8 *) (*s_objet_argument_1).objet)) < 0) || ((*((real8 *) (*s_objet_argument_2).objet)) < 0)) { (*s_etat_processus).exception = d_ep_resultat_indefini; 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); return; } (*((real8 *) (*s_objet_resultat).objet)) = gsl_sf_bessel_Inu((double) ((*((real8 *) (*s_objet_argument_2).objet))), (double) ((*((integer8 *) (*s_objet_argument_1).objet)))); break; } case 'K' : { if (((*((integer8 *) (*s_objet_argument_1).objet)) <= 0) || ((*((real8 *) (*s_objet_argument_2).objet)) < 0)) { (*s_etat_processus).exception = d_ep_resultat_indefini; 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); return; } (*((real8 *) (*s_objet_resultat).objet)) = gsl_sf_bessel_Knu((double) ((*((real8 *) (*s_objet_argument_2).objet))), (double) ((*((integer8 *) (*s_objet_argument_1).objet)))); break; } default : { (*s_etat_processus).exception = d_ep_resultat_indefini; 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); return; break; } } } else if ((*s_objet_argument_1).type == REL) { if ((s_objet_resultat = allocation(s_etat_processus, REL)) == NULL) { (*s_etat_processus).erreur_systeme = d_es_allocation_memoire; return; } switch((*((unsigned char *) (*s_objet_argument_3).objet))) { case 'J' : { if (((*((real8 *) (*s_objet_argument_1).objet)) < 0) || ((*((real8 *) (*s_objet_argument_2).objet)) < 0)) { (*s_etat_processus).exception = d_ep_resultat_indefini; 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); return; } (*((real8 *) (*s_objet_resultat).objet)) = gsl_sf_bessel_Jnu((double) ((*((real8 *) (*s_objet_argument_2).objet))), (double) ((*((real8 *) (*s_objet_argument_1).objet)))); break; } case 'Y' : { if (((*((real8 *) (*s_objet_argument_1).objet)) <= 0) || ((*((real8 *) (*s_objet_argument_2).objet)) < 0)) { (*s_etat_processus).exception = d_ep_resultat_indefini; 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); return; } (*((real8 *) (*s_objet_resultat).objet)) = gsl_sf_bessel_Yn((double) ((*((real8 *) (*s_objet_argument_2).objet))), (double) ((*((real8 *) (*s_objet_argument_1).objet)))); break; } case 'I' : { if (((*((real8 *) (*s_objet_argument_1).objet)) < 0) || ((*((real8 *) (*s_objet_argument_2).objet)) < 0)) { (*s_etat_processus).exception = d_ep_resultat_indefini; 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); return; } (*((real8 *) (*s_objet_resultat).objet)) = gsl_sf_bessel_In((double) ((*((real8 *) (*s_objet_argument_2).objet))), (double) ((*((real8 *) (*s_objet_argument_1).objet)))); break; } case 'K' : { if (((*((real8 *) (*s_objet_argument_1).objet)) <= 0) || ((*((real8 *) (*s_objet_argument_2).objet)) < 0)) { (*s_etat_processus).exception = d_ep_resultat_indefini; 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); return; } (*((real8 *) (*s_objet_resultat).objet)) = gsl_sf_bessel_Kn((double) ((*((real8 *) (*s_objet_argument_2).objet))), (double) ((*((real8 *) (*s_objet_argument_1).objet)))); break; } default : { (*s_etat_processus).exception = d_ep_resultat_indefini; 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); return; break; } } } 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; } } else if (((*s_objet_argument_2).type == NOM) || ((*s_objet_argument_2).type == RPN) || ((*s_objet_argument_2).type == ALG)) { creation_expression = d_vrai; } 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; } } 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_argument_invalide; return; } } else if (((*s_objet_argument_3).type == NOM) || ((*s_objet_argument_3).type == RPN) || ((*s_objet_argument_3).type == ALG)) { creation_expression = d_vrai; } 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; } if (creation_expression == d_vrai) { if ((s_copie_argument_1 = copie_objet(s_etat_processus, s_objet_argument_1, 'N')) == NULL) { (*s_etat_processus).erreur_systeme = d_es_allocation_memoire; return; } if ((s_copie_argument_2 = copie_objet(s_etat_processus, s_objet_argument_2, 'N')) == NULL) { (*s_etat_processus).erreur_systeme = d_es_allocation_memoire; return; } if ((s_copie_argument_3 = copie_objet(s_etat_processus, s_objet_argument_3, 'N')) == NULL) { (*s_etat_processus).erreur_systeme = d_es_allocation_memoire; return; } if (((*s_copie_argument_1).type == RPN) || ((*s_copie_argument_2).type == RPN) || ((*s_copie_argument_3).type == RPN)) { if ((s_objet_resultat = allocation(s_etat_processus, RPN)) == NULL) { (*s_etat_processus).erreur_systeme = d_es_allocation_memoire; return; } } else { if ((s_objet_resultat = allocation(s_etat_processus, ALG)) == NULL) { (*s_etat_processus).erreur_systeme = d_es_allocation_memoire; return; } } if (((*s_objet_resultat).objet = allocation_maillon(s_etat_processus)) == NULL) { (*s_etat_processus).erreur_systeme = d_es_allocation_memoire; return; } l_element_courant = (*s_objet_resultat).objet; if (((*l_element_courant).donnee = allocation(s_etat_processus, FCT)) == NULL) { (*s_etat_processus).erreur_systeme = d_es_allocation_memoire; return; } (*((struct_fonction *) (*(*l_element_courant).donnee).objet)) .nombre_arguments = 0; (*((struct_fonction *) (*(*l_element_courant).donnee).objet)) .fonction = instruction_vers_niveau_superieur; if (((*((struct_fonction *) (*(*l_element_courant).donnee).objet)) .nom_fonction = malloc(3 * sizeof(unsigned char))) == NULL) { (*s_etat_processus).erreur_systeme = d_es_allocation_memoire; return; } strcpy((*((struct_fonction *) (*(*l_element_courant).donnee).objet)) .nom_fonction, "<<"); if (((*s_copie_argument_3).type == ALG) || ((*s_copie_argument_3).type == RPN)) { l_element_atome = (struct_liste_chainee *) (*s_copie_argument_3).objet; i = 0; while(l_element_atome != NULL) { i++; l_element_atome = (*l_element_atome).suivant; } if (i < 3) { if (((*l_element_courant).suivant = allocation_maillon(s_etat_processus)) == NULL) { (*s_etat_processus).erreur_systeme = d_es_allocation_memoire; return; } l_element_courant = (*l_element_courant).suivant; (*l_element_courant).donnee = s_copie_argument_3; } else { (*l_element_courant).suivant = (*((struct_liste_chainee *) (*s_copie_argument_3).objet)).suivant; l_element_precedent = NULL; l_element_courant = (*l_element_courant).suivant; liberation(s_etat_processus, (*((struct_liste_chainee *) (*s_copie_argument_3) .objet)).donnee); free((*s_copie_argument_3).objet); free(s_copie_argument_3); while((*l_element_courant).suivant != NULL) { l_element_precedent = l_element_courant; l_element_courant = (*l_element_courant).suivant; } liberation(s_etat_processus, (*l_element_courant).donnee); free(l_element_courant); l_element_courant = l_element_precedent; } } else { if (((*l_element_courant).suivant = allocation_maillon(s_etat_processus)) == NULL) { (*s_etat_processus).erreur_systeme = d_es_allocation_memoire; return; } l_element_courant = (*l_element_courant).suivant; (*l_element_courant).donnee = s_copie_argument_3; } if (((*s_copie_argument_2).type == ALG) || ((*s_copie_argument_2).type == RPN)) { l_element_atome = (struct_liste_chainee *) (*s_copie_argument_2).objet; i = 0; while(l_element_atome != NULL) { i++; l_element_atome = (*l_element_atome).suivant; } if (i < 3) { if (((*l_element_courant).suivant = allocation_maillon(s_etat_processus)) == NULL) { (*s_etat_processus).erreur_systeme = d_es_allocation_memoire; return; } l_element_courant = (*l_element_courant).suivant; (*l_element_courant).donnee = s_copie_argument_2; } else { (*l_element_courant).suivant = (*((struct_liste_chainee *) (*s_copie_argument_2).objet)).suivant; l_element_courant = (*l_element_courant).suivant; l_element_precedent = NULL; liberation(s_etat_processus, (*((struct_liste_chainee *) (*s_copie_argument_2) .objet)).donnee); free((*s_copie_argument_2).objet); free(s_copie_argument_2); while((*l_element_courant).suivant != NULL) { l_element_precedent = l_element_courant; l_element_courant = (*l_element_courant).suivant; } liberation(s_etat_processus, (*l_element_courant).donnee); free(l_element_courant); l_element_courant = l_element_precedent; } } else { if (((*l_element_courant).suivant = allocation_maillon(s_etat_processus)) == NULL) { (*s_etat_processus).erreur_systeme = d_es_allocation_memoire; return; } l_element_courant = (*l_element_courant).suivant; (*l_element_courant).donnee = s_copie_argument_2; } if (((*s_copie_argument_1).type == ALG) || ((*s_copie_argument_1).type == RPN)) { l_element_atome = (struct_liste_chainee *) (*s_copie_argument_1).objet; i = 0; while(l_element_atome != NULL) { i++; l_element_atome = (*l_element_atome).suivant; } if (i < 3) { if (((*l_element_courant).suivant = allocation_maillon(s_etat_processus)) == NULL) { (*s_etat_processus).erreur_systeme = d_es_allocation_memoire; return; } l_element_courant = (*l_element_courant).suivant; (*l_element_courant).donnee = s_copie_argument_1; } else { (*l_element_courant).suivant = (*((struct_liste_chainee *) (*s_copie_argument_1).objet)).suivant; l_element_courant = (*l_element_courant).suivant; l_element_precedent = NULL; liberation(s_etat_processus, (*((struct_liste_chainee *) (*s_copie_argument_1) .objet)).donnee); free((*s_copie_argument_1).objet); free(s_copie_argument_1); while((*l_element_courant).suivant != NULL) { l_element_precedent = l_element_courant; l_element_courant = (*l_element_courant).suivant; } liberation(s_etat_processus, (*l_element_courant).donnee); free(l_element_courant); l_element_courant = l_element_precedent; } } else { if (((*l_element_courant).suivant = allocation_maillon(s_etat_processus)) == NULL) { (*s_etat_processus).erreur_systeme = d_es_allocation_memoire; return; } l_element_courant = (*l_element_courant).suivant; (*l_element_courant).donnee = s_copie_argument_1; } if (((*l_element_courant).suivant = allocation_maillon(s_etat_processus)) == NULL) { (*s_etat_processus).erreur_systeme = d_es_allocation_memoire; return; } l_element_courant = (*l_element_courant).suivant; if (((*l_element_courant).donnee = allocation(s_etat_processus, FCT)) == NULL) { (*s_etat_processus).erreur_systeme = d_es_allocation_memoire; return; } (*((struct_fonction *) (*(*l_element_courant).donnee).objet)) .nombre_arguments = 3; (*((struct_fonction *) (*(*l_element_courant).donnee).objet)) .fonction = instruction_bessel; if (((*((struct_fonction *) (*(*l_element_courant).donnee).objet)) .nom_fonction = malloc(7 * sizeof(unsigned char))) == NULL) { (*s_etat_processus).erreur_systeme = d_es_allocation_memoire; return; } strcpy((*((struct_fonction *) (*(*l_element_courant).donnee).objet)) .nom_fonction, "BESSEL"); if (((*l_element_courant).suivant = allocation_maillon(s_etat_processus)) == NULL) { (*s_etat_processus).erreur_systeme = d_es_allocation_memoire; return; } l_element_courant = (*l_element_courant).suivant; if (((*l_element_courant).donnee = (struct_objet *) allocation(s_etat_processus, FCT)) == NULL) { (*s_etat_processus).erreur_systeme = d_es_allocation_memoire; return; } (*((struct_fonction *) (*(*l_element_courant).donnee).objet)) .nombre_arguments = 0; (*((struct_fonction *) (*(*l_element_courant).donnee).objet)) .fonction = instruction_vers_niveau_inferieur; if (((*((struct_fonction *) (*(*l_element_courant).donnee).objet)) .nom_fonction = malloc(3 * sizeof(unsigned char))) == NULL) { (*s_etat_processus).erreur_systeme = d_es_allocation_memoire; return; } strcpy((*((struct_fonction *) (*(*l_element_courant).donnee).objet)) .nom_fonction, ">>"); (*l_element_courant).suivant = NULL; } if (empilement(s_etat_processus, &((*s_etat_processus).l_base_pile), s_objet_resultat) == d_erreur) { 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); return; } /* ================================================================================ Fonction 'backtrace' ================================================================================ Entrées : -------------------------------------------------------------------------------- Sorties : -------------------------------------------------------------------------------- Effets de bord : néant ================================================================================ */ void instruction_backtrace(struct_processus *s_etat_processus) { (*s_etat_processus).erreur_execution = d_ex; if ((*s_etat_processus).affichage_arguments == 'Y') { printf("\n BACKTRACE "); if ((*s_etat_processus).langue == 'F') { printf("(affichage de la pile système)\n\n"); printf(" Aucun argument\n"); } else { printf("(print system stack)\n\n"); printf(" No argument\n"); } 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; } } trace(s_etat_processus, stdout); return; } // vim: ts=4