![]() ![]() | ![]() |
Passage de la branche 4.1 en branche stable.
1: /* 2: ================================================================================ 3: RPL/2 (R) version 4.1.0 4: Copyright (C) 1989-2011 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 ((*s_etat_processus).rpl_home == NULL) 786: { 787: if ((tampon = malloc((strlen((unsigned char *) 788: (*s_objet_argument).objet) + strlen(d_exec_path) 789: + 7) * sizeof(unsigned char))) == NULL) 790: { 791: (*s_etat_processus).erreur_systeme = 792: d_es_allocation_memoire; 793: return; 794: } 795: 796: sprintf(tampon, "/%s/lib/%s", d_exec_path, (unsigned char *) 797: (*s_objet_argument).objet); 798: } 799: else 800: { 801: if ((tampon = malloc((strlen((unsigned char *) 802: (*s_objet_argument).objet) + 803: strlen((*s_etat_processus).rpl_home) 804: + 7) * sizeof(unsigned char))) == NULL) 805: { 806: (*s_etat_processus).erreur_systeme = 807: d_es_allocation_memoire; 808: return; 809: } 810: 811: sprintf(tampon, "/%s/lib/%s", (*s_etat_processus).rpl_home, 812: (unsigned char *) (*s_objet_argument).objet); 813: } 814: 815: caracteristiques_fichier(s_etat_processus, tampon, 816: &existence, &ouverture, &unite); 817: 818: if (existence != d_faux) 819: { 820: free((unsigned char *) (*s_objet_argument).objet); 821: (*s_objet_argument).objet = tampon; 822: } 823: else 824: { 825: free(tampon); 826: } 827: } 828: } 829: 830: if ((bibliotheque = chargement_bibliotheque(s_etat_processus, 831: (unsigned char *) (*s_objet_argument).objet)) == NULL) 832: { 833: liberation(s_etat_processus, s_objet_argument); 834: return; 835: } 836: 837: if ((s_objet_resultat = allocation(s_etat_processus, SLB)) == NULL) 838: { 839: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire; 840: return; 841: } 842: 843: (*((struct_bibliotheque *) (*s_objet_resultat).objet)).descripteur = 844: bibliotheque; 845: (*((struct_bibliotheque *) (*s_objet_resultat).objet)).pid = getpid(); 846: (*((struct_bibliotheque *) (*s_objet_resultat).objet)).tid = 847: pthread_self(); 848: 849: if (((*((struct_bibliotheque *) (*s_objet_resultat).objet)).nom = 850: malloc((strlen((unsigned char *) (*s_objet_argument).objet) 851: + 1) * sizeof(unsigned char))) == NULL) 852: { 853: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire; 854: return; 855: } 856: 857: strcpy((*((struct_bibliotheque *) (*s_objet_resultat).objet)).nom, 858: (unsigned char *) (*s_objet_argument).objet); 859: 860: liberation(s_etat_processus, s_objet_argument); 861: } 862: else 863: { 864: liberation(s_etat_processus, s_objet_argument); 865: 866: (*s_etat_processus).erreur_execution = d_ex_erreur_type_argument; 867: return; 868: } 869: 870: if (empilement(s_etat_processus, &((*s_etat_processus).l_base_pile), 871: s_objet_resultat) == d_erreur) 872: { 873: return; 874: } 875: 876: return; 877: } 878: 879: 880: /* 881: ================================================================================ 882: Fonction 'uchol' 883: ================================================================================ 884: Entrées : pointeur sur une structure struct_processus 885: -------------------------------------------------------------------------------- 886: Sorties : 887: -------------------------------------------------------------------------------- 888: Effets de bord : néant 889: ================================================================================ 890: */ 891: 892: void 893: instruction_uchol(struct_processus *s_etat_processus) 894: { 895: struct_objet *s_copie_objet; 896: struct_objet *s_objet; 897: 898: (*s_etat_processus).erreur_execution = d_ex; 899: 900: if ((*s_etat_processus).affichage_arguments == 'Y') 901: { 902: printf("\n UCHOL "); 903: 904: if ((*s_etat_processus).langue == 'F') 905: { 906: printf("(décomposition de Cholevski à droite)\n\n"); 907: } 908: else 909: { 910: printf("(right Cholevski decomposition)\n\n"); 911: } 912: 913: printf(" 1: %s, %s\n", d_MIN, d_MRL); 914: printf("-> 1: %s\n\n", d_MRL); 915: 916: printf(" 1: %s\n", d_MCX); 917: printf("-> 1: %s\n", d_MCX); 918: 919: return; 920: } 921: else if ((*s_etat_processus).test_instruction == 'Y') 922: { 923: (*s_etat_processus).nombre_arguments = -1; 924: return; 925: } 926: 927: if (test_cfsf(s_etat_processus, 31) == d_vrai) 928: { 929: if (empilement_pile_last(s_etat_processus, 1) == d_erreur) 930: { 931: return; 932: } 933: } 934: 935: if (depilement(s_etat_processus, &((*s_etat_processus).l_base_pile), 936: &s_objet) == d_erreur) 937: { 938: (*s_etat_processus).erreur_execution = d_ex_manque_argument; 939: return; 940: } 941: 942: 943: /* 944: -------------------------------------------------------------------------------- 945: Résultat sous la forme de matrices réelles 946: -------------------------------------------------------------------------------- 947: */ 948: 949: if (((*s_objet).type == MIN) || 950: ((*s_objet).type == MRL)) 951: { 952: if ((*((struct_matrice *) (*s_objet).objet)).nombre_lignes != 953: (*((struct_matrice *) (*s_objet).objet)).nombre_colonnes) 954: { 955: liberation(s_etat_processus, s_objet); 956: 957: (*s_etat_processus).erreur_execution = d_ex_dimensions_invalides; 958: return; 959: } 960: 961: if ((s_copie_objet = copie_objet(s_etat_processus, s_objet, 'Q')) 962: == NULL) 963: { 964: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire; 965: return; 966: } 967: 968: liberation(s_etat_processus, s_objet); 969: s_objet = s_copie_objet; 970: 971: factorisation_cholesky(s_etat_processus, (*s_objet).objet, 'U'); 972: (*s_objet).type = MRL; 973: 974: if ((*s_etat_processus).erreur_systeme != d_es) 975: { 976: return; 977: } 978: 979: if (((*s_etat_processus).exception != d_ep) || 980: ((*s_etat_processus).erreur_execution != d_ex)) 981: { 982: if ((*s_etat_processus).exception == d_ep_domaine_definition) 983: { 984: (*s_etat_processus).exception = 985: d_ep_matrice_non_definie_positive; 986: } 987: 988: liberation(s_etat_processus, s_objet); 989: return; 990: } 991: } 992: 993: /* 994: -------------------------------------------------------------------------------- 995: Résultat sous la forme de matrices complexes 996: -------------------------------------------------------------------------------- 997: */ 998: 999: else if ((*s_objet).type == MCX) 1000: { 1001: if ((*((struct_matrice *) (*s_objet).objet)).nombre_lignes != 1002: (*((struct_matrice *) (*s_objet).objet)).nombre_colonnes) 1003: { 1004: liberation(s_etat_processus, s_objet); 1005: 1006: (*s_etat_processus).erreur_execution = d_ex_dimensions_invalides; 1007: return; 1008: } 1009: 1010: if ((s_copie_objet = copie_objet(s_etat_processus, s_objet, 'Q')) 1011: == NULL) 1012: { 1013: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire; 1014: return; 1015: } 1016: 1017: liberation(s_etat_processus, s_objet); 1018: s_objet = s_copie_objet; 1019: 1020: factorisation_cholesky(s_etat_processus, (*s_objet).objet, 'U'); 1021: 1022: if ((*s_etat_processus).erreur_systeme != d_es) 1023: { 1024: return; 1025: } 1026: 1027: if (((*s_etat_processus).exception != d_ep) || 1028: ((*s_etat_processus).erreur_execution != d_ex)) 1029: { 1030: if ((*s_etat_processus).exception == d_ep_domaine_definition) 1031: { 1032: (*s_etat_processus).exception = 1033: d_ep_matrice_non_definie_positive; 1034: } 1035: 1036: liberation(s_etat_processus, s_objet); 1037: return; 1038: } 1039: } 1040: 1041: /* 1042: -------------------------------------------------------------------------------- 1043: Type d'argument invalide 1044: -------------------------------------------------------------------------------- 1045: */ 1046: 1047: else 1048: { 1049: liberation(s_etat_processus, s_objet); 1050: 1051: (*s_etat_processus).erreur_execution = d_ex_erreur_type_argument; 1052: return; 1053: } 1054: 1055: if (empilement(s_etat_processus, &((*s_etat_processus).l_base_pile), 1056: s_objet) == d_erreur) 1057: { 1058: return; 1059: } 1060: 1061: return; 1062: } 1063: 1064: 1065: /* 1066: ================================================================================ 1067: Fonction 'unlock' 1068: ================================================================================ 1069: Entrées : pointeur sur une structure struct_processus 1070: -------------------------------------------------------------------------------- 1071: Sorties : 1072: -------------------------------------------------------------------------------- 1073: Effets de bord : néant 1074: ================================================================================ 1075: */ 1076: 1077: void 1078: instruction_unlock(struct_processus *s_etat_processus) 1079: { 1080: struct flock lock; 1081: 1082: struct_descripteur_fichier *descripteur; 1083: 1084: struct_objet *s_objet; 1085: 1086: (*s_etat_processus).erreur_execution = d_ex; 1087: 1088: if ((*s_etat_processus).affichage_arguments == 'Y') 1089: { 1090: printf("\n UNLOCK "); 1091: 1092: if ((*s_etat_processus).langue == 'F') 1093: { 1094: printf("(déverrouillage d'un fichier)\n\n"); 1095: } 1096: else 1097: { 1098: printf("(file unlock)\n\n"); 1099: } 1100: 1101: printf(" 1: %s\n", d_FCH); 1102: 1103: return; 1104: } 1105: else if ((*s_etat_processus).test_instruction == 'Y') 1106: { 1107: (*s_etat_processus).nombre_arguments = -1; 1108: return; 1109: } 1110: 1111: if (test_cfsf(s_etat_processus, 31) == d_vrai) 1112: { 1113: if (empilement_pile_last(s_etat_processus, 1) == d_erreur) 1114: { 1115: return; 1116: } 1117: } 1118: 1119: if (depilement(s_etat_processus, &((*s_etat_processus).l_base_pile), 1120: &s_objet) == d_erreur) 1121: { 1122: (*s_etat_processus).erreur_execution = d_ex_manque_argument; 1123: return; 1124: } 1125: 1126: if ((*s_objet).type == FCH) 1127: { 1128: lock.l_type = F_UNLCK; 1129: lock.l_whence = SEEK_SET; 1130: lock.l_start = 0; 1131: lock.l_len = 0; 1132: lock.l_pid = getpid(); 1133: 1134: if ((descripteur = descripteur_fichier(s_etat_processus, 1135: (struct_fichier *) (*s_objet).objet)) == NULL) 1136: { 1137: return; 1138: } 1139: 1140: if (fcntl(fileno((*descripteur).descripteur_c), F_SETLK, &lock) 1141: == -1) 1142: { 1143: liberation(s_etat_processus, s_objet); 1144: 1145: (*s_etat_processus).erreur_execution = d_ex_fichier_verrouille; 1146: return; 1147: } 1148: } 1149: else 1150: { 1151: liberation(s_etat_processus, s_objet); 1152: 1153: (*s_etat_processus).erreur_execution = d_ex_erreur_type_argument; 1154: return; 1155: } 1156: 1157: return; 1158: } 1159: 1160: 1161: /* 1162: ================================================================================ 1163: Fonction 'unprotect' 1164: ================================================================================ 1165: Entrées : 1166: -------------------------------------------------------------------------------- 1167: Sorties : 1168: -------------------------------------------------------------------------------- 1169: Effets de bord : néant 1170: ================================================================================ 1171: */ 1172: 1173: void 1174: instruction_unprotect(struct_processus *s_etat_processus) 1175: { 1176: struct_liste_chainee *l_element_courant; 1177: 1178: struct_objet *s_objet; 1179: 1180: (*s_etat_processus).erreur_execution = d_ex; 1181: 1182: if ((*s_etat_processus).affichage_arguments == 'Y') 1183: { 1184: printf("\n UNPROTECT "); 1185: 1186: if ((*s_etat_processus).langue == 'F') 1187: { 1188: printf("(déverrouille une variable)\n\n"); 1189: } 1190: else 1191: { 1192: printf("(unlock a variable)\n\n"); 1193: } 1194: 1195: printf(" 1: %s, %s\n", d_NOM, d_LST); 1196: 1197: return; 1198: } 1199: else if ((*s_etat_processus).test_instruction == 'Y') 1200: { 1201: (*s_etat_processus).nombre_arguments = -1; 1202: return; 1203: } 1204: 1205: if (test_cfsf(s_etat_processus, 31) == d_vrai) 1206: { 1207: if (empilement_pile_last(s_etat_processus, 1) == d_erreur) 1208: { 1209: return; 1210: } 1211: } 1212: 1213: if (depilement(s_etat_processus, &((*s_etat_processus).l_base_pile), 1214: &s_objet) == d_erreur) 1215: { 1216: (*s_etat_processus).erreur_execution = d_ex_manque_argument; 1217: return; 1218: } 1219: 1220: if ((*s_objet).type == NOM) 1221: { 1222: if (recherche_variable(s_etat_processus, ((*((struct_nom *) 1223: (*s_objet).objet)).nom)) == d_faux) 1224: { 1225: liberation(s_etat_processus, s_objet); 1226: 1227: (*s_etat_processus).erreur_systeme = d_es; 1228: (*s_etat_processus).erreur_execution = d_ex_variable_non_definie; 1229: return; 1230: } 1231: 1232: (*(*s_etat_processus).pointeur_variable_courante) 1233: .variable_verrouillee = d_faux; 1234: } 1235: else if ((*s_objet).type == LST) 1236: { 1237: l_element_courant = (struct_liste_chainee *) (*s_objet).objet; 1238: 1239: while(l_element_courant != NULL) 1240: { 1241: if ((*(*l_element_courant).donnee).type != NOM) 1242: { 1243: liberation(s_etat_processus, s_objet); 1244: 1245: (*s_etat_processus).erreur_execution = d_ex_nom_invalide; 1246: return; 1247: } 1248: 1249: if (recherche_variable(s_etat_processus, (*((struct_nom *) 1250: (*(*l_element_courant).donnee).objet)).nom) == d_faux) 1251: { 1252: liberation(s_etat_processus, s_objet); 1253: 1254: (*s_etat_processus).erreur_systeme = d_es; 1255: (*s_etat_processus).erreur_execution = 1256: d_ex_variable_non_definie; 1257: return; 1258: } 1259: 1260: (*(*s_etat_processus).pointeur_variable_courante) 1261: .variable_verrouillee = d_faux; 1262: 1263: l_element_courant = (*l_element_courant).suivant; 1264: } 1265: } 1266: else 1267: { 1268: liberation(s_etat_processus, s_objet); 1269: 1270: (*s_etat_processus).erreur_execution = d_ex_nom_invalide; 1271: return; 1272: } 1273: 1274: liberation(s_etat_processus, s_objet); 1275: 1276: return; 1277: } 1278: 1279: 1280: /* 1281: ================================================================================ 1282: Fonction 'ucase' 1283: ================================================================================ 1284: Entrées : pointeur sur une structure struct_processus 1285: -------------------------------------------------------------------------------- 1286: Sorties : 1287: -------------------------------------------------------------------------------- 1288: Effets de bord : néant 1289: ================================================================================ 1290: */ 1291: 1292: void 1293: instruction_ucase(struct_processus *s_etat_processus) 1294: { 1295: struct_objet *s_objet_argument; 1296: struct_objet *s_objet_resultat; 1297: 1298: unsigned char *ptr; 1299: unsigned char registre; 1300: 1301: (*s_etat_processus).erreur_execution = d_ex; 1302: 1303: if ((*s_etat_processus).affichage_arguments == 'Y') 1304: { 1305: printf("\n UCASE "); 1306: 1307: if ((*s_etat_processus).langue == 'F') 1308: { 1309: printf("(converison d'une chaîne de caractères en majuscules)\n\n"); 1310: } 1311: else 1312: { 1313: printf("(convert string to upper case)\n\n"); 1314: } 1315: 1316: printf(" 1: %s\n", d_CHN); 1317: return; 1318: } 1319: else if ((*s_etat_processus).test_instruction == 'Y') 1320: { 1321: (*s_etat_processus).nombre_arguments = -1; 1322: return; 1323: } 1324: 1325: if (test_cfsf(s_etat_processus, 31) == d_vrai) 1326: { 1327: if (empilement_pile_last(s_etat_processus, 1) == d_erreur) 1328: { 1329: return; 1330: } 1331: } 1332: 1333: if (depilement(s_etat_processus, &((*s_etat_processus).l_base_pile), 1334: &s_objet_argument) == d_erreur) 1335: { 1336: (*s_etat_processus).erreur_execution = d_ex_manque_argument; 1337: return; 1338: } 1339: 1340: if ((*s_objet_argument).type == CHN) 1341: { 1342: if ((s_objet_resultat = copie_objet(s_etat_processus, 1343: s_objet_argument, 'O')) == NULL) 1344: { 1345: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire; 1346: return; 1347: } 1348: 1349: liberation(s_etat_processus, s_objet_argument); 1350: ptr = (unsigned char *) (*s_objet_resultat).objet; 1351: 1352: while((*ptr) != d_code_fin_chaine) 1353: { 1354: registre = toupper((*ptr)); 1355: 1356: if (tolower(registre) == (*ptr)) 1357: { 1358: (*ptr) = registre; 1359: } 1360: 1361: ptr++; 1362: } 1363: 1364: if (empilement(s_etat_processus, &((*s_etat_processus).l_base_pile), 1365: s_objet_resultat) == d_erreur) 1366: { 1367: return; 1368: } 1369: } 1370: else 1371: { 1372: liberation(s_etat_processus, s_objet_argument); 1373: 1374: (*s_etat_processus).erreur_execution = d_ex_erreur_type_argument; 1375: return; 1376: } 1377: 1378: return; 1379: } 1380: 1381: // vim: ts=4