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