/* ================================================================================ RPL/2 (R) version 4.1.26 Copyright (C) 1989-2017 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 '->table' ================================================================================ Entrées : structure processus -------------------------------------------------------------------------------- Sorties : -------------------------------------------------------------------------------- Effets de bord : néant ================================================================================ */ void instruction_fleche_table(struct_processus *s_etat_processus) { struct_objet *s_objet; integer8 i; integer8 nombre_elements; (*s_etat_processus).erreur_execution = d_ex; if ((*s_etat_processus).affichage_arguments == 'Y') { printf("\n ->TABLE "); if ((*s_etat_processus).langue == 'F') { printf("(création d'une table)\n\n"); } else { printf("(create table)\n\n"); } printf(" n: %s, %s, %s, %s, %s, %s,\n" " %s, %s, %s, %s, %s,\n" " %s, %s, %s, %s, %s,\n" " %s, %s\n", d_INT, d_REL, d_CPL, d_VIN, d_VRL, d_VCX, d_MIN, d_MRL, d_MCX, d_TAB, d_BIN, d_NOM, d_CHN, d_LST, d_ALG, d_RPN, d_FCH, d_SLB); printf(" ...\n"); printf(" 2: %s, %s, %s, %s, %s, %s,\n" " %s, %s, %s, %s, %s,\n" " %s, %s, %s, %s, %s,\n" " %s, %s\n", d_INT, d_REL, d_CPL, d_VIN, d_VRL, d_VCX, d_MIN, d_MRL, d_MCX, d_TAB, d_BIN, d_NOM, d_CHN, d_LST, d_ALG, d_RPN, d_FCH, d_SLB); printf(" 1: %s\n", d_INT); printf("-> 1: %s\n", d_TAB); return; } else if ((*s_etat_processus).test_instruction == 'Y') { (*s_etat_processus).nombre_arguments = -1; return; } if (test_cfsf(s_etat_processus, 31) == d_vrai) { if (empilement_pile_last(s_etat_processus, 0) == d_erreur) { return; } } if ((*s_etat_processus).hauteur_pile_operationnelle == 0) { (*s_etat_processus).erreur_execution = d_ex_manque_argument; return; } if ((*(*(*s_etat_processus).l_base_pile).donnee).type != INT) { (*s_etat_processus).erreur_execution = d_ex_argument_invalide; return; } nombre_elements = (*((integer8 *) (*(*(*s_etat_processus).l_base_pile) .donnee).objet)); if (nombre_elements < 0) { /* -- Opération absurde autorisée sur le calculateur HP-28S ----------------------- */ (*s_etat_processus).erreur_execution = d_ex_argument_invalide; return; } if (nombre_elements >= (*s_etat_processus).hauteur_pile_operationnelle) { (*s_etat_processus).erreur_execution = d_ex_manque_argument; return; } if (test_cfsf(s_etat_processus, 31) == d_vrai) { if (empilement_pile_last(s_etat_processus, nombre_elements + 1) == d_erreur) { return; } } if (depilement(s_etat_processus, &((*s_etat_processus).l_base_pile), &s_objet) == d_erreur) { return; } liberation(s_etat_processus, s_objet); if ((s_objet = allocation(s_etat_processus, TBL)) == NULL) { (*s_etat_processus).erreur_systeme = d_es_allocation_memoire; return; } (*((struct_tableau *) (*s_objet).objet)).nombre_elements = nombre_elements; if (((*((struct_tableau *) (*s_objet).objet)).elements = malloc(((size_t) nombre_elements) * sizeof(struct_objet *))) == NULL) { (*s_etat_processus).erreur_systeme = d_es_allocation_memoire; return; } for(i = 0; i < nombre_elements; i++) { if (depilement(s_etat_processus, &((*s_etat_processus).l_base_pile), &((*((struct_tableau *) (*s_objet).objet)).elements [nombre_elements - (i + 1)])) == d_erreur) { return; } } if (empilement(s_etat_processus, &((*s_etat_processus).l_base_pile), s_objet) == d_erreur) { return; } return; } /* ================================================================================ Fonction '->diag' ================================================================================ Entrées : pointeur sur une structure struct_processus -------------------------------------------------------------------------------- Sorties : -------------------------------------------------------------------------------- Effets de bord : néant ================================================================================ */ void instruction_fleche_diag(struct_processus *s_etat_processus) { struct_objet *s_objet_argument; struct_objet *s_objet_resultat; integer8 i; integer8 j; (*s_etat_processus).erreur_execution = d_ex; if ((*s_etat_processus).affichage_arguments == 'Y') { printf("\n ->DIAG "); if ((*s_etat_processus).langue == 'F') { printf("(conversion d'un vecteur en matrice diaginale)\n\n"); } else { printf("(vector to diagonal matrix conversion)\n\n"); } printf("-> 1: %s, %s, %s\n", d_VIN, d_VRL, d_VCX); printf(" 1: %s, %s, %s\n", d_MIN, d_MRL, d_MCX); return; } else if ((*s_etat_processus).test_instruction == 'Y') { (*s_etat_processus).nombre_arguments = -1; return; } 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; } /* * Conversion d'un vecteur */ if ((*s_objet_argument).type == VIN) { if ((s_objet_resultat = allocation(s_etat_processus, MIN)) == NULL) { (*s_etat_processus).erreur_systeme = d_es_allocation_memoire; return; } (*((struct_matrice *) (*s_objet_resultat).objet)).nombre_lignes = (*((struct_vecteur *) (*s_objet_argument).objet)).taille; (*((struct_matrice *) (*s_objet_resultat).objet)).nombre_colonnes = (*((struct_vecteur *) (*s_objet_argument).objet)).taille; if (((*((struct_matrice *) (*s_objet_resultat).objet)).tableau = malloc(((size_t) (*((struct_matrice *) (*s_objet_resultat).objet)).nombre_lignes) * sizeof(integer8 *))) == NULL) { (*s_etat_processus).erreur_systeme = d_es_allocation_memoire; return; } for(i = 0; i < (*((struct_matrice *) (*s_objet_resultat).objet)) .nombre_lignes; i++) { if ((((integer8 **) (*((struct_matrice *) (*s_objet_resultat).objet)).tableau)[i] = malloc(((size_t) (*((struct_matrice *) (*s_objet_resultat).objet)).nombre_colonnes) * sizeof(integer8))) == NULL) { (*s_etat_processus).erreur_systeme = d_es_allocation_memoire; return; } for(j = 0; j < (*((struct_matrice *) (*s_objet_resultat).objet)) .nombre_colonnes; j++) { if (i != j) { ((integer8 **) (*((struct_matrice *) (*s_objet_resultat) .objet)).tableau)[i][j] = 0; } else { ((integer8 **) (*((struct_matrice *) (*s_objet_resultat) .objet)).tableau)[i][j] = ((integer8 *) (*((struct_vecteur *) (*s_objet_argument) .objet)).tableau)[i]; } } } } else if ((*s_objet_argument).type == VRL) { if ((s_objet_resultat = allocation(s_etat_processus, MRL)) == NULL) { (*s_etat_processus).erreur_systeme = d_es_allocation_memoire; return; } (*((struct_matrice *) (*s_objet_resultat).objet)).nombre_lignes = (*((struct_vecteur *) (*s_objet_argument).objet)).taille; (*((struct_matrice *) (*s_objet_resultat).objet)).nombre_colonnes = (*((struct_vecteur *) (*s_objet_argument).objet)).taille; if (((*((struct_matrice *) (*s_objet_resultat).objet)).tableau = malloc(((size_t) (*((struct_matrice *) (*s_objet_resultat) .objet)).nombre_lignes) * sizeof(real8 *))) == NULL) { (*s_etat_processus).erreur_systeme = d_es_allocation_memoire; return; } for(i = 0; i < (*((struct_matrice *) (*s_objet_resultat).objet)) .nombre_lignes; i++) { if ((((real8 **) (*((struct_matrice *) (*s_objet_resultat).objet)).tableau)[i] = malloc(((size_t) (*((struct_matrice *) (*s_objet_resultat).objet)).nombre_colonnes) * sizeof(real8))) == NULL) { (*s_etat_processus).erreur_systeme = d_es_allocation_memoire; return; } for(j = 0; j < (*((struct_matrice *) (*s_objet_resultat).objet)) .nombre_colonnes; j++) { if (i != j) { ((real8 **) (*((struct_matrice *) (*s_objet_resultat) .objet)).tableau)[i][j] = 0; } else { ((real8 **) (*((struct_matrice *) (*s_objet_resultat) .objet)).tableau)[i][j] = ((real8 *) (*((struct_vecteur *) (*s_objet_argument) .objet)).tableau)[i]; } } } } else if ((*s_objet_argument).type == VCX) { if ((s_objet_resultat = allocation(s_etat_processus, MCX)) == NULL) { (*s_etat_processus).erreur_systeme = d_es_allocation_memoire; return; } (*((struct_matrice *) (*s_objet_resultat).objet)).nombre_lignes = (*((struct_vecteur *) (*s_objet_argument).objet)).taille; (*((struct_matrice *) (*s_objet_resultat).objet)).nombre_colonnes = (*((struct_vecteur *) (*s_objet_argument).objet)).taille; if (((*((struct_matrice *) (*s_objet_resultat).objet)).tableau = malloc(((size_t) (*((struct_matrice *) (*s_objet_resultat) .objet)).nombre_lignes) * sizeof(complex16 *))) == NULL) { (*s_etat_processus).erreur_systeme = d_es_allocation_memoire; return; } for(i = 0; i < (*((struct_matrice *) (*s_objet_resultat).objet)) .nombre_lignes; i++) { if ((((complex16 **) (*((struct_matrice *) (*s_objet_resultat).objet)).tableau)[i] = malloc(((size_t) (*((struct_matrice *) (*s_objet_resultat).objet)).nombre_colonnes) * sizeof(complex16))) == NULL) { (*s_etat_processus).erreur_systeme = d_es_allocation_memoire; return; } for(j = 0; j < (*((struct_matrice *) (*s_objet_resultat).objet)) .nombre_colonnes; j++) { if (i != j) { ((complex16 **) (*((struct_matrice *) (*s_objet_resultat) .objet)).tableau)[i][j].partie_reelle = 0; ((complex16 **) (*((struct_matrice *) (*s_objet_resultat) .objet)).tableau)[i][j].partie_imaginaire = 0; } else { ((complex16 **) (*((struct_matrice *) (*s_objet_resultat) .objet)).tableau)[i][j] = ((complex16 *) (*((struct_vecteur *) (*s_objet_argument) .objet)).tableau)[i]; } } } } /* * Conversion impossible impossible */ else { liberation(s_etat_processus, s_objet_argument); (*s_etat_processus).erreur_execution = d_ex_erreur_type_argument; return; } liberation(s_etat_processus, s_objet_argument); if (empilement(s_etat_processus, &((*s_etat_processus).l_base_pile), s_objet_resultat) == d_erreur) { return; } return; } /* ================================================================================ Fonction 'forall' ================================================================================ Entrées : structure processus -------------------------------------------------------------------------------- Sorties : -------------------------------------------------------------------------------- Effets de bord : néant ================================================================================ */ void instruction_forall(struct_processus *s_etat_processus) { struct_objet *s_objet_1; struct_objet *s_objet_2; struct_variable s_variable; unsigned char instruction_valide; unsigned char *tampon; unsigned char test_instruction; (*s_etat_processus).erreur_execution = d_ex; if ((*s_etat_processus).affichage_arguments == 'Y') { printf("\n FORALL "); if ((*s_etat_processus).langue == 'F') { printf("(boucle définie sur un objet)\n\n"); } else { printf("(define a object-based loop)\n\n"); } if ((*s_etat_processus).langue == 'F') { printf(" Utilisation :\n\n"); } else { printf(" Usage:\n\n"); } printf(" %s FORALL (variable)\n", d_LST); printf(" (expression)\n"); printf(" [EXIT]/[CYCLE]\n"); printf(" ...\n"); printf(" NEXT\n\n"); printf(" %s FORALL (variable)\n", d_TAB); printf(" (expression)\n"); printf(" [EXIT]/[CYCLE]\n"); printf(" ...\n"); printf(" NEXT\n"); return; } else if ((*s_etat_processus).test_instruction == 'Y') { (*s_etat_processus).nombre_arguments = -1; return; } if ((*s_etat_processus).erreur_systeme != d_es) { 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_1) == d_erreur) { (*s_etat_processus).erreur_execution = d_ex_manque_argument; return; } if (((*s_objet_1).type != LST) && ((*s_objet_1).type != TBL)) { liberation(s_etat_processus, s_objet_1); (*s_etat_processus).erreur_execution = d_ex_erreur_traitement_boucle; return; } empilement_pile_systeme(s_etat_processus); if ((*s_etat_processus).erreur_systeme != d_es) { return; } if ((*s_etat_processus).mode_execution_programme == 'Y') { tampon = (*s_etat_processus).instruction_courante; test_instruction = (*s_etat_processus).test_instruction; instruction_valide = (*s_etat_processus).instruction_valide; (*s_etat_processus).test_instruction = 'Y'; if (recherche_instruction_suivante(s_etat_processus) == d_erreur) { return; } analyse(s_etat_processus, NULL); if ((*s_etat_processus).instruction_valide == 'Y') { liberation(s_etat_processus, s_objet_1); free((*s_etat_processus).instruction_courante); (*s_etat_processus).instruction_courante = tampon; (*s_etat_processus).instruction_valide = instruction_valide; (*s_etat_processus).test_instruction = test_instruction; depilement_pile_systeme(s_etat_processus); (*s_etat_processus).erreur_execution = d_ex_nom_reserve; return; } (*s_etat_processus).type_en_cours = NON; recherche_type(s_etat_processus); free((*s_etat_processus).instruction_courante); (*s_etat_processus).instruction_courante = tampon; (*s_etat_processus).instruction_valide = instruction_valide; (*s_etat_processus).test_instruction = test_instruction; if ((*s_etat_processus).erreur_execution != d_ex) { depilement_pile_systeme(s_etat_processus); liberation(s_etat_processus, s_objet_1); return; } if (depilement(s_etat_processus, &((*s_etat_processus).l_base_pile), &s_objet_2) == d_erreur) { liberation(s_etat_processus, s_objet_1); depilement_pile_systeme(s_etat_processus); (*s_etat_processus).erreur_execution = d_ex_manque_argument; return; } (*(*s_etat_processus).l_base_pile_systeme) .origine_routine_evaluation = 'N'; } else { if ((*s_etat_processus).expression_courante == NULL) { depilement_pile_systeme(s_etat_processus); (*s_etat_processus).erreur_execution = d_ex_manque_argument; return; } (*s_etat_processus).expression_courante = (*(*s_etat_processus) .expression_courante).suivant; if ((s_objet_2 = copie_objet(s_etat_processus, (*(*s_etat_processus).expression_courante) .donnee, 'P')) == NULL) { (*s_etat_processus).erreur_systeme = d_es_allocation_memoire; return; } (*(*s_etat_processus).l_base_pile_systeme) .origine_routine_evaluation = 'Y'; } if ((*s_objet_2).type != NOM) { liberation(s_etat_processus, s_objet_1); depilement_pile_systeme(s_etat_processus); (*s_etat_processus).erreur_execution = d_ex_erreur_traitement_boucle; return; } else if ((*((struct_nom *) (*s_objet_2).objet)).symbole == d_vrai) { liberation(s_etat_processus, s_objet_1); depilement_pile_systeme(s_etat_processus); (*s_etat_processus).erreur_execution = d_ex_erreur_traitement_boucle; return; } (*s_etat_processus).niveau_courant++; (*(*s_etat_processus).l_base_pile_systeme).type_cloture = 'A'; if ((s_variable.nom = malloc((strlen( (*((struct_nom *) (*s_objet_2).objet)).nom) + 1) * sizeof(unsigned char))) == NULL) { (*s_etat_processus).erreur_systeme = d_es_allocation_memoire; return; } strcpy(s_variable.nom, (*((struct_nom *) (*s_objet_2).objet)).nom); s_variable.niveau = (*s_etat_processus).niveau_courant; if ((*s_objet_1).type == LST) { if ((*s_objet_1).objet == NULL) { // La liste est vide. On doit sauter au NEXT correspondant. liberation(s_etat_processus, s_objet_1); liberation(s_etat_processus, s_objet_2); free(s_variable.nom); if (((*(*s_etat_processus).l_base_pile_systeme) .limite_indice_boucle = allocation(s_etat_processus, NON)) == NULL) { (*s_etat_processus).erreur_systeme = d_es_allocation_memoire; return; } instruction_cycle(s_etat_processus); return; } if ((s_variable.objet = copie_objet(s_etat_processus, (*((struct_liste_chainee *) (*s_objet_1).objet)).donnee, 'P')) == NULL) { (*s_etat_processus).erreur_systeme = d_es_allocation_memoire; return; } // Mémorisation de la position courante dans la liste if (((*(*s_etat_processus).l_base_pile_systeme).indice_boucle = allocation(s_etat_processus, NON)) == NULL) { (*s_etat_processus).erreur_systeme = d_es_allocation_memoire; return; } (*(*(*s_etat_processus).l_base_pile_systeme).indice_boucle).objet = (struct_objet *) (*s_objet_1).objet; } else { if ((*((struct_tableau *) (*s_objet_1).objet)).nombre_elements == 0) { // La table est vide, il convient de sauter au NEXT correspondant. liberation(s_etat_processus, s_objet_1); liberation(s_etat_processus, s_objet_2); free(s_variable.nom); if (((*(*s_etat_processus).l_base_pile_systeme) .limite_indice_boucle = allocation(s_etat_processus, NON)) == NULL) { (*s_etat_processus).erreur_systeme = d_es_allocation_memoire; return; } instruction_cycle(s_etat_processus); return; } if ((s_variable.objet = copie_objet(s_etat_processus, (*((struct_tableau *) (*s_objet_1).objet)).elements[0], 'P')) == NULL) { (*s_etat_processus).erreur_systeme = d_es_allocation_memoire; return; } // Création d'un objet de type entier contenant la position // de l'élément courant dans la table. if (((*(*s_etat_processus).l_base_pile_systeme).indice_boucle = allocation(s_etat_processus, INT)) == NULL) { (*s_etat_processus).erreur_systeme = d_es_allocation_memoire; return; } (*((integer8 *) (*(*(*s_etat_processus).l_base_pile_systeme) .indice_boucle).objet)) = 0; } if (creation_variable(s_etat_processus, &s_variable, 'V', 'P') == d_erreur) { return; } liberation(s_etat_processus, s_objet_2); (*(*s_etat_processus).l_base_pile_systeme).limite_indice_boucle = s_objet_1; if ((*s_etat_processus).mode_execution_programme == 'Y') { (*(*s_etat_processus).l_base_pile_systeme).adresse_retour = (*s_etat_processus).position_courante; } else { (*(*s_etat_processus).l_base_pile_systeme).pointeur_objet_retour = (*s_etat_processus).expression_courante; } if (((*(*s_etat_processus).l_base_pile_systeme).nom_variable = malloc((strlen(s_variable.nom) + 1) * sizeof(unsigned char))) == NULL) { (*s_etat_processus).erreur_systeme = d_es_allocation_memoire; return; } strcpy((*(*s_etat_processus).l_base_pile_systeme).nom_variable, s_variable.nom); return; } // vim: ts=4