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