--- rpl/src/instructions_n1.c 2010/04/21 13:45:48 1.7 +++ rpl/src/instructions_n1.c 2012/12/18 13:19:37 1.41 @@ -1,7 +1,7 @@ /* ================================================================================ - RPL/2 (R) version 4.0.15 - Copyright (C) 1989-2010 Dr. BERTRAND Joël + RPL/2 (R) version 4.1.12 + Copyright (C) 1989-2012 Dr. BERTRAND Joël This file is part of RPL/2. @@ -20,18 +20,18 @@ */ -#include "rpl.conv.h" +#include "rpl-conv.h" /* ================================================================================ Fonction 'neg' ================================================================================ - Entrées : + Entrées : -------------------------------------------------------------------------------- Sorties : -------------------------------------------------------------------------------- - Effets de bord : néant + Effets de bord : néant ================================================================================ */ @@ -120,7 +120,7 @@ instruction_neg(struct_processus *s_etat } /* - * Permet d'éviter les résultats du type -0. Valable pour tous + * Permet d'éviter les résultats du type -0. Valable pour tous * les types... */ @@ -133,7 +133,7 @@ instruction_neg(struct_processus *s_etat /* -------------------------------------------------------------------------------- - Opposition d'un réel + Opposition d'un réel -------------------------------------------------------------------------------- */ @@ -217,7 +217,7 @@ instruction_neg(struct_processus *s_etat /* -------------------------------------------------------------------------------- - Opposition d'un vecteur de réels + Opposition d'un vecteur de réels -------------------------------------------------------------------------------- */ @@ -320,7 +320,7 @@ instruction_neg(struct_processus *s_etat /* -------------------------------------------------------------------------------- - Opposition d'une matrice de réels + Opposition d'une matrice de réels -------------------------------------------------------------------------------- */ @@ -641,11 +641,11 @@ instruction_neg(struct_processus *s_etat ================================================================================ Fonction 'not' ================================================================================ - Entrées : pointeur sur une struct_processus + Entrées : pointeur sur une struct_processus -------------------------------------------------------------------------------- Sorties : -------------------------------------------------------------------------------- - Effets de bord : néant + Effets de bord : néant ================================================================================ */ @@ -667,7 +667,7 @@ instruction_not(struct_processus *s_etat if ((*s_etat_processus).langue == 'F') { - printf("(complément)\n\n"); + printf("(complément)\n\n"); } else { @@ -756,11 +756,14 @@ instruction_not(struct_processus *s_etat else if ((*s_objet_argument).type == BIN) { - (*((logical8 *) (*s_objet_argument).objet)) = - ~(*((logical8 *) (*s_objet_argument).objet)); + if ((s_objet_resultat = allocation(s_etat_processus, BIN)) == NULL) + { + (*s_etat_processus).erreur_systeme = d_es_allocation_memoire; + return; + } - s_objet_resultat = s_objet_argument; - s_objet_argument = NULL; + (*((logical8 *) (*s_objet_resultat).objet)) = + ~(*((logical8 *) (*s_objet_argument).objet)); } /* @@ -975,11 +978,11 @@ instruction_not(struct_processus *s_etat ================================================================================ Fonction '<>' ================================================================================ - Entrées : + Entrées : -------------------------------------------------------------------------------- Sorties : -------------------------------------------------------------------------------- - Effets de bord : néant + Effets de bord : néant ================================================================================ */ @@ -1012,7 +1015,7 @@ instruction_ne(struct_processus *s_etat_ if ((*s_etat_processus).langue == 'F') { - printf("(opérateur différence)\n\n"); + printf("(opérateur différence)\n\n"); } else { @@ -1081,7 +1084,7 @@ instruction_ne(struct_processus *s_etat_ /* -------------------------------------------------------------------------------- - SAME NOT sur des valeurs numériques + SAME NOT sur des valeurs numériques -------------------------------------------------------------------------------- */ @@ -1179,7 +1182,7 @@ instruction_ne(struct_processus *s_etat_ /* -------------------------------------------------------------------------------- - SAME NOT portant sur des chaînes de caractères + SAME NOT portant sur des chaînes de caractères -------------------------------------------------------------------------------- */ @@ -1203,7 +1206,7 @@ instruction_ne(struct_processus *s_etat_ -------------------------------------------------------------------------------- */ /* - * Il y a de la récursivité dans l'air... + * Il y a de la récursivité dans l'air... */ else if ((((*s_objet_argument_1).type == LST) && @@ -1331,7 +1334,7 @@ instruction_ne(struct_processus *s_etat_ } /* - * Vecteurs de réels + * Vecteurs de réels */ else if (((*s_objet_argument_1).type == VRL) && @@ -1459,7 +1462,7 @@ instruction_ne(struct_processus *s_etat_ } /* - * Matrice de réels + * Matrice de réels */ else if (((*s_objet_argument_1).type == MRL) && @@ -1561,7 +1564,7 @@ instruction_ne(struct_processus *s_etat_ */ /* - * Nom ou valeur numérique / Nom ou valeur numérique + * Nom ou valeur numérique / Nom ou valeur numérique */ else if ((((*s_objet_argument_1).type == NOM) && @@ -1698,7 +1701,7 @@ instruction_ne(struct_processus *s_etat_ } /* - * Nom ou valeur numérique / Expression + * Nom ou valeur numérique / Expression */ else if (((((*s_objet_argument_1).type == ALG) || @@ -1790,7 +1793,7 @@ instruction_ne(struct_processus *s_etat_ } /* - * Expression / Nom ou valeur numérique + * Expression / Nom ou valeur numérique */ else if ((((*s_objet_argument_1).type == NOM) || @@ -2041,11 +2044,11 @@ instruction_ne(struct_processus *s_etat_ ================================================================================ Fonction 'next' ================================================================================ - Entrées : + Entrées : -------------------------------------------------------------------------------- Sorties : -------------------------------------------------------------------------------- - Effets de bord : néant + Effets de bord : néant ================================================================================ */ @@ -2055,6 +2058,7 @@ instruction_next(struct_processus *s_eta struct_objet *s_objet; struct_objet *s_copie_objet; + logical1 fin_boucle; logical1 presence_compteur; (*s_etat_processus).erreur_execution = d_ex; @@ -2065,7 +2069,7 @@ instruction_next(struct_processus *s_eta if ((*s_etat_processus).langue == 'F') { - printf("(fin d'une boucle définie)\n\n"); + printf("(fin d'une boucle définie)\n\n"); } else { @@ -2103,192 +2107,353 @@ instruction_next(struct_processus *s_eta return; } - presence_compteur = ((*(*s_etat_processus).l_base_pile_systeme) - .type_cloture == 'F') ? d_vrai : d_faux; + if ((*(*s_etat_processus).l_base_pile_systeme).type_cloture != 'A') + { // FOR ou START + presence_compteur = ((*(*s_etat_processus).l_base_pile_systeme) + .type_cloture == 'F') ? d_vrai : d_faux; - if (((*(*s_etat_processus).l_base_pile_systeme).type_cloture != 'S') - && (presence_compteur == d_faux)) - { - (*s_etat_processus).erreur_execution = d_ex_erreur_traitement_boucle; - return; - } + if (((*(*s_etat_processus).l_base_pile_systeme).type_cloture != 'S') + && (presence_compteur == d_faux)) + { + (*s_etat_processus).erreur_execution = + d_ex_erreur_traitement_boucle; + return; + } - /* - * Pour une boucle avec indice, on fait pointer - * (*(*s_etat_processus).l_base_pile_systeme).indice_boucle sur - * la variable correspondante. Remarque, le contenu de la variable - * est détruit au courant de l'opération. - */ + /* + * Pour une boucle avec indice, on fait pointer + * (*(*s_etat_processus).l_base_pile_systeme).indice_boucle sur + * la variable correspondante. Remarque, le contenu de la variable + * est détruit au courant de l'opération. + */ - if (presence_compteur == d_vrai) - { - if (recherche_variable(s_etat_processus, (*(*s_etat_processus) - .l_base_pile_systeme).nom_variable) == d_faux) + if (presence_compteur == d_vrai) { - (*s_etat_processus).erreur_execution = d_ex_variable_non_definie; - return; + if (recherche_variable(s_etat_processus, (*(*s_etat_processus) + .l_base_pile_systeme).nom_variable) == d_faux) + { + (*s_etat_processus).erreur_execution = + d_ex_variable_non_definie; + return; + } + + if ((*(*s_etat_processus).pointeur_variable_courante) + .variable_verrouillee == d_vrai) + { + (*s_etat_processus).erreur_execution = + d_ex_variable_verrouillee; + return; + } + + if ((*(*s_etat_processus).pointeur_variable_courante).objet == NULL) + { + (*s_etat_processus).erreur_execution = d_ex_variable_partagee; + return; + } + + (*(*s_etat_processus).l_base_pile_systeme).indice_boucle = + (*(*s_etat_processus).pointeur_variable_courante).objet; } - if (((*s_etat_processus).s_liste_variables[(*s_etat_processus) - .position_variable_courante]).variable_verrouillee == d_vrai) + /* + * Empilement pour calculer le nouvel indice. Au passage, la + * variable (*(*s_etat_processus).l_base_pile_systeme).indice_boucle + * est libérée. + */ + + if (empilement(s_etat_processus, &((*s_etat_processus).l_base_pile), + (*(*s_etat_processus).l_base_pile_systeme).indice_boucle) + == d_erreur) { - (*s_etat_processus).erreur_execution = d_ex_variable_verrouillee; return; } - if (((*s_etat_processus).s_liste_variables[(*s_etat_processus) - .position_variable_courante]).objet == NULL) + if ((s_objet = allocation(s_etat_processus, INT)) == NULL) { - (*s_etat_processus).erreur_execution = d_ex_variable_partagee; + (*s_etat_processus).erreur_systeme = d_es_allocation_memoire; return; } - (*(*s_etat_processus).l_base_pile_systeme).indice_boucle = - ((*s_etat_processus).s_liste_variables[(*s_etat_processus) - .position_variable_courante]).objet; - } - - /* - * Empilement pour calculer le nouvel indice. Au passage, la - * variable (*(*s_etat_processus).l_base_pile_systeme).indice_boucle - * est libérée. - */ - - if (empilement(s_etat_processus, &((*s_etat_processus).l_base_pile), - (*(*s_etat_processus).l_base_pile_systeme).indice_boucle) - == d_erreur) - { - return; - } + (*((integer8 *) (*s_objet).objet)) = 1; - if ((s_objet = allocation(s_etat_processus, INT)) == NULL) - { - (*s_etat_processus).erreur_systeme = d_es_allocation_memoire; - return; - } - - (*((integer8 *) (*s_objet).objet)) = 1; - - if (empilement(s_etat_processus, &((*s_etat_processus).l_base_pile), - s_objet) == d_erreur) - { - return; - } + if (empilement(s_etat_processus, &((*s_etat_processus).l_base_pile), + s_objet) == d_erreur) + { + return; + } - instruction_plus(s_etat_processus); + instruction_plus(s_etat_processus); - if (depilement(s_etat_processus, &((*s_etat_processus).l_base_pile), - &s_objet) == d_erreur) - { - liberation(s_etat_processus, s_objet); + if (depilement(s_etat_processus, &((*s_etat_processus).l_base_pile), + &s_objet) == d_erreur) + { + liberation(s_etat_processus, s_objet); - (*s_etat_processus).erreur_execution = d_ex_manque_argument; - return; - } + (*s_etat_processus).erreur_execution = d_ex_manque_argument; + return; + } - if (((*s_objet).type != INT) && - ((*s_objet).type != REL)) - { - liberation(s_etat_processus, s_objet); + if (((*s_objet).type != INT) && ((*s_objet).type != REL)) + { + liberation(s_etat_processus, s_objet); - (*s_etat_processus).erreur_execution = d_ex_erreur_traitement_boucle; - return; - } + (*s_etat_processus).erreur_execution = + d_ex_erreur_traitement_boucle; + return; + } - if (presence_compteur == d_vrai) - { - /* - * L'addition crée si besoin une copie de l'objet - */ + if (presence_compteur == d_vrai) + { + /* + * L'addition crée si besoin une copie de l'objet + */ - (*(*s_etat_processus).l_base_pile_systeme).indice_boucle = NULL; - ((*s_etat_processus).s_liste_variables[(*s_etat_processus) - .position_variable_courante]).objet = s_objet; - } - else - { - (*(*s_etat_processus).l_base_pile_systeme).indice_boucle = s_objet; - } + (*(*s_etat_processus).l_base_pile_systeme).indice_boucle = NULL; + (*(*s_etat_processus).pointeur_variable_courante).objet = s_objet; + } + else + { + (*(*s_etat_processus).l_base_pile_systeme).indice_boucle = s_objet; + } - if ((s_copie_objet = copie_objet(s_etat_processus, s_objet, 'P')) == NULL) - { - (*s_etat_processus).erreur_systeme = d_es_allocation_memoire; - return; - } + if ((s_copie_objet = copie_objet(s_etat_processus, s_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_copie_objet) == d_erreur) - { - return; - } + if (empilement(s_etat_processus, &((*s_etat_processus).l_base_pile), + s_copie_objet) == d_erreur) + { + return; + } - if ((s_copie_objet = copie_objet(s_etat_processus, - (*(*s_etat_processus).l_base_pile_systeme) - .limite_indice_boucle, 'P')) == NULL) - { - (*s_etat_processus).erreur_systeme = d_es_allocation_memoire; - return; - } + if ((s_copie_objet = copie_objet(s_etat_processus, + (*(*s_etat_processus).l_base_pile_systeme) + .limite_indice_boucle, 'P')) == NULL) + { + (*s_etat_processus).erreur_systeme = d_es_allocation_memoire; + return; + } - if (empilement(s_etat_processus, &((*s_etat_processus).l_base_pile), - s_copie_objet) == d_erreur) - { - return; - } + if (empilement(s_etat_processus, &((*s_etat_processus).l_base_pile), + s_copie_objet) == d_erreur) + { + return; + } - instruction_le(s_etat_processus); + instruction_le(s_etat_processus); - 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 (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) - { - liberation(s_etat_processus, s_objet); + if ((*s_objet).type != INT) + { + liberation(s_etat_processus, s_objet); - (*s_etat_processus).erreur_execution = d_ex_erreur_traitement_boucle; - return; - } + (*s_etat_processus).erreur_execution = + d_ex_erreur_traitement_boucle; + return; + } - if ((*((integer8 *) (*s_objet).objet)) != 0) - { - if ((*(*s_etat_processus).l_base_pile_systeme) - .origine_routine_evaluation == 'N') + if ((*((integer8 *) (*s_objet).objet)) != 0) { - (*s_etat_processus).position_courante = (*(*s_etat_processus) - .l_base_pile_systeme).adresse_retour; + if ((*(*s_etat_processus).l_base_pile_systeme) + .origine_routine_evaluation == 'N') + { + (*s_etat_processus).position_courante = (*(*s_etat_processus) + .l_base_pile_systeme).adresse_retour; + } + else + { + (*s_etat_processus).expression_courante = (*(*s_etat_processus) + .l_base_pile_systeme).pointeur_objet_retour; + } } else { - (*s_etat_processus).expression_courante = (*(*s_etat_processus) - .l_base_pile_systeme).pointeur_objet_retour; + depilement_pile_systeme(s_etat_processus); + + if ((*s_etat_processus).erreur_systeme != d_es) + { + return; + } + + if (presence_compteur == d_vrai) + { + (*s_etat_processus).niveau_courant--; + + if (retrait_variables_par_niveau(s_etat_processus) == d_erreur) + { + return; + } + } } + + liberation(s_etat_processus, s_objet); } else - { - depilement_pile_systeme(s_etat_processus); + { // FORALL + if ((*(*(*s_etat_processus).l_base_pile_systeme).limite_indice_boucle) + .type == NON) + { // L'objet initial était vide. + (*s_etat_processus).niveau_courant--; + depilement_pile_systeme(s_etat_processus); - if ((*s_etat_processus).erreur_systeme != d_es) - { + liberation(s_etat_processus, (*(*s_etat_processus) + .l_base_pile_systeme).limite_indice_boucle); return; } + else if ((*(*(*s_etat_processus).l_base_pile_systeme) + .limite_indice_boucle).type == LST) + { // FORALL sur une liste + if ((*((struct_liste_chainee *) (*(*(*s_etat_processus) + .l_base_pile_systeme).indice_boucle).objet)).suivant + != NULL) + { + if (recherche_variable(s_etat_processus, (*(*s_etat_processus) + .l_base_pile_systeme).nom_variable) == d_faux) + { + (*s_etat_processus).erreur_execution = + d_ex_variable_non_definie; + return; + } + + if ((*(*s_etat_processus).pointeur_variable_courante) + .variable_verrouillee == d_vrai) + { + (*s_etat_processus).erreur_execution = + d_ex_variable_verrouillee; + return; + } + + if ((*(*s_etat_processus).pointeur_variable_courante).objet + == NULL) + { + (*s_etat_processus).erreur_execution + = d_ex_variable_partagee; + return; + } + + (*(*(*s_etat_processus).l_base_pile_systeme).indice_boucle) + .objet = (*((struct_liste_chainee *) + (*(*(*s_etat_processus).l_base_pile_systeme) + .indice_boucle).objet)).suivant; + liberation(s_etat_processus, (*(*s_etat_processus) + .pointeur_variable_courante).objet); + + if (((*(*s_etat_processus).pointeur_variable_courante).objet + = copie_objet(s_etat_processus, + (*((struct_liste_chainee *) (*(*(*s_etat_processus) + .l_base_pile_systeme).indice_boucle).objet)).donnee, + 'P')) == NULL) + { + (*s_etat_processus).erreur_systeme + = d_es_allocation_memoire; + return; + } + + fin_boucle = d_faux; + } + else + { + fin_boucle = d_vrai; + } + } + else + { // FORALL sur une table + (*((integer8 *) (*(*(*s_etat_processus).l_base_pile_systeme) + .indice_boucle).objet))++; + + if ((*((integer8 *) (*(*(*s_etat_processus).l_base_pile_systeme) + .indice_boucle).objet)) < (integer8) (*((struct_tableau *) + (*(*(*s_etat_processus).l_base_pile_systeme) + .limite_indice_boucle).objet)).nombre_elements) + { + if (recherche_variable(s_etat_processus, (*(*s_etat_processus) + .l_base_pile_systeme).nom_variable) == d_faux) + { + (*s_etat_processus).erreur_execution = + d_ex_variable_non_definie; + return; + } - if (presence_compteur == d_vrai) + if ((*(*s_etat_processus).pointeur_variable_courante) + .variable_verrouillee == d_vrai) + { + (*s_etat_processus).erreur_execution = + d_ex_variable_verrouillee; + return; + } + + if ((*(*s_etat_processus).pointeur_variable_courante).objet + == NULL) + { + (*s_etat_processus).erreur_execution + = d_ex_variable_partagee; + return; + } + + liberation(s_etat_processus, (*(*s_etat_processus) + .pointeur_variable_courante).objet); + + if (((*(*s_etat_processus).pointeur_variable_courante).objet + = copie_objet(s_etat_processus, (*((struct_tableau *) + (*(*(*s_etat_processus).l_base_pile_systeme) + .limite_indice_boucle).objet)).elements[(*((integer8 *) + (*(*(*s_etat_processus).l_base_pile_systeme) + .indice_boucle).objet))], 'P')) == NULL) + { + (*s_etat_processus).erreur_systeme + = d_es_allocation_memoire; + return; + } + + fin_boucle = d_faux; + } + else + { + fin_boucle = d_vrai; + } + } + + if (fin_boucle == d_vrai) { + depilement_pile_systeme(s_etat_processus); + + if ((*s_etat_processus).erreur_systeme != d_es) + { + return; + } + (*s_etat_processus).niveau_courant--; - if (retrait_variable_par_niveau(s_etat_processus) == d_erreur) + if (retrait_variables_par_niveau(s_etat_processus) == d_erreur) { return; } } + else + { + if ((*(*s_etat_processus).l_base_pile_systeme) + .origine_routine_evaluation == 'N') + { + (*s_etat_processus).position_courante = (*(*s_etat_processus) + .l_base_pile_systeme).adresse_retour; + } + else + { + (*s_etat_processus).expression_courante = (*(*s_etat_processus) + .l_base_pile_systeme).pointeur_objet_retour; + } + } } - liberation(s_etat_processus, s_objet); - return; } @@ -2297,11 +2462,11 @@ instruction_next(struct_processus *s_eta ================================================================================ Fonction 'nrand' ================================================================================ - Entrées : structure processus + Entrées : structure processus ------------------------------------------------------------------------------- Sorties : -------------------------------------------------------------------------------- - Effets de bord : néant + Effets de bord : néant ================================================================================ */ @@ -2318,7 +2483,7 @@ instruction_nrand(struct_processus *s_et if ((*s_etat_processus).langue == 'F') { - printf("(valeur aléatoire gaussienne)\n\n"); + printf("(valeur aléatoire gaussienne)\n\n"); } else {