Annotation of rpl/src/instructions_u1.c, revision 1.1
1.1 ! bertrand 1: /*
! 2: ================================================================================
! 3: RPL/2 (R) version 4.0.9
! 4: Copyright (C) 1989-2010 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 erreur;
! 693: logical1 existence;
! 694: logical1 ouverture;
! 695:
! 696: struct_objet *s_objet_argument;
! 697: struct_objet *s_objet_resultat;
! 698:
! 699: unsigned char *tampon;
! 700:
! 701: unsigned long unite;
! 702:
! 703: void *bibliotheque;
! 704:
! 705: (*s_etat_processus).erreur_execution = d_ex;
! 706:
! 707: if ((*s_etat_processus).affichage_arguments == 'Y')
! 708: {
! 709: printf("\n USE ");
! 710:
! 711: if ((*s_etat_processus).langue == 'F')
! 712: {
! 713: printf("(insertion d'une bibliothèque dynamique)\n\n");
! 714: printf("Si le chemin ne comprend pas de '/', la bibliothèque "
! 715: "est recherchée\n");
! 716: printf("successivement dans le répertoire courant puis dans %s."
! 717: "\n\n", d_exec_path);
! 718: }
! 719: else
! 720: {
! 721: printf("(insert a shared library)\n\n");
! 722: printf("If this path does not include '/', RPL/2 tries to find "
! 723: "it in current\n");
! 724: printf("directory or %s in this order.\n\n", d_exec_path);
! 725: }
! 726:
! 727: printf(" 1: %s\n", d_CHN);
! 728: printf("-> 1: %s\n", d_SLB);
! 729:
! 730: return;
! 731: }
! 732: else if ((*s_etat_processus).test_instruction == 'Y')
! 733: {
! 734: (*s_etat_processus).nombre_arguments = -1;
! 735: return;
! 736: }
! 737:
! 738: if (test_cfsf(s_etat_processus, 31) == d_vrai)
! 739: {
! 740: if (empilement_pile_last(s_etat_processus, 1) == d_erreur)
! 741: {
! 742: return;
! 743: }
! 744: }
! 745:
! 746: if (depilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
! 747: &s_objet_argument) == d_erreur)
! 748: {
! 749: (*s_etat_processus).erreur_execution = d_ex_manque_argument;
! 750: return;
! 751: }
! 752:
! 753: if ((*s_objet_argument).type == CHN)
! 754: {
! 755: /*
! 756: * Si le nom contient un '/', il est traité comme un chemin
! 757: * absolu. Dans le cas contraire, on essaye successivement
! 758: * './' puis le répertoire lib de l'installation du langage.
! 759: */
! 760:
! 761: if (index((unsigned char *) (*s_objet_argument).objet, '/') == NULL)
! 762: {
! 763: if ((tampon = malloc((strlen((unsigned char *) (*s_objet_argument)
! 764: .objet) + 3) * sizeof(unsigned char))) == NULL)
! 765: {
! 766: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
! 767: return;
! 768: }
! 769:
! 770: sprintf(tampon, "./%s", (unsigned char *)
! 771: (*s_objet_argument).objet);
! 772:
! 773: erreur = caracteristiques_fichier(s_etat_processus, tampon,
! 774: &existence, &ouverture, &unite);
! 775:
! 776: if (existence != d_faux)
! 777: {
! 778: free((unsigned char *) (*s_objet_argument).objet);
! 779: (*s_objet_argument).objet = tampon;
! 780: }
! 781: else
! 782: {
! 783: free(tampon);
! 784:
! 785: if ((tampon = malloc((strlen((unsigned char *)
! 786: (*s_objet_argument).objet) + strlen(d_exec_path) + 7)
! 787: * sizeof(unsigned char))) == NULL)
! 788: {
! 789: (*s_etat_processus).erreur_systeme =
! 790: d_es_allocation_memoire;
! 791: return;
! 792: }
! 793:
! 794: sprintf(tampon, "/%s/lib/%s", d_exec_path, (unsigned char *)
! 795: (*s_objet_argument).objet);
! 796:
! 797: caracteristiques_fichier(s_etat_processus, tampon,
! 798: &existence, &ouverture, &unite);
! 799:
! 800: if (existence != d_faux)
! 801: {
! 802: free((unsigned char *) (*s_objet_argument).objet);
! 803: (*s_objet_argument).objet = tampon;
! 804: }
! 805: else
! 806: {
! 807: free(tampon);
! 808: }
! 809: }
! 810: }
! 811:
! 812: if ((bibliotheque = chargement_bibliotheque(s_etat_processus,
! 813: (unsigned char *) (*s_objet_argument).objet)) == NULL)
! 814: {
! 815: liberation(s_etat_processus, s_objet_argument);
! 816: return;
! 817: }
! 818:
! 819: if ((s_objet_resultat = allocation(s_etat_processus, SLB)) == NULL)
! 820: {
! 821: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
! 822: return;
! 823: }
! 824:
! 825: (*((struct_bibliotheque *) (*s_objet_resultat).objet)).descripteur =
! 826: bibliotheque;
! 827: (*((struct_bibliotheque *) (*s_objet_resultat).objet)).pid = getpid();
! 828: (*((struct_bibliotheque *) (*s_objet_resultat).objet)).tid =
! 829: pthread_self();
! 830:
! 831: if (((*((struct_bibliotheque *) (*s_objet_resultat).objet)).nom =
! 832: malloc((strlen((unsigned char *) (*s_objet_argument).objet)
! 833: + 1) * sizeof(unsigned char))) == NULL)
! 834: {
! 835: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
! 836: return;
! 837: }
! 838:
! 839: strcpy((*((struct_bibliotheque *) (*s_objet_resultat).objet)).nom,
! 840: (unsigned char *) (*s_objet_argument).objet);
! 841:
! 842: liberation(s_etat_processus, s_objet_argument);
! 843: }
! 844: else
! 845: {
! 846: liberation(s_etat_processus, s_objet_argument);
! 847:
! 848: (*s_etat_processus).erreur_execution = d_ex_erreur_type_argument;
! 849: return;
! 850: }
! 851:
! 852: if (empilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
! 853: s_objet_resultat) == d_erreur)
! 854: {
! 855: return;
! 856: }
! 857:
! 858: return;
! 859: }
! 860:
! 861:
! 862: /*
! 863: ================================================================================
! 864: Fonction 'uchol'
! 865: ================================================================================
! 866: Entrées : pointeur sur une structure struct_processus
! 867: --------------------------------------------------------------------------------
! 868: Sorties :
! 869: --------------------------------------------------------------------------------
! 870: Effets de bord : néant
! 871: ================================================================================
! 872: */
! 873:
! 874: void
! 875: instruction_uchol(struct_processus *s_etat_processus)
! 876: {
! 877: struct_objet *s_copie_objet;
! 878: struct_objet *s_objet;
! 879:
! 880: (*s_etat_processus).erreur_execution = d_ex;
! 881:
! 882: if ((*s_etat_processus).affichage_arguments == 'Y')
! 883: {
! 884: printf("\n UCHOL ");
! 885:
! 886: if ((*s_etat_processus).langue == 'F')
! 887: {
! 888: printf("(décomposition de Cholevski à droite)\n\n");
! 889: }
! 890: else
! 891: {
! 892: printf("(right Cholevski decomposition)\n\n");
! 893: }
! 894:
! 895: printf(" 1: %s, %s\n", d_MIN, d_MRL);
! 896: printf("-> 1: %s\n\n", d_MRL);
! 897:
! 898: printf(" 1: %s\n", d_MCX);
! 899: printf("-> 1: %s\n", d_MCX);
! 900:
! 901: return;
! 902: }
! 903: else if ((*s_etat_processus).test_instruction == 'Y')
! 904: {
! 905: (*s_etat_processus).nombre_arguments = -1;
! 906: return;
! 907: }
! 908:
! 909: if (test_cfsf(s_etat_processus, 31) == d_vrai)
! 910: {
! 911: if (empilement_pile_last(s_etat_processus, 1) == d_erreur)
! 912: {
! 913: return;
! 914: }
! 915: }
! 916:
! 917: if (depilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
! 918: &s_objet) == d_erreur)
! 919: {
! 920: (*s_etat_processus).erreur_execution = d_ex_manque_argument;
! 921: return;
! 922: }
! 923:
! 924:
! 925: /*
! 926: --------------------------------------------------------------------------------
! 927: Résultat sous la forme de matrices réelles
! 928: --------------------------------------------------------------------------------
! 929: */
! 930:
! 931: if (((*s_objet).type == MIN) ||
! 932: ((*s_objet).type == MRL))
! 933: {
! 934: if ((*((struct_matrice *) (*s_objet).objet)).nombre_lignes !=
! 935: (*((struct_matrice *) (*s_objet).objet)).nombre_colonnes)
! 936: {
! 937: liberation(s_etat_processus, s_objet);
! 938:
! 939: (*s_etat_processus).erreur_execution = d_ex_dimensions_invalides;
! 940: return;
! 941: }
! 942:
! 943: if ((s_copie_objet = copie_objet(s_etat_processus, s_objet, 'Q'))
! 944: == NULL)
! 945: {
! 946: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
! 947: return;
! 948: }
! 949:
! 950: liberation(s_etat_processus, s_objet);
! 951: s_objet = s_copie_objet;
! 952:
! 953: factorisation_cholesky(s_etat_processus, (*s_objet).objet, 'U');
! 954: (*s_objet).type = MRL;
! 955:
! 956: if ((*s_etat_processus).erreur_systeme != d_es)
! 957: {
! 958: return;
! 959: }
! 960:
! 961: if (((*s_etat_processus).exception != d_ep) ||
! 962: ((*s_etat_processus).erreur_execution != d_ex))
! 963: {
! 964: if ((*s_etat_processus).exception == d_ep_domaine_definition)
! 965: {
! 966: (*s_etat_processus).exception =
! 967: d_ep_matrice_non_definie_positive;
! 968: }
! 969:
! 970: liberation(s_etat_processus, s_objet);
! 971: return;
! 972: }
! 973: }
! 974:
! 975: /*
! 976: --------------------------------------------------------------------------------
! 977: Résultat sous la forme de matrices complexes
! 978: --------------------------------------------------------------------------------
! 979: */
! 980:
! 981: else if ((*s_objet).type == MCX)
! 982: {
! 983: if ((*((struct_matrice *) (*s_objet).objet)).nombre_lignes !=
! 984: (*((struct_matrice *) (*s_objet).objet)).nombre_colonnes)
! 985: {
! 986: liberation(s_etat_processus, s_objet);
! 987:
! 988: (*s_etat_processus).erreur_execution = d_ex_dimensions_invalides;
! 989: return;
! 990: }
! 991:
! 992: if ((s_copie_objet = copie_objet(s_etat_processus, s_objet, 'Q'))
! 993: == NULL)
! 994: {
! 995: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
! 996: return;
! 997: }
! 998:
! 999: liberation(s_etat_processus, s_objet);
! 1000: s_objet = s_copie_objet;
! 1001:
! 1002: factorisation_cholesky(s_etat_processus, (*s_objet).objet, 'U');
! 1003:
! 1004: if ((*s_etat_processus).erreur_systeme != d_es)
! 1005: {
! 1006: return;
! 1007: }
! 1008:
! 1009: if (((*s_etat_processus).exception != d_ep) ||
! 1010: ((*s_etat_processus).erreur_execution != d_ex))
! 1011: {
! 1012: if ((*s_etat_processus).exception == d_ep_domaine_definition)
! 1013: {
! 1014: (*s_etat_processus).exception =
! 1015: d_ep_matrice_non_definie_positive;
! 1016: }
! 1017:
! 1018: liberation(s_etat_processus, s_objet);
! 1019: return;
! 1020: }
! 1021: }
! 1022:
! 1023: /*
! 1024: --------------------------------------------------------------------------------
! 1025: Type d'argument invalide
! 1026: --------------------------------------------------------------------------------
! 1027: */
! 1028:
! 1029: else
! 1030: {
! 1031: liberation(s_etat_processus, s_objet);
! 1032:
! 1033: (*s_etat_processus).erreur_execution = d_ex_erreur_type_argument;
! 1034: return;
! 1035: }
! 1036:
! 1037: if (empilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
! 1038: s_objet) == d_erreur)
! 1039: {
! 1040: return;
! 1041: }
! 1042:
! 1043: return;
! 1044: }
! 1045:
! 1046:
! 1047: /*
! 1048: ================================================================================
! 1049: Fonction 'unlock'
! 1050: ================================================================================
! 1051: Entrées : pointeur sur une structure struct_processus
! 1052: --------------------------------------------------------------------------------
! 1053: Sorties :
! 1054: --------------------------------------------------------------------------------
! 1055: Effets de bord : néant
! 1056: ================================================================================
! 1057: */
! 1058:
! 1059: void
! 1060: instruction_unlock(struct_processus *s_etat_processus)
! 1061: {
! 1062: file *descripteur;
! 1063:
! 1064: struct flock lock;
! 1065:
! 1066: struct_objet *s_objet;
! 1067:
! 1068: (*s_etat_processus).erreur_execution = d_ex;
! 1069:
! 1070: if ((*s_etat_processus).affichage_arguments == 'Y')
! 1071: {
! 1072: printf("\n UNLOCK ");
! 1073:
! 1074: if ((*s_etat_processus).langue == 'F')
! 1075: {
! 1076: printf("(déverrouillage d'un fichier)\n\n");
! 1077: }
! 1078: else
! 1079: {
! 1080: printf("(file unlock)\n\n");
! 1081: }
! 1082:
! 1083: printf(" 1: %s\n", d_FCH);
! 1084:
! 1085: return;
! 1086: }
! 1087: else if ((*s_etat_processus).test_instruction == 'Y')
! 1088: {
! 1089: (*s_etat_processus).nombre_arguments = -1;
! 1090: return;
! 1091: }
! 1092:
! 1093: if (test_cfsf(s_etat_processus, 31) == d_vrai)
! 1094: {
! 1095: if (empilement_pile_last(s_etat_processus, 1) == d_erreur)
! 1096: {
! 1097: return;
! 1098: }
! 1099: }
! 1100:
! 1101: if (depilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
! 1102: &s_objet) == d_erreur)
! 1103: {
! 1104: (*s_etat_processus).erreur_execution = d_ex_manque_argument;
! 1105: return;
! 1106: }
! 1107:
! 1108: if ((*s_objet).type == FCH)
! 1109: {
! 1110: lock.l_type = F_UNLCK;
! 1111: lock.l_whence = SEEK_SET;
! 1112: lock.l_start = 0;
! 1113: lock.l_len = 0;
! 1114: lock.l_pid = getpid();
! 1115:
! 1116: if ((descripteur = descripteur_fichier(s_etat_processus,
! 1117: (struct_fichier *) (*s_objet).objet)) == NULL)
! 1118: {
! 1119: return;
! 1120: }
! 1121:
! 1122: if (fcntl(fileno(descripteur), F_SETLK, &lock) == -1)
! 1123: {
! 1124: liberation(s_etat_processus, s_objet);
! 1125:
! 1126: (*s_etat_processus).erreur_execution = d_ex_fichier_verrouille;
! 1127: return;
! 1128: }
! 1129: }
! 1130: else
! 1131: {
! 1132: liberation(s_etat_processus, s_objet);
! 1133:
! 1134: (*s_etat_processus).erreur_execution = d_ex_erreur_type_argument;
! 1135: return;
! 1136: }
! 1137:
! 1138: return;
! 1139: }
! 1140:
! 1141:
! 1142: /*
! 1143: ================================================================================
! 1144: Fonction 'unprotect'
! 1145: ================================================================================
! 1146: Entrées :
! 1147: --------------------------------------------------------------------------------
! 1148: Sorties :
! 1149: --------------------------------------------------------------------------------
! 1150: Effets de bord : néant
! 1151: ================================================================================
! 1152: */
! 1153:
! 1154: void
! 1155: instruction_unprotect(struct_processus *s_etat_processus)
! 1156: {
! 1157: struct_liste_chainee *l_element_courant;
! 1158:
! 1159: struct_objet *s_objet;
! 1160:
! 1161: (*s_etat_processus).erreur_execution = d_ex;
! 1162:
! 1163: if ((*s_etat_processus).affichage_arguments == 'Y')
! 1164: {
! 1165: printf("\n UNPROTECT ");
! 1166:
! 1167: if ((*s_etat_processus).langue == 'F')
! 1168: {
! 1169: printf("(déverrouille une variable)\n\n");
! 1170: }
! 1171: else
! 1172: {
! 1173: printf("(unlock a variable)\n\n");
! 1174: }
! 1175:
! 1176: printf(" 1: %s, %s\n", d_NOM, d_LST);
! 1177:
! 1178: return;
! 1179: }
! 1180: else if ((*s_etat_processus).test_instruction == 'Y')
! 1181: {
! 1182: (*s_etat_processus).nombre_arguments = -1;
! 1183: return;
! 1184: }
! 1185:
! 1186: if (test_cfsf(s_etat_processus, 31) == d_vrai)
! 1187: {
! 1188: if (empilement_pile_last(s_etat_processus, 1) == d_erreur)
! 1189: {
! 1190: return;
! 1191: }
! 1192: }
! 1193:
! 1194: if (depilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
! 1195: &s_objet) == d_erreur)
! 1196: {
! 1197: (*s_etat_processus).erreur_execution = d_ex_manque_argument;
! 1198: return;
! 1199: }
! 1200:
! 1201: if ((*s_objet).type == NOM)
! 1202: {
! 1203: if (recherche_variable(s_etat_processus, ((*((struct_nom *)
! 1204: (*s_objet).objet)).nom)) == d_faux)
! 1205: {
! 1206: liberation(s_etat_processus, s_objet);
! 1207:
! 1208: (*s_etat_processus).erreur_systeme = d_es;
! 1209: (*s_etat_processus).erreur_execution = d_ex_variable_non_definie;
! 1210: return;
! 1211: }
! 1212:
! 1213: ((*s_etat_processus).s_liste_variables[(*s_etat_processus)
! 1214: .position_variable_courante]).variable_verrouillee = d_faux;
! 1215: }
! 1216: else if ((*s_objet).type == LST)
! 1217: {
! 1218: l_element_courant = (struct_liste_chainee *) (*s_objet).objet;
! 1219:
! 1220: while(l_element_courant != NULL)
! 1221: {
! 1222: if ((*(*l_element_courant).donnee).type != NOM)
! 1223: {
! 1224: liberation(s_etat_processus, s_objet);
! 1225:
! 1226: (*s_etat_processus).erreur_execution = d_ex_nom_invalide;
! 1227: return;
! 1228: }
! 1229:
! 1230: if (recherche_variable(s_etat_processus, (*((struct_nom *)
! 1231: (*(*l_element_courant).donnee).objet)).nom) == d_faux)
! 1232: {
! 1233: liberation(s_etat_processus, s_objet);
! 1234:
! 1235: (*s_etat_processus).erreur_systeme = d_es;
! 1236: (*s_etat_processus).erreur_execution =
! 1237: d_ex_variable_non_definie;
! 1238: return;
! 1239: }
! 1240:
! 1241: ((*s_etat_processus).s_liste_variables[(*s_etat_processus)
! 1242: .position_variable_courante]).variable_verrouillee = d_faux;
! 1243:
! 1244: l_element_courant = (*l_element_courant).suivant;
! 1245: }
! 1246: }
! 1247: else
! 1248: {
! 1249: liberation(s_etat_processus, s_objet);
! 1250:
! 1251: (*s_etat_processus).erreur_execution = d_ex_nom_invalide;
! 1252: return;
! 1253: }
! 1254:
! 1255: liberation(s_etat_processus, s_objet);
! 1256:
! 1257: return;
! 1258: }
! 1259:
! 1260:
! 1261: /*
! 1262: ================================================================================
! 1263: Fonction 'ucase'
! 1264: ================================================================================
! 1265: Entrées : pointeur sur une structure struct_processus
! 1266: --------------------------------------------------------------------------------
! 1267: Sorties :
! 1268: --------------------------------------------------------------------------------
! 1269: Effets de bord : néant
! 1270: ================================================================================
! 1271: */
! 1272:
! 1273: void
! 1274: instruction_ucase(struct_processus *s_etat_processus)
! 1275: {
! 1276: struct_objet *s_objet_argument;
! 1277: struct_objet *s_objet_resultat;
! 1278:
! 1279: unsigned char *ptr;
! 1280: unsigned char registre;
! 1281:
! 1282: (*s_etat_processus).erreur_execution = d_ex;
! 1283:
! 1284: if ((*s_etat_processus).affichage_arguments == 'Y')
! 1285: {
! 1286: printf("\n UCASE ");
! 1287:
! 1288: if ((*s_etat_processus).langue == 'F')
! 1289: {
! 1290: printf("(converison d'une chaîne de caractères en majuscules)\n\n");
! 1291: }
! 1292: else
! 1293: {
! 1294: printf("(convert string to upper case)\n\n");
! 1295: }
! 1296:
! 1297: printf(" 1: %s\n", d_CHN);
! 1298: return;
! 1299: }
! 1300: else if ((*s_etat_processus).test_instruction == 'Y')
! 1301: {
! 1302: (*s_etat_processus).nombre_arguments = -1;
! 1303: return;
! 1304: }
! 1305:
! 1306: if (test_cfsf(s_etat_processus, 31) == d_vrai)
! 1307: {
! 1308: if (empilement_pile_last(s_etat_processus, 1) == d_erreur)
! 1309: {
! 1310: return;
! 1311: }
! 1312: }
! 1313:
! 1314: if (depilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
! 1315: &s_objet_argument) == d_erreur)
! 1316: {
! 1317: (*s_etat_processus).erreur_execution = d_ex_manque_argument;
! 1318: return;
! 1319: }
! 1320:
! 1321: if ((*s_objet_argument).type == CHN)
! 1322: {
! 1323: if ((s_objet_resultat = copie_objet(s_etat_processus,
! 1324: s_objet_argument, 'O')) == NULL)
! 1325: {
! 1326: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
! 1327: return;
! 1328: }
! 1329:
! 1330: liberation(s_etat_processus, s_objet_argument);
! 1331: ptr = (unsigned char *) (*s_objet_resultat).objet;
! 1332:
! 1333: while((*ptr) != d_code_fin_chaine)
! 1334: {
! 1335: registre = toupper((*ptr));
! 1336:
! 1337: if (tolower(registre) == (*ptr))
! 1338: {
! 1339: (*ptr) = registre;
! 1340: }
! 1341:
! 1342: ptr++;
! 1343: }
! 1344:
! 1345: if (empilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
! 1346: s_objet_resultat) == d_erreur)
! 1347: {
! 1348: return;
! 1349: }
! 1350: }
! 1351: else
! 1352: {
! 1353: liberation(s_etat_processus, s_objet_argument);
! 1354:
! 1355: (*s_etat_processus).erreur_execution = d_ex_erreur_type_argument;
! 1356: return;
! 1357: }
! 1358:
! 1359: return;
! 1360: }
! 1361:
! 1362: // vim: ts=4
CVSweb interface <joel.bertrand@systella.fr>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to instructions_u1.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [local] / rpl / src