File:  [local] / rpl / src / instructions_u1.c
Revision 1.72: download - view: text, annotated - select for diffs - revision graph
Fri Jan 10 11:15:49 2020 UTC (4 years, 2 months ago) by bertrand
Branches: MAIN
CVS tags: rpl-4_1_32, HEAD
Modification du copyright.

    1: /*
    2: ================================================================================
    3:   RPL/2 (R) version 4.1.32
    4:   Copyright (C) 1989-2020 Dr. BERTRAND Joël
    5: 
    6:   This file is part of RPL/2.
    7: 
    8:   RPL/2 is free software; you can redistribute it and/or modify it
    9:   under the terms of the CeCILL V2 License as published by the french
   10:   CEA, CNRS and INRIA.
   11:  
   12:   RPL/2 is distributed in the hope that it will be useful, but WITHOUT
   13:   ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
   14:   FITNESS FOR A PARTICULAR PURPOSE.  See the CeCILL V2 License
   15:   for more details.
   16:  
   17:   You should have received a copy of the CeCILL License
   18:   along with RPL/2. If not, write to info@cecill.info.
   19: ================================================================================
   20: */
   21: 
   22: 
   23: #include "rpl-conv.h"
   24: 
   25: 
   26: /*
   27: ================================================================================
   28:   Fonction 'until'
   29: ================================================================================
   30:   Entrées : pointeur sur une structure struct_processus
   31: --------------------------------------------------------------------------------
   32:   Sorties :
   33: --------------------------------------------------------------------------------
   34:   Effets de bord : néant
   35: ================================================================================
   36: */
   37: 
   38: void
   39: instruction_until(struct_processus *s_etat_processus)
   40: {
   41:     (*s_etat_processus).erreur_execution = d_ex;
   42: 
   43:     if ((*s_etat_processus).affichage_arguments == 'Y')
   44:     {
   45:         printf("\n  UNTIL ");
   46: 
   47:         if ((*s_etat_processus).langue == 'F')
   48:         {
   49:             printf("(structure de contrôle)\n\n");
   50:             printf("  Utilisation :\n\n");
   51:         }
   52:         else
   53:         {
   54:             printf("(control statement)\n\n");
   55:             printf("  Usage:\n\n");
   56:         }
   57: 
   58:         printf("    DO\n");
   59:         printf("        (expression 1)\n");
   60:         printf("        EXIT\n");
   61:         printf("        (expression 2)\n");
   62:         printf("    UNTIL\n");
   63:         printf("        (clause)\n");
   64:         printf("    END\n\n");
   65: 
   66:         printf("    DO\n");
   67:         printf("        (expression)\n");
   68:         printf("    UNTIL\n");
   69:         printf("        (clause)\n");
   70:         printf("    END\n");
   71: 
   72:         return;
   73:     }
   74:     else if ((*s_etat_processus).test_instruction == 'Y')
   75:     {
   76:         (*s_etat_processus).nombre_arguments = -1;
   77:         return;
   78:     }
   79: 
   80:     (*(*s_etat_processus).l_base_pile_systeme).clause = 'U';
   81: 
   82:     return;
   83: }
   84: 
   85: 
   86: /*
   87: ================================================================================
   88:   Fonction 'utpc'
   89: ================================================================================
   90:   Entrées : pointeur sur une structure struct_processus
   91: --------------------------------------------------------------------------------
   92:   Sorties :
   93: --------------------------------------------------------------------------------
   94:   Effets de bord : néant
   95: ================================================================================
   96: */
   97: 
   98: void
   99: instruction_utpc(struct_processus *s_etat_processus)
  100: {
  101:     integer8                    n;
  102: 
  103:     real8                       x;
  104: 
  105:     struct_objet                *s_objet_argument_1;
  106:     struct_objet                *s_objet_argument_2;
  107:     struct_objet                *s_objet_resultat;
  108: 
  109:     (*s_etat_processus).erreur_execution = d_ex;
  110: 
  111:     if ((*s_etat_processus).affichage_arguments == 'Y')
  112:     {
  113:         printf("\n  UTPC ");
  114: 
  115:         if ((*s_etat_processus).langue == 'F')
  116:         {
  117:             printf("(loi du Xhi carrée cumulé à droite)\n\n");
  118:         }
  119:         else
  120:         {
  121:             printf("(upper-tail probability chi-square distribution)\n\n");
  122:         }
  123: 
  124:         printf("    2: %s\n", d_INT);
  125:         printf("    1: %s, %s\n", d_INT, d_REL);
  126:         printf("->  1: %s\n", d_REL);
  127: 
  128:         return;
  129:     }
  130:     else if ((*s_etat_processus).test_instruction == 'Y')
  131:     {
  132:         (*s_etat_processus).nombre_arguments = 2;
  133:         return;
  134:     }
  135: 
  136:     if (test_cfsf(s_etat_processus, 31) == d_vrai)
  137:     {
  138:         if (empilement_pile_last(s_etat_processus, 2) == d_erreur)
  139:         {
  140:             return;
  141:         }
  142:     }
  143: 
  144:     if (depilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
  145:             &s_objet_argument_1) == d_erreur)
  146:     {
  147:         (*s_etat_processus).erreur_execution = d_ex_manque_argument;
  148:         return;
  149:     }
  150: 
  151:     if (depilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
  152:             &s_objet_argument_2) == d_erreur)
  153:     {
  154:         liberation(s_etat_processus, s_objet_argument_1);
  155: 
  156:         (*s_etat_processus).erreur_execution = d_ex_manque_argument;
  157:         return;
  158:     }
  159: 
  160:     if (((*s_objet_argument_2).type == INT) &&
  161:             (((*s_objet_argument_1).type == REL) ||
  162:             ((*s_objet_argument_1).type == INT)))
  163:     {
  164:         n = (integer4) (*((integer8 *) (*s_objet_argument_2).objet));
  165: 
  166:         if (n <= 0)
  167:         {
  168:             liberation(s_etat_processus, s_objet_argument_1);
  169:             liberation(s_etat_processus, s_objet_argument_2);
  170: 
  171:             (*s_etat_processus).erreur_execution = d_ex_argument_invalide;
  172:             return;
  173:         }
  174: 
  175:         if ((s_objet_resultat = allocation(s_etat_processus, REL))
  176:                 == NULL)
  177:         {
  178:             (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
  179:             return;
  180:         }
  181: 
  182:         if ((*s_objet_argument_1).type == INT)
  183:         {
  184:             x = (real8) (*((integer8 *) (*s_objet_argument_1).objet));
  185:         }
  186:         else
  187:         {
  188:             x = (*((real8 *) (*s_objet_argument_1).objet));
  189:         }
  190: 
  191:         if (x < 0)
  192:         {
  193:             (*((real8 *) (*s_objet_resultat).objet)) = 1;
  194:         }
  195:         else
  196:         {
  197:             f90x2cd(&x, &n, (real8 *) (*s_objet_resultat).objet);
  198:         }
  199:     }
  200:     else
  201:     {
  202:         liberation(s_etat_processus, s_objet_argument_1);
  203:         liberation(s_etat_processus, s_objet_argument_2);
  204: 
  205:         (*s_etat_processus).erreur_execution = d_ex_erreur_type_argument;
  206:         return;
  207:     }
  208: 
  209:     liberation(s_etat_processus, s_objet_argument_1);
  210:     liberation(s_etat_processus, s_objet_argument_2);
  211: 
  212:     if (empilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
  213:             s_objet_resultat) == d_erreur)
  214:     {
  215:         return;
  216:     }
  217: 
  218:     return;
  219: }
  220: 
  221: 
  222: /*
  223: ================================================================================
  224:   Fonction 'utpn'
  225: ================================================================================
  226:   Entrées : pointeur sur une structure struct_processus
  227: --------------------------------------------------------------------------------
  228:   Sorties :
  229: --------------------------------------------------------------------------------
  230:   Effets de bord : néant
  231: ================================================================================
  232: */
  233: 
  234: void
  235: instruction_utpn(struct_processus *s_etat_processus)
  236: {
  237:     real8                       moyenne;
  238:     real8                       variance;
  239:     real8                       x;
  240: 
  241:     struct_objet                *s_objet_argument_1;
  242:     struct_objet                *s_objet_argument_2;
  243:     struct_objet                *s_objet_argument_3;
  244:     struct_objet                *s_objet_resultat;
  245: 
  246:     (*s_etat_processus).erreur_execution = d_ex;
  247: 
  248:     if ((*s_etat_processus).affichage_arguments == 'Y')
  249:     {
  250:         printf("\n  UTPN ");
  251: 
  252:         if ((*s_etat_processus).langue == 'F')
  253:         {
  254:             printf("(loi normale cumulée à droite)\n\n");
  255:         }
  256:         else
  257:         {
  258:             printf("(upper-tail probability normal distribution)\n\n");
  259:         }
  260: 
  261:         printf("    3: %s, %s\n", d_INT, d_REL); 
  262:         printf("    2: %s, %s\n", d_INT, d_REL); 
  263:         printf("    1: %s, %s\n", d_INT, d_REL);
  264:         printf("->  1: %s\n", d_REL);
  265: 
  266:         return;
  267:     }
  268:     else if ((*s_etat_processus).test_instruction == 'Y')
  269:     {
  270:         (*s_etat_processus).nombre_arguments = 3;
  271:         return;
  272:     }
  273: 
  274:     if (test_cfsf(s_etat_processus, 31) == d_vrai)
  275:     {
  276:         if (empilement_pile_last(s_etat_processus, 3) == d_erreur)
  277:         {
  278:             return;
  279:         }
  280:     }
  281: 
  282:     if (depilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
  283:             &s_objet_argument_1) == d_erreur)
  284:     {
  285:         (*s_etat_processus).erreur_execution = d_ex_manque_argument;
  286:         return;
  287:     }
  288: 
  289:     if (depilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
  290:             &s_objet_argument_2) == d_erreur)
  291:     {
  292:         liberation(s_etat_processus, s_objet_argument_1);
  293: 
  294:         (*s_etat_processus).erreur_execution = d_ex_manque_argument;
  295:         return;
  296:     }
  297: 
  298:     if (depilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
  299:             &s_objet_argument_3) == d_erreur)
  300:     {
  301:         liberation(s_etat_processus, s_objet_argument_1);
  302:         liberation(s_etat_processus, s_objet_argument_2);
  303: 
  304:         (*s_etat_processus).erreur_execution = d_ex_manque_argument;
  305:         return;
  306:     }
  307: 
  308:     if ((((*s_objet_argument_1).type == INT) ||
  309:             ((*s_objet_argument_1).type == REL)) &&
  310:             (((*s_objet_argument_2).type == INT) ||
  311:             ((*s_objet_argument_2).type == REL)) &&
  312:             (((*s_objet_argument_3).type == INT) ||
  313:             ((*s_objet_argument_3).type == REL)))
  314:     {
  315:         if ((s_objet_resultat = allocation(s_etat_processus, REL))
  316:                 == NULL)
  317:         {
  318:             (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
  319:             return;
  320:         }
  321: 
  322:         if ((*s_objet_argument_1).type == INT)
  323:         {
  324:             x = (real8) (*((integer8 *) (*s_objet_argument_1).objet));
  325:         }
  326:         else
  327:         {
  328:             x = (*((real8 *) (*s_objet_argument_1).objet));
  329:         }
  330: 
  331:         if ((*s_objet_argument_3).type == INT)
  332:         {
  333:             moyenne = (real8) (*((integer8 *) (*s_objet_argument_3).objet));
  334:         }
  335:         else
  336:         {
  337:             moyenne = (*((real8 *) (*s_objet_argument_3).objet));
  338:         }
  339: 
  340:         if ((*s_objet_argument_2).type == INT)
  341:         {
  342:             variance = (real8) (*((integer8 *) (*s_objet_argument_2).objet));
  343:         }
  344:         else
  345:         {
  346:             variance = (*((real8 *) (*s_objet_argument_2).objet));
  347:         }
  348: 
  349: 
  350:         if (variance == 0)
  351:         {
  352:             (*((real8 *) (*s_objet_resultat).objet)) = 0;
  353:         }
  354:         else if (variance > 0)
  355:         {
  356:             f90gausscd(&x, &moyenne, &variance,
  357:                     (real8 *) (*s_objet_resultat).objet);
  358:         }
  359:         else
  360:         {
  361:             liberation(s_etat_processus, s_objet_argument_1);
  362:             liberation(s_etat_processus, s_objet_argument_2);
  363:             liberation(s_etat_processus, s_objet_argument_3);
  364:             liberation(s_etat_processus, s_objet_resultat);
  365: 
  366:             (*s_etat_processus).erreur_execution = d_ex_erreur_type_argument;
  367:             return;
  368:         }
  369:     }
  370:     else
  371:     {
  372:         liberation(s_etat_processus, s_objet_argument_1);
  373:         liberation(s_etat_processus, s_objet_argument_2);
  374:         liberation(s_etat_processus, s_objet_argument_3);
  375: 
  376:         (*s_etat_processus).erreur_execution = d_ex_erreur_type_argument;
  377:         return;
  378:     }
  379: 
  380:     liberation(s_etat_processus, s_objet_argument_1);
  381:     liberation(s_etat_processus, s_objet_argument_2);
  382:     liberation(s_etat_processus, s_objet_argument_3);
  383: 
  384:     if (empilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
  385:             s_objet_resultat) == d_erreur)
  386:     {
  387:         return;
  388:     }
  389: 
  390:     return;
  391: }
  392: 
  393: 
  394: /*
  395: ================================================================================
  396:   Fonction 'utpf'
  397: ================================================================================
  398:   Entrées : pointeur sur une structure struct_processus
  399: --------------------------------------------------------------------------------
  400:   Sorties :
  401: --------------------------------------------------------------------------------
  402:   Effets de bord : néant
  403: ================================================================================
  404: */
  405: 
  406: void
  407: instruction_utpf(struct_processus *s_etat_processus)
  408: {
  409:     integer8                    n1;
  410:     integer8                    n2;
  411: 
  412:     real8                       x;
  413: 
  414:     struct_objet                *s_objet_argument_1;
  415:     struct_objet                *s_objet_argument_2;
  416:     struct_objet                *s_objet_argument_3;
  417:     struct_objet                *s_objet_resultat;
  418: 
  419:     (*s_etat_processus).erreur_execution = d_ex;
  420: 
  421:     if ((*s_etat_processus).affichage_arguments == 'Y')
  422:     {
  423:         printf("\n  UTPF ");
  424: 
  425:         if ((*s_etat_processus).langue == 'F')
  426:         {
  427:             printf("(loi F cumulée à droite)\n\n");
  428:         }
  429:         else
  430:         {
  431:             printf("(upper-tail probability F distribution)\n\n");
  432:         }
  433: 
  434:         printf("    3: %s\n", d_INT); 
  435:         printf("    2: %s\n", d_INT); 
  436:         printf("    1: %s, %s\n", d_INT, d_REL);
  437:         printf("->  1: %s\n", d_REL);
  438: 
  439:         return;
  440:     }
  441:     else if ((*s_etat_processus).test_instruction == 'Y')
  442:     {
  443:         (*s_etat_processus).nombre_arguments = 3;
  444:         return;
  445:     }
  446: 
  447:     if (test_cfsf(s_etat_processus, 31) == d_vrai)
  448:     {
  449:         if (empilement_pile_last(s_etat_processus, 3) == d_erreur)
  450:         {
  451:             return;
  452:         }
  453:     }
  454: 
  455:     if (depilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
  456:             &s_objet_argument_1) == d_erreur)
  457:     {
  458:         (*s_etat_processus).erreur_execution = d_ex_manque_argument;
  459:         return;
  460:     }
  461: 
  462:     if (depilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
  463:             &s_objet_argument_2) == d_erreur)
  464:     {
  465:         liberation(s_etat_processus, s_objet_argument_1);
  466: 
  467:         (*s_etat_processus).erreur_execution = d_ex_manque_argument;
  468:         return;
  469:     }
  470: 
  471:     if (depilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
  472:             &s_objet_argument_3) == d_erreur)
  473:     {
  474:         liberation(s_etat_processus, s_objet_argument_1);
  475:         liberation(s_etat_processus, s_objet_argument_2);
  476: 
  477:         (*s_etat_processus).erreur_execution = d_ex_manque_argument;
  478:         return;
  479:     }
  480: 
  481:     if ((((*s_objet_argument_1).type == INT) ||
  482:             ((*s_objet_argument_1).type == REL)) &&
  483:             ((*s_objet_argument_2).type == INT) &&
  484:             ((*s_objet_argument_3).type == INT))
  485:     {
  486:         n1 = (integer4) (*((integer8 *) (*s_objet_argument_3).objet));
  487:         n2 = (integer4) (*((integer8 *) (*s_objet_argument_2).objet));
  488: 
  489:         if ((n1 <= 0) || (n2 <= 0))
  490:         {
  491:             liberation(s_etat_processus, s_objet_argument_1);
  492:             liberation(s_etat_processus, s_objet_argument_2);
  493:             liberation(s_etat_processus, s_objet_argument_3);
  494: 
  495:             (*s_etat_processus).erreur_execution = d_ex_argument_invalide;
  496:             return;
  497:         }
  498: 
  499:         if ((s_objet_resultat = allocation(s_etat_processus, REL))
  500:                 == NULL)
  501:         {
  502:             (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
  503:             return;
  504:         }
  505: 
  506:         if ((*s_objet_argument_1).type == INT)
  507:         {
  508:             x = (real8) (*((integer8 *) (*s_objet_argument_1).objet));
  509:         }
  510:         else
  511:         {
  512:             x = (*((real8 *) (*s_objet_argument_1).objet));
  513:         }
  514: 
  515:         if (x < 0)
  516:         {
  517:             (*((real8 *) (*s_objet_resultat).objet)) = 1;
  518:         }
  519:         else
  520:         {
  521:             f90fcd(&x, &n1, &n2, (real8 *) (*s_objet_resultat).objet);
  522:         }
  523:     }
  524:     else
  525:     {
  526:         liberation(s_etat_processus, s_objet_argument_1);
  527:         liberation(s_etat_processus, s_objet_argument_2);
  528:         liberation(s_etat_processus, s_objet_argument_3);
  529: 
  530:         (*s_etat_processus).erreur_execution = d_ex_erreur_type_argument;
  531:         return;
  532:     }
  533: 
  534:     liberation(s_etat_processus, s_objet_argument_1);
  535:     liberation(s_etat_processus, s_objet_argument_2);
  536:     liberation(s_etat_processus, s_objet_argument_3);
  537: 
  538:     if (empilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
  539:             s_objet_resultat) == d_erreur)
  540:     {
  541:         return;
  542:     }
  543: 
  544:     return;
  545: }
  546: 
  547: 
  548: /*
  549: ================================================================================
  550:   Fonction 'utpt'
  551: ================================================================================
  552:   Entrées : pointeur sur une structure struct_processus
  553: --------------------------------------------------------------------------------
  554:   Sorties :
  555: --------------------------------------------------------------------------------
  556:   Effets de bord : néant
  557: ================================================================================
  558: */
  559: 
  560: void
  561: instruction_utpt(struct_processus *s_etat_processus)
  562: {
  563:     integer8                    n;
  564: 
  565:     real8                       x;
  566: 
  567:     struct_objet                *s_objet_argument_1;
  568:     struct_objet                *s_objet_argument_2;
  569:     struct_objet                *s_objet_resultat;
  570: 
  571:     (*s_etat_processus).erreur_execution = d_ex;
  572: 
  573:     if ((*s_etat_processus).affichage_arguments == 'Y')
  574:     {
  575:         printf("\n  UTPT ");
  576: 
  577:         if ((*s_etat_processus).langue == 'F')
  578:         {
  579:             printf("(loi du t de Student cumulée à droite)\n\n");
  580:         }
  581:         else
  582:         {
  583:             printf("(upper-tail probability Student's t  distribution)\n\n");
  584:         }
  585: 
  586:         printf("    2: %s\n", d_INT); 
  587:         printf("    1: %s, %s\n", d_INT, d_REL);
  588:         printf("->  1: %s\n", d_REL);
  589: 
  590:         return;
  591:     }
  592:     else if ((*s_etat_processus).test_instruction == 'Y')
  593:     {
  594:         (*s_etat_processus).nombre_arguments = 2;
  595:         return;
  596:     }
  597: 
  598:     if (test_cfsf(s_etat_processus, 31) == d_vrai)
  599:     {
  600:         if (empilement_pile_last(s_etat_processus, 2) == d_erreur)
  601:         {
  602:             return;
  603:         }
  604:     }
  605: 
  606:     if (depilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
  607:             &s_objet_argument_1) == d_erreur)
  608:     {
  609:         (*s_etat_processus).erreur_execution = d_ex_manque_argument;
  610:         return;
  611:     }
  612: 
  613:     if (depilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
  614:             &s_objet_argument_2) == d_erreur)
  615:     {
  616:         liberation(s_etat_processus, s_objet_argument_1);
  617: 
  618:         (*s_etat_processus).erreur_execution = d_ex_manque_argument;
  619:         return;
  620:     }
  621: 
  622:     if (((*s_objet_argument_2).type == INT) &&
  623:             (((*s_objet_argument_1).type == REL) ||
  624:             ((*s_objet_argument_1).type == INT)))
  625:     {
  626:         n = (integer4) (*((integer8 *) (*s_objet_argument_2).objet));
  627: 
  628:         if (n <= 0)
  629:         {
  630:             liberation(s_etat_processus, s_objet_argument_1);
  631:             liberation(s_etat_processus, s_objet_argument_2);
  632: 
  633:             (*s_etat_processus).erreur_execution = d_ex_argument_invalide;
  634:             return;
  635:         }
  636: 
  637:         if ((s_objet_resultat = allocation(s_etat_processus, REL))
  638:                 == NULL)
  639:         {
  640:             (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
  641:             return;
  642:         }
  643: 
  644:         if ((*s_objet_argument_1).type == INT)
  645:         {
  646:             x = (real8) (*((integer8 *) (*s_objet_argument_1).objet));
  647:         }
  648:         else
  649:         {
  650:             x = (*((real8 *) (*s_objet_argument_1).objet));
  651:         }
  652: 
  653:         f90tcd(&x, &n, (real8 *) (*s_objet_resultat).objet);
  654:     }
  655:     else
  656:     {
  657:         liberation(s_etat_processus, s_objet_argument_1);
  658:         liberation(s_etat_processus, s_objet_argument_2);
  659: 
  660:         (*s_etat_processus).erreur_execution = d_ex_erreur_type_argument;
  661:         return;
  662:     }
  663: 
  664:     liberation(s_etat_processus, s_objet_argument_1);
  665:     liberation(s_etat_processus, s_objet_argument_2);
  666: 
  667:     if (empilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
  668:             s_objet_resultat) == d_erreur)
  669:     {
  670:         return;
  671:     }
  672: 
  673:     return;
  674: }
  675: 
  676: 
  677: /*
  678: ================================================================================
  679:   Fonction 'use'
  680: ================================================================================
  681:   Entrées : pointeur sur une structure struct_processus
  682: --------------------------------------------------------------------------------
  683:   Sorties :
  684: --------------------------------------------------------------------------------
  685:   Effets de bord : néant
  686: ================================================================================
  687: */
  688: 
  689: void
  690: instruction_use(struct_processus *s_etat_processus)
  691: {
  692:     logical1                        existence;
  693:     logical1                        ouverture;
  694: 
  695:     struct_objet                    *s_objet_argument;
  696:     struct_objet                    *s_objet_resultat;
  697: 
  698:     unsigned char                   *tampon;
  699: 
  700:     unsigned long                   unite;
  701: 
  702:     void                            *bibliotheque;
  703: 
  704:     (*s_etat_processus).erreur_execution = d_ex;
  705: 
  706:     if ((*s_etat_processus).affichage_arguments == 'Y')
  707:     {
  708:         printf("\n  USE ");
  709: 
  710:         if ((*s_etat_processus).langue == 'F')
  711:         {
  712:             printf("(insertion d'une bibliothèque dynamique)\n\n");
  713:             printf("Si le chemin ne commence pas par '/', la bibliothèque "
  714:                     "est recherchée\n");
  715:             printf("successivement dans le répertoire courant puis dans %s."
  716:                     "\n\n", d_exec_path);
  717:         }
  718:         else
  719:         {
  720:             printf("(insert a shared library)\n\n");
  721:             printf("If this path does not begin with '/', RPL/2 tries to find "
  722:                     "it in current\n");
  723:             printf("directory or %s in this order.\n\n", d_exec_path);
  724:         }
  725: 
  726:         printf("    1: %s\n", d_CHN);
  727:         printf("->  1: %s\n", d_SLB);
  728: 
  729:         return;
  730:     }
  731:     else if ((*s_etat_processus).test_instruction == 'Y')
  732:     {
  733:         (*s_etat_processus).nombre_arguments = -1;
  734:         return;
  735:     }
  736: 
  737:     if (test_cfsf(s_etat_processus, 31) == d_vrai)
  738:     {
  739:         if (empilement_pile_last(s_etat_processus, 1) == d_erreur)
  740:         {
  741:             return;
  742:         }
  743:     }
  744: 
  745:     if (depilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
  746:             &s_objet_argument) == d_erreur)
  747:     {
  748:         (*s_etat_processus).erreur_execution = d_ex_manque_argument;
  749:         return;
  750:     }
  751: 
  752:     if ((*s_objet_argument).type == CHN)
  753:     {
  754:         /*
  755:          * Si le nom commence par un '/', il est traité comme un chemin
  756:          * absolu. Dans le cas contraire, on essaye successivement
  757:          * './' puis le répertoire lib de l'installation du langage.
  758:          */
  759: 
  760:         if (((unsigned char *) (*s_objet_argument).objet)[0] != '/')
  761:         {
  762:             if ((tampon = malloc((strlen((unsigned char *) (*s_objet_argument)
  763:                     .objet) + 3) * sizeof(unsigned char))) == NULL)
  764:             {
  765:                 (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
  766:                 return;
  767:             }
  768: 
  769:             sprintf(tampon, "./%s", (unsigned char *)
  770:                     (*s_objet_argument).objet);
  771: 
  772:             caracteristiques_fichier(s_etat_processus, tampon,
  773:                     &existence, &ouverture, &unite);
  774: 
  775:             if (existence != d_faux)
  776:             {
  777:                 free((unsigned char *) (*s_objet_argument).objet);
  778:                 (*s_objet_argument).objet = tampon;
  779:             }
  780:             else
  781:             {
  782:                 free(tampon);
  783: 
  784:                 if ((*s_etat_processus).rpl_home == NULL)
  785:                 {
  786:                     if ((tampon = malloc((strlen((unsigned char *)
  787:                             (*s_objet_argument).objet) + strlen(d_exec_path)
  788:                             + 7) * sizeof(unsigned char))) == NULL)
  789:                     {
  790:                         (*s_etat_processus).erreur_systeme =
  791:                                 d_es_allocation_memoire;
  792:                         return;
  793:                     }
  794: 
  795:                     sprintf(tampon, "/%s/lib/%s", d_exec_path, (unsigned char *)
  796:                             (*s_objet_argument).objet);
  797:                 }
  798:                 else
  799:                 {
  800:                     if ((tampon = malloc((strlen((unsigned char *)
  801:                             (*s_objet_argument).objet) +
  802:                             strlen((*s_etat_processus).rpl_home)
  803:                             + 7) * sizeof(unsigned char))) == NULL)
  804:                     {
  805:                         (*s_etat_processus).erreur_systeme =
  806:                                 d_es_allocation_memoire;
  807:                         return;
  808:                     }
  809: 
  810:                     sprintf(tampon, "/%s/lib/%s", (*s_etat_processus).rpl_home,
  811:                             (unsigned char *) (*s_objet_argument).objet);
  812:                 }
  813: 
  814:                 // Si la chaîne commence par '//', on supprime un '/'.
  815:                 // tampon[1] existe toujours.
  816: 
  817:                 if (tampon[1] == '/')
  818:                 {
  819:                     memmove(tampon, tampon + 1, strlen(tampon));
  820:                 }
  821: 
  822:                 caracteristiques_fichier(s_etat_processus, tampon,
  823:                         &existence, &ouverture, &unite);
  824: 
  825:                 if (existence != d_faux)
  826:                 {
  827:                     free((unsigned char *) (*s_objet_argument).objet);
  828:                     (*s_objet_argument).objet = tampon;
  829:                 }
  830:                 else
  831:                 {
  832:                     free(tampon);
  833:                 }
  834:             }
  835:         }
  836: 
  837:         if ((bibliotheque = chargement_bibliotheque(s_etat_processus,
  838:                 (unsigned char *) (*s_objet_argument).objet)) == NULL)
  839:         {
  840:             liberation(s_etat_processus, s_objet_argument);
  841:             return;
  842:         }
  843: 
  844:         if ((s_objet_resultat = allocation(s_etat_processus, SLB)) == NULL)
  845:         {
  846:             (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
  847:             return;
  848:         }
  849: 
  850:         (*((struct_bibliotheque *) (*s_objet_resultat).objet)).descripteur =
  851:                 bibliotheque;
  852:         (*((struct_bibliotheque *) (*s_objet_resultat).objet)).pid = getpid();
  853:         (*((struct_bibliotheque *) (*s_objet_resultat).objet)).tid =
  854:                 pthread_self();
  855: 
  856:         if (((*((struct_bibliotheque *) (*s_objet_resultat).objet)).nom =
  857:                 malloc((strlen((unsigned char *) (*s_objet_argument).objet)
  858:                 + 1) * sizeof(unsigned char))) == NULL)
  859:         {
  860:             (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
  861:             return;
  862:         }
  863: 
  864:         strcpy((*((struct_bibliotheque *) (*s_objet_resultat).objet)).nom,
  865:                 (unsigned char *) (*s_objet_argument).objet);
  866: 
  867:         liberation(s_etat_processus, s_objet_argument);
  868:     }
  869:     else
  870:     {
  871:         liberation(s_etat_processus, s_objet_argument);
  872: 
  873:         (*s_etat_processus).erreur_execution = d_ex_erreur_type_argument;
  874:         return;
  875:     }
  876: 
  877:     if (empilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
  878:             s_objet_resultat) == d_erreur)
  879:     {
  880:         return;
  881:     }
  882: 
  883:     return;
  884: }
  885: 
  886: 
  887: /*
  888: ================================================================================
  889:   Fonction 'uchol'
  890: ================================================================================
  891:   Entrées : pointeur sur une structure struct_processus
  892: --------------------------------------------------------------------------------
  893:   Sorties :
  894: --------------------------------------------------------------------------------
  895:   Effets de bord : néant
  896: ================================================================================
  897: */
  898: 
  899: void
  900: instruction_uchol(struct_processus *s_etat_processus)
  901: {
  902:     struct_objet                *s_copie_objet;
  903:     struct_objet                *s_objet;
  904: 
  905:     (*s_etat_processus).erreur_execution = d_ex;
  906: 
  907:     if ((*s_etat_processus).affichage_arguments == 'Y')
  908:     {
  909:         printf("\n  UCHOL ");
  910:         
  911:         if ((*s_etat_processus).langue == 'F')
  912:         {
  913:             printf("(décomposition de Cholevski à droite)\n\n");
  914:         }
  915:         else
  916:         {
  917:             printf("(right Cholevski decomposition)\n\n");
  918:         }
  919: 
  920:         printf("    1: %s, %s\n", d_MIN, d_MRL);
  921:         printf("->  1: %s\n\n", d_MRL);
  922: 
  923:         printf("    1: %s\n", d_MCX);
  924:         printf("->  1: %s\n", d_MCX);
  925: 
  926:         return;
  927:     }
  928:     else if ((*s_etat_processus).test_instruction == 'Y')
  929:     {
  930:         (*s_etat_processus).nombre_arguments = -1;
  931:         return;
  932:     }
  933: 
  934:     if (test_cfsf(s_etat_processus, 31) == d_vrai)
  935:     {
  936:         if (empilement_pile_last(s_etat_processus, 1) == d_erreur)
  937:         {
  938:             return;
  939:         }
  940:     }
  941: 
  942:     if (depilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
  943:             &s_objet) == d_erreur)
  944:     {
  945:         (*s_etat_processus).erreur_execution = d_ex_manque_argument;
  946:         return;
  947:     }
  948: 
  949: 
  950: /*
  951: --------------------------------------------------------------------------------
  952:   Résultat sous la forme de matrices réelles
  953: --------------------------------------------------------------------------------
  954: */
  955: 
  956:     if (((*s_objet).type == MIN) ||
  957:             ((*s_objet).type == MRL))
  958:     {
  959:         if ((*((struct_matrice *) (*s_objet).objet)).nombre_lignes !=
  960:                 (*((struct_matrice *) (*s_objet).objet)).nombre_colonnes)
  961:         {
  962:             liberation(s_etat_processus, s_objet);
  963: 
  964:             (*s_etat_processus).erreur_execution = d_ex_dimensions_invalides;
  965:             return;
  966:         }
  967: 
  968:         if ((s_copie_objet = copie_objet(s_etat_processus, s_objet, 'Q'))
  969:                 == NULL)
  970:         {
  971:             (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
  972:             return;
  973:         }
  974: 
  975:         liberation(s_etat_processus, s_objet);
  976:         s_objet = s_copie_objet;
  977: 
  978:         factorisation_cholesky(s_etat_processus, (*s_objet).objet, 'U');
  979:         (*s_objet).type = MRL;
  980: 
  981:         if ((*s_etat_processus).erreur_systeme != d_es)
  982:         {
  983:             return;
  984:         }
  985: 
  986:         if (((*s_etat_processus).exception != d_ep) ||
  987:                 ((*s_etat_processus).erreur_execution != d_ex))
  988:         {
  989:             if ((*s_etat_processus).exception == d_ep_domaine_definition)
  990:             {
  991:                 (*s_etat_processus).exception =
  992:                         d_ep_matrice_non_definie_positive;
  993:             }
  994: 
  995:             liberation(s_etat_processus, s_objet);
  996:             return;
  997:         }
  998:     }
  999: 
 1000: /*
 1001: --------------------------------------------------------------------------------
 1002:   Résultat sous la forme de matrices complexes
 1003: --------------------------------------------------------------------------------
 1004: */
 1005: 
 1006:     else if ((*s_objet).type == MCX)
 1007:     {
 1008:         if ((*((struct_matrice *) (*s_objet).objet)).nombre_lignes !=
 1009:                 (*((struct_matrice *) (*s_objet).objet)).nombre_colonnes)
 1010:         {
 1011:             liberation(s_etat_processus, s_objet);
 1012: 
 1013:             (*s_etat_processus).erreur_execution = d_ex_dimensions_invalides;
 1014:             return;
 1015:         }
 1016: 
 1017:         if ((s_copie_objet = copie_objet(s_etat_processus, s_objet, 'Q'))
 1018:                 == NULL)
 1019:         {
 1020:             (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
 1021:             return;
 1022:         }
 1023: 
 1024:         liberation(s_etat_processus, s_objet);
 1025:         s_objet = s_copie_objet;
 1026: 
 1027:         factorisation_cholesky(s_etat_processus, (*s_objet).objet, 'U');
 1028: 
 1029:         if ((*s_etat_processus).erreur_systeme != d_es)
 1030:         {
 1031:             return;
 1032:         }
 1033: 
 1034:         if (((*s_etat_processus).exception != d_ep) ||
 1035:                 ((*s_etat_processus).erreur_execution != d_ex))
 1036:         {
 1037:             if ((*s_etat_processus).exception == d_ep_domaine_definition)
 1038:             {
 1039:                 (*s_etat_processus).exception =
 1040:                         d_ep_matrice_non_definie_positive;
 1041:             }
 1042: 
 1043:             liberation(s_etat_processus, s_objet);
 1044:             return;
 1045:         }
 1046:     }
 1047: 
 1048: /*
 1049: --------------------------------------------------------------------------------
 1050:   Type d'argument invalide
 1051: --------------------------------------------------------------------------------
 1052: */
 1053: 
 1054:     else
 1055:     {
 1056:         liberation(s_etat_processus, s_objet);
 1057: 
 1058:         (*s_etat_processus).erreur_execution = d_ex_erreur_type_argument;
 1059:         return;
 1060:     }
 1061: 
 1062:     if (empilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
 1063:             s_objet) == d_erreur)
 1064:     {
 1065:         return;
 1066:     }
 1067: 
 1068:     return;
 1069: }
 1070: 
 1071: 
 1072: /*
 1073: ================================================================================
 1074:   Fonction 'unlock'
 1075: ================================================================================
 1076:   Entrées : pointeur sur une structure struct_processus
 1077: --------------------------------------------------------------------------------
 1078:   Sorties :
 1079: --------------------------------------------------------------------------------
 1080:   Effets de bord : néant
 1081: ================================================================================
 1082: */
 1083: 
 1084: void
 1085: instruction_unlock(struct_processus *s_etat_processus)
 1086: {
 1087:     struct flock                lock;
 1088: 
 1089:     struct_descripteur_fichier  *descripteur;
 1090: 
 1091:     struct_objet                *s_objet;
 1092: 
 1093:     (*s_etat_processus).erreur_execution = d_ex;
 1094: 
 1095:     if ((*s_etat_processus).affichage_arguments == 'Y')
 1096:     {
 1097:         printf("\n  UNLOCK ");
 1098:         
 1099:         if ((*s_etat_processus).langue == 'F')
 1100:         {
 1101:             printf("(déverrouillage d'un fichier)\n\n");
 1102:         }
 1103:         else
 1104:         {
 1105:             printf("(file unlock)\n\n");
 1106:         }
 1107: 
 1108:         printf("    1: %s\n", d_FCH);
 1109: 
 1110:         return;
 1111:     }
 1112:     else if ((*s_etat_processus).test_instruction == 'Y')
 1113:     {
 1114:         (*s_etat_processus).nombre_arguments = -1;
 1115:         return;
 1116:     }
 1117: 
 1118:     if (test_cfsf(s_etat_processus, 31) == d_vrai)
 1119:     {
 1120:         if (empilement_pile_last(s_etat_processus, 1) == d_erreur)
 1121:         {
 1122:             return;
 1123:         }
 1124:     }
 1125: 
 1126:     if (depilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
 1127:             &s_objet) == d_erreur)
 1128:     {
 1129:         (*s_etat_processus).erreur_execution = d_ex_manque_argument;
 1130:         return;
 1131:     }
 1132: 
 1133:     if ((*s_objet).type == FCH)
 1134:     {
 1135:         lock.l_type = F_UNLCK;
 1136:         lock.l_whence = SEEK_SET;
 1137:         lock.l_start = 0;
 1138:         lock.l_len = 0;
 1139:         lock.l_pid = getpid();
 1140: 
 1141:         if ((descripteur = descripteur_fichier(s_etat_processus,
 1142:                 (struct_fichier *) (*s_objet).objet)) == NULL)
 1143:         {
 1144:             return;
 1145:         }
 1146: 
 1147:         if (fcntl(fileno((*descripteur).descripteur_c), F_SETLK, &lock)
 1148:                 == -1)
 1149:         {
 1150:             liberation(s_etat_processus, s_objet);
 1151: 
 1152:             (*s_etat_processus).erreur_execution = d_ex_fichier_verrouille;
 1153:             return;
 1154:         }
 1155:     }
 1156:     else
 1157:     {
 1158:         liberation(s_etat_processus, s_objet);
 1159: 
 1160:         (*s_etat_processus).erreur_execution = d_ex_erreur_type_argument;
 1161:         return;
 1162:     }
 1163: 
 1164:     return;
 1165: }
 1166: 
 1167: 
 1168: /*
 1169: ================================================================================
 1170:   Fonction 'unprotect'
 1171: ================================================================================
 1172:   Entrées :
 1173: --------------------------------------------------------------------------------
 1174:   Sorties :
 1175: --------------------------------------------------------------------------------
 1176:   Effets de bord : néant
 1177: ================================================================================
 1178: */
 1179: 
 1180: void
 1181: instruction_unprotect(struct_processus *s_etat_processus)
 1182: {
 1183:     struct_liste_chainee                *l_element_courant;
 1184: 
 1185:     struct_objet                        *s_objet;
 1186: 
 1187:     (*s_etat_processus).erreur_execution = d_ex;
 1188: 
 1189:     if ((*s_etat_processus).affichage_arguments == 'Y')
 1190:     {
 1191:         printf("\n  UNPROTECT ");
 1192: 
 1193:         if ((*s_etat_processus).langue == 'F')
 1194:         {
 1195:             printf("(déverrouille une variable)\n\n");
 1196:         }
 1197:         else
 1198:         {
 1199:             printf("(unlock a variable)\n\n");
 1200:         }
 1201: 
 1202:         printf("    1: %s, %s\n", d_NOM, d_LST);
 1203: 
 1204:         return;
 1205:     }
 1206:     else if ((*s_etat_processus).test_instruction == 'Y')
 1207:     {
 1208:         (*s_etat_processus).nombre_arguments = -1;
 1209:         return;
 1210:     }
 1211:     
 1212:     if (test_cfsf(s_etat_processus, 31) == d_vrai)
 1213:     {
 1214:         if (empilement_pile_last(s_etat_processus, 1) == d_erreur)
 1215:         {
 1216:             return;
 1217:         }
 1218:     }
 1219: 
 1220:     if (depilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
 1221:             &s_objet) == d_erreur)
 1222:     {
 1223:         (*s_etat_processus).erreur_execution = d_ex_manque_argument;
 1224:         return;
 1225:     }
 1226: 
 1227:     if ((*s_objet).type == NOM)
 1228:     {
 1229:         if (recherche_variable(s_etat_processus, ((*((struct_nom *)
 1230:                 (*s_objet).objet)).nom)) == d_faux)
 1231:         {
 1232:             liberation(s_etat_processus, s_objet);
 1233: 
 1234:             (*s_etat_processus).erreur_systeme = d_es;
 1235:             (*s_etat_processus).erreur_execution = d_ex_variable_non_definie;
 1236:             return;
 1237:         }
 1238: 
 1239:         (*(*s_etat_processus).pointeur_variable_courante)
 1240:                 .variable_verrouillee = d_faux;
 1241:     }
 1242:     else if ((*s_objet).type == LST)
 1243:     {
 1244:         l_element_courant = (struct_liste_chainee *) (*s_objet).objet;
 1245: 
 1246:         while(l_element_courant != NULL)
 1247:         {
 1248:             if ((*(*l_element_courant).donnee).type != NOM)
 1249:             {
 1250:                 liberation(s_etat_processus, s_objet);
 1251: 
 1252:                 (*s_etat_processus).erreur_execution = d_ex_nom_invalide;
 1253:                 return;
 1254:             }
 1255: 
 1256:             if (recherche_variable(s_etat_processus, (*((struct_nom *)
 1257:                     (*(*l_element_courant).donnee).objet)).nom) == d_faux)
 1258:             {
 1259:                 liberation(s_etat_processus, s_objet);
 1260: 
 1261:                 (*s_etat_processus).erreur_systeme = d_es;
 1262:                 (*s_etat_processus).erreur_execution =
 1263:                         d_ex_variable_non_definie;
 1264:                 return;
 1265:             }
 1266: 
 1267:             (*(*s_etat_processus).pointeur_variable_courante)
 1268:                     .variable_verrouillee = d_faux;
 1269: 
 1270:             l_element_courant = (*l_element_courant).suivant;
 1271:         }
 1272:     }
 1273:     else
 1274:     {
 1275:         liberation(s_etat_processus, s_objet);
 1276: 
 1277:         (*s_etat_processus).erreur_execution = d_ex_nom_invalide;
 1278:         return;
 1279:     }
 1280: 
 1281:     liberation(s_etat_processus, s_objet);
 1282: 
 1283:     return;
 1284: }
 1285: 
 1286: 
 1287: /*
 1288: ================================================================================
 1289:   Fonction 'ucase'
 1290: ================================================================================
 1291:   Entrées : pointeur sur une structure struct_processus
 1292: --------------------------------------------------------------------------------
 1293:   Sorties :
 1294: --------------------------------------------------------------------------------
 1295:   Effets de bord : néant
 1296: ================================================================================
 1297: */
 1298: 
 1299: void
 1300: instruction_ucase(struct_processus *s_etat_processus)
 1301: {
 1302:     struct_objet            *s_objet_argument;
 1303:     struct_objet            *s_objet_resultat;
 1304: 
 1305:     (*s_etat_processus).erreur_execution = d_ex;
 1306: 
 1307:     if ((*s_etat_processus).affichage_arguments == 'Y')
 1308:     {
 1309:         printf("\n  UCASE ");
 1310:         
 1311:         if ((*s_etat_processus).langue == 'F')
 1312:         {
 1313:             printf("(converison d'une chaîne de caractères en majuscules)\n\n");
 1314:         }
 1315:         else
 1316:         {
 1317:             printf("(convert string to upper case)\n\n");
 1318:         }
 1319: 
 1320:         printf("    1: %s\n", d_CHN);
 1321:         return;
 1322:     }
 1323:     else if ((*s_etat_processus).test_instruction == 'Y')
 1324:     {
 1325:         (*s_etat_processus).nombre_arguments = -1;
 1326:         return;
 1327:     }
 1328: 
 1329:     if (test_cfsf(s_etat_processus, 31) == d_vrai)
 1330:     {
 1331:         if (empilement_pile_last(s_etat_processus, 1) == d_erreur)
 1332:         {
 1333:             return;
 1334:         }
 1335:     }
 1336: 
 1337:     if (depilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
 1338:             &s_objet_argument) == d_erreur)
 1339:     {
 1340:         (*s_etat_processus).erreur_execution = d_ex_manque_argument;
 1341:         return;
 1342:     }
 1343: 
 1344:     if ((*s_objet_argument).type == CHN)
 1345:     {
 1346:         if ((s_objet_resultat = copie_objet(s_etat_processus,
 1347:                 s_objet_argument, 'O')) == NULL)
 1348:         {
 1349:             (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
 1350:             return;
 1351:         }
 1352: 
 1353:         liberation(s_etat_processus, s_objet_argument);
 1354:         conversion_chaine(s_etat_processus, (unsigned char *)
 1355:                 (*s_objet_resultat).objet, 'M');
 1356: 
 1357:         if (empilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
 1358:                 s_objet_resultat) == d_erreur)
 1359:         {
 1360:             return;
 1361:         }
 1362:     }
 1363:     else
 1364:     {
 1365:         liberation(s_etat_processus, s_objet_argument);
 1366: 
 1367:         (*s_etat_processus).erreur_execution = d_ex_erreur_type_argument;
 1368:         return;
 1369:     }
 1370: 
 1371:     return;
 1372: }
 1373: 
 1374: // vim: ts=4

CVSweb interface <joel.bertrand@systella.fr>