Annotation of rpl/src/instructions_u1.c, revision 1.12
1.1 bertrand 1: /*
2: ================================================================================
1.12 ! bertrand 3: RPL/2 (R) version 4.0.18
1.1 bertrand 4: Copyright (C) 1989-2010 Dr. BERTRAND Joël
5:
6: This file is part of RPL/2.
7:
8: RPL/2 is free software; you can redistribute it and/or modify it
9: under the terms of the CeCILL V2 License as published by the french
10: CEA, CNRS and INRIA.
11:
12: RPL/2 is distributed in the hope that it will be useful, but WITHOUT
13: ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
14: FITNESS FOR A PARTICULAR PURPOSE. See the CeCILL V2 License
15: for more details.
16:
17: You should have received a copy of the CeCILL License
18: along with RPL/2. If not, write to info@cecill.info.
19: ================================================================================
20: */
21:
22:
23: #include "rpl.conv.h"
24:
25:
26: /*
27: ================================================================================
28: Fonction 'until'
29: ================================================================================
30: Entrées : pointeur sur une structure struct_processus
31: --------------------------------------------------------------------------------
32: Sorties :
33: --------------------------------------------------------------------------------
34: Effets de bord : néant
35: ================================================================================
36: */
37:
38: void
39: instruction_until(struct_processus *s_etat_processus)
40: {
41: (*s_etat_processus).erreur_execution = d_ex;
42:
43: if ((*s_etat_processus).affichage_arguments == 'Y')
44: {
45: printf("\n UNTIL ");
46:
47: if ((*s_etat_processus).langue == 'F')
48: {
49: printf("(structure de contrôle)\n\n");
50: printf(" Utilisation :\n\n");
51: }
52: else
53: {
54: printf("(control statement)\n\n");
55: printf(" Usage:\n\n");
56: }
57:
58: printf(" DO\n");
59: printf(" (expression 1)\n");
60: printf(" EXIT\n");
61: printf(" (expression 2)\n");
62: printf(" UNTIL\n");
63: printf(" (clause)\n");
64: printf(" END\n\n");
65:
66: printf(" DO\n");
67: printf(" (expression)\n");
68: printf(" UNTIL\n");
69: printf(" (clause)\n");
70: printf(" END\n");
71:
72: return;
73: }
74: else if ((*s_etat_processus).test_instruction == 'Y')
75: {
76: (*s_etat_processus).nombre_arguments = -1;
77: return;
78: }
79:
80: (*(*s_etat_processus).l_base_pile_systeme).clause = 'U';
81:
82: return;
83: }
84:
85:
86: /*
87: ================================================================================
88: Fonction 'utpc'
89: ================================================================================
90: Entrées : pointeur sur une structure struct_processus
91: --------------------------------------------------------------------------------
92: Sorties :
93: --------------------------------------------------------------------------------
94: Effets de bord : néant
95: ================================================================================
96: */
97:
98: void
99: instruction_utpc(struct_processus *s_etat_processus)
100: {
101: integer8 n;
102:
103: real8 x;
104:
105: struct_objet *s_objet_argument_1;
106: struct_objet *s_objet_argument_2;
107: struct_objet *s_objet_resultat;
108:
109: (*s_etat_processus).erreur_execution = d_ex;
110:
111: if ((*s_etat_processus).affichage_arguments == 'Y')
112: {
113: printf("\n UTPC ");
114:
115: if ((*s_etat_processus).langue == 'F')
116: {
117: printf("(loi du Xhi carrée cumulé à droite)\n\n");
118: }
119: else
120: {
121: printf("(upper-tail probability chi-square distribution)\n\n");
122: }
123:
124: printf(" 2: %s\n", d_INT);
125: printf(" 1: %s, %s\n", d_INT, d_REL);
126: printf("-> 1: %s\n", d_REL);
127:
128: return;
129: }
130: else if ((*s_etat_processus).test_instruction == 'Y')
131: {
132: (*s_etat_processus).nombre_arguments = 2;
133: return;
134: }
135:
136: if (test_cfsf(s_etat_processus, 31) == d_vrai)
137: {
138: if (empilement_pile_last(s_etat_processus, 2) == d_erreur)
139: {
140: return;
141: }
142: }
143:
144: if (depilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
145: &s_objet_argument_1) == d_erreur)
146: {
147: (*s_etat_processus).erreur_execution = d_ex_manque_argument;
148: return;
149: }
150:
151: if (depilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
152: &s_objet_argument_2) == d_erreur)
153: {
154: liberation(s_etat_processus, s_objet_argument_1);
155:
156: (*s_etat_processus).erreur_execution = d_ex_manque_argument;
157: return;
158: }
159:
160: if (((*s_objet_argument_2).type == INT) &&
161: (((*s_objet_argument_1).type == REL) ||
162: ((*s_objet_argument_1).type == INT)))
163: {
164: n = (integer4) (*((integer8 *) (*s_objet_argument_2).objet));
165:
166: if (n <= 0)
167: {
168: liberation(s_etat_processus, s_objet_argument_1);
169: liberation(s_etat_processus, s_objet_argument_2);
170:
171: (*s_etat_processus).erreur_execution = d_ex_argument_invalide;
172: return;
173: }
174:
175: if ((s_objet_resultat = allocation(s_etat_processus, REL))
176: == NULL)
177: {
178: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
179: return;
180: }
181:
182: if ((*s_objet_argument_1).type == INT)
183: {
184: x = (real8) (*((integer8 *) (*s_objet_argument_1).objet));
185: }
186: else
187: {
188: x = (*((real8 *) (*s_objet_argument_1).objet));
189: }
190:
191: if (x < 0)
192: {
193: (*((real8 *) (*s_objet_resultat).objet)) = 1;
194: }
195: else
196: {
197: f90x2cd(&x, &n, (real8 *) (*s_objet_resultat).objet);
198: }
199: }
200: else
201: {
202: liberation(s_etat_processus, s_objet_argument_1);
203: liberation(s_etat_processus, s_objet_argument_2);
204:
205: (*s_etat_processus).erreur_execution = d_ex_erreur_type_argument;
206: return;
207: }
208:
209: liberation(s_etat_processus, s_objet_argument_1);
210: liberation(s_etat_processus, s_objet_argument_2);
211:
212: if (empilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
213: s_objet_resultat) == d_erreur)
214: {
215: return;
216: }
217:
218: return;
219: }
220:
221:
222: /*
223: ================================================================================
224: Fonction 'utpn'
225: ================================================================================
226: Entrées : pointeur sur une structure struct_processus
227: --------------------------------------------------------------------------------
228: Sorties :
229: --------------------------------------------------------------------------------
230: Effets de bord : néant
231: ================================================================================
232: */
233:
234: void
235: instruction_utpn(struct_processus *s_etat_processus)
236: {
237: real8 moyenne;
238: real8 variance;
239: real8 x;
240:
241: struct_objet *s_objet_argument_1;
242: struct_objet *s_objet_argument_2;
243: struct_objet *s_objet_argument_3;
244: struct_objet *s_objet_resultat;
245:
246: (*s_etat_processus).erreur_execution = d_ex;
247:
248: if ((*s_etat_processus).affichage_arguments == 'Y')
249: {
250: printf("\n UTPN ");
251:
252: if ((*s_etat_processus).langue == 'F')
253: {
254: printf("(loi normale cumulée à droite)\n\n");
255: }
256: else
257: {
258: printf("(upper-tail probability normal distribution)\n\n");
259: }
260:
261: printf(" 3: %s, %s\n", d_INT, d_REL);
262: printf(" 2: %s, %s\n", d_INT, d_REL);
263: printf(" 1: %s, %s\n", d_INT, d_REL);
264: printf("-> 1: %s\n", d_REL);
265:
266: return;
267: }
268: else if ((*s_etat_processus).test_instruction == 'Y')
269: {
270: (*s_etat_processus).nombre_arguments = 3;
271: return;
272: }
273:
274: if (test_cfsf(s_etat_processus, 31) == d_vrai)
275: {
276: if (empilement_pile_last(s_etat_processus, 3) == d_erreur)
277: {
278: return;
279: }
280: }
281:
282: if (depilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
283: &s_objet_argument_1) == d_erreur)
284: {
285: (*s_etat_processus).erreur_execution = d_ex_manque_argument;
286: return;
287: }
288:
289: if (depilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
290: &s_objet_argument_2) == d_erreur)
291: {
292: liberation(s_etat_processus, s_objet_argument_1);
293:
294: (*s_etat_processus).erreur_execution = d_ex_manque_argument;
295: return;
296: }
297:
298: if (depilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
299: &s_objet_argument_3) == d_erreur)
300: {
301: liberation(s_etat_processus, s_objet_argument_1);
302: liberation(s_etat_processus, s_objet_argument_2);
303:
304: (*s_etat_processus).erreur_execution = d_ex_manque_argument;
305: return;
306: }
307:
308: if ((((*s_objet_argument_1).type == INT) ||
309: ((*s_objet_argument_1).type == REL)) &&
310: (((*s_objet_argument_2).type == INT) ||
311: ((*s_objet_argument_2).type == REL)) &&
312: (((*s_objet_argument_3).type == INT) ||
313: ((*s_objet_argument_3).type == REL)))
314: {
315: if ((s_objet_resultat = allocation(s_etat_processus, REL))
316: == NULL)
317: {
318: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
319: return;
320: }
321:
322: if ((*s_objet_argument_1).type == INT)
323: {
324: x = (real8) (*((integer8 *) (*s_objet_argument_1).objet));
325: }
326: else
327: {
328: x = (*((real8 *) (*s_objet_argument_1).objet));
329: }
330:
331: if ((*s_objet_argument_3).type == INT)
332: {
333: moyenne = (real8) (*((integer8 *) (*s_objet_argument_3).objet));
334: }
335: else
336: {
337: moyenne = (*((real8 *) (*s_objet_argument_3).objet));
338: }
339:
340: if ((*s_objet_argument_2).type == INT)
341: {
342: variance = (real8) (*((integer8 *) (*s_objet_argument_2).objet));
343: }
344: else
345: {
346: variance = (*((real8 *) (*s_objet_argument_2).objet));
347: }
348:
349:
350: if (variance == 0)
351: {
352: (*((real8 *) (*s_objet_resultat).objet)) = 0;
353: }
354: else if (variance > 0)
355: {
356: f90gausscd(&x, &moyenne, &variance,
357: (real8 *) (*s_objet_resultat).objet);
358: }
359: else
360: {
361: liberation(s_etat_processus, s_objet_argument_1);
362: liberation(s_etat_processus, s_objet_argument_2);
363: liberation(s_etat_processus, s_objet_argument_3);
364: liberation(s_etat_processus, s_objet_resultat);
365:
366: (*s_etat_processus).erreur_execution = d_ex_erreur_type_argument;
367: return;
368: }
369: }
370: else
371: {
372: liberation(s_etat_processus, s_objet_argument_1);
373: liberation(s_etat_processus, s_objet_argument_2);
374: liberation(s_etat_processus, s_objet_argument_3);
375:
376: (*s_etat_processus).erreur_execution = d_ex_erreur_type_argument;
377: return;
378: }
379:
380: liberation(s_etat_processus, s_objet_argument_1);
381: liberation(s_etat_processus, s_objet_argument_2);
382: liberation(s_etat_processus, s_objet_argument_3);
383:
384: if (empilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
385: s_objet_resultat) == d_erreur)
386: {
387: return;
388: }
389:
390: return;
391: }
392:
393:
394: /*
395: ================================================================================
396: Fonction 'utpf'
397: ================================================================================
398: Entrées : pointeur sur une structure struct_processus
399: --------------------------------------------------------------------------------
400: Sorties :
401: --------------------------------------------------------------------------------
402: Effets de bord : néant
403: ================================================================================
404: */
405:
406: void
407: instruction_utpf(struct_processus *s_etat_processus)
408: {
409: integer8 n1;
410: integer8 n2;
411:
412: real8 x;
413:
414: struct_objet *s_objet_argument_1;
415: struct_objet *s_objet_argument_2;
416: struct_objet *s_objet_argument_3;
417: struct_objet *s_objet_resultat;
418:
419: (*s_etat_processus).erreur_execution = d_ex;
420:
421: if ((*s_etat_processus).affichage_arguments == 'Y')
422: {
423: printf("\n UTPF ");
424:
425: if ((*s_etat_processus).langue == 'F')
426: {
427: printf("(loi F cumulée à droite)\n\n");
428: }
429: else
430: {
431: printf("(upper-tail probability F distribution)\n\n");
432: }
433:
434: printf(" 3: %s\n", d_INT);
435: printf(" 2: %s\n", d_INT);
436: printf(" 1: %s, %s\n", d_INT, d_REL);
437: printf("-> 1: %s\n", d_REL);
438:
439: return;
440: }
441: else if ((*s_etat_processus).test_instruction == 'Y')
442: {
443: (*s_etat_processus).nombre_arguments = 3;
444: return;
445: }
446:
447: if (test_cfsf(s_etat_processus, 31) == d_vrai)
448: {
449: if (empilement_pile_last(s_etat_processus, 3) == d_erreur)
450: {
451: return;
452: }
453: }
454:
455: if (depilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
456: &s_objet_argument_1) == d_erreur)
457: {
458: (*s_etat_processus).erreur_execution = d_ex_manque_argument;
459: return;
460: }
461:
462: if (depilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
463: &s_objet_argument_2) == d_erreur)
464: {
465: liberation(s_etat_processus, s_objet_argument_1);
466:
467: (*s_etat_processus).erreur_execution = d_ex_manque_argument;
468: return;
469: }
470:
471: if (depilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
472: &s_objet_argument_3) == d_erreur)
473: {
474: liberation(s_etat_processus, s_objet_argument_1);
475: liberation(s_etat_processus, s_objet_argument_2);
476:
477: (*s_etat_processus).erreur_execution = d_ex_manque_argument;
478: return;
479: }
480:
481: if ((((*s_objet_argument_1).type == INT) ||
482: ((*s_objet_argument_1).type == REL)) &&
483: ((*s_objet_argument_2).type == INT) &&
484: ((*s_objet_argument_3).type == INT))
485: {
486: n1 = (integer4) (*((integer8 *) (*s_objet_argument_3).objet));
487: n2 = (integer4) (*((integer8 *) (*s_objet_argument_2).objet));
488:
489: if ((n1 <= 0) || (n2 <= 0))
490: {
491: liberation(s_etat_processus, s_objet_argument_1);
492: liberation(s_etat_processus, s_objet_argument_2);
493: liberation(s_etat_processus, s_objet_argument_3);
494:
495: (*s_etat_processus).erreur_execution = d_ex_argument_invalide;
496: return;
497: }
498:
499: if ((s_objet_resultat = allocation(s_etat_processus, REL))
500: == NULL)
501: {
502: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
503: return;
504: }
505:
506: if ((*s_objet_argument_1).type == INT)
507: {
508: x = (real8) (*((integer8 *) (*s_objet_argument_1).objet));
509: }
510: else
511: {
512: x = (*((real8 *) (*s_objet_argument_1).objet));
513: }
514:
515: if (x < 0)
516: {
517: (*((real8 *) (*s_objet_resultat).objet)) = 1;
518: }
519: else
520: {
521: f90fcd(&x, &n1, &n2, (real8 *) (*s_objet_resultat).objet);
522: }
523: }
524: else
525: {
526: liberation(s_etat_processus, s_objet_argument_1);
527: liberation(s_etat_processus, s_objet_argument_2);
528: liberation(s_etat_processus, s_objet_argument_3);
529:
530: (*s_etat_processus).erreur_execution = d_ex_erreur_type_argument;
531: return;
532: }
533:
534: liberation(s_etat_processus, s_objet_argument_1);
535: liberation(s_etat_processus, s_objet_argument_2);
536: liberation(s_etat_processus, s_objet_argument_3);
537:
538: if (empilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
539: s_objet_resultat) == d_erreur)
540: {
541: return;
542: }
543:
544: return;
545: }
546:
547:
548: /*
549: ================================================================================
550: Fonction 'utpt'
551: ================================================================================
552: Entrées : pointeur sur une structure struct_processus
553: --------------------------------------------------------------------------------
554: Sorties :
555: --------------------------------------------------------------------------------
556: Effets de bord : néant
557: ================================================================================
558: */
559:
560: void
561: instruction_utpt(struct_processus *s_etat_processus)
562: {
563: integer8 n;
564:
565: real8 x;
566:
567: struct_objet *s_objet_argument_1;
568: struct_objet *s_objet_argument_2;
569: struct_objet *s_objet_resultat;
570:
571: (*s_etat_processus).erreur_execution = d_ex;
572:
573: if ((*s_etat_processus).affichage_arguments == 'Y')
574: {
575: printf("\n UTPT ");
576:
577: if ((*s_etat_processus).langue == 'F')
578: {
579: printf("(loi du t de Student cumulée à droite)\n\n");
580: }
581: else
582: {
583: printf("(upper-tail probability Student's t distribution)\n\n");
584: }
585:
586: printf(" 2: %s\n", d_INT);
587: printf(" 1: %s, %s\n", d_INT, d_REL);
588: printf("-> 1: %s\n", d_REL);
589:
590: return;
591: }
592: else if ((*s_etat_processus).test_instruction == 'Y')
593: {
594: (*s_etat_processus).nombre_arguments = 2;
595: return;
596: }
597:
598: if (test_cfsf(s_etat_processus, 31) == d_vrai)
599: {
600: if (empilement_pile_last(s_etat_processus, 2) == d_erreur)
601: {
602: return;
603: }
604: }
605:
606: if (depilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
607: &s_objet_argument_1) == d_erreur)
608: {
609: (*s_etat_processus).erreur_execution = d_ex_manque_argument;
610: return;
611: }
612:
613: if (depilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
614: &s_objet_argument_2) == d_erreur)
615: {
616: liberation(s_etat_processus, s_objet_argument_1);
617:
618: (*s_etat_processus).erreur_execution = d_ex_manque_argument;
619: return;
620: }
621:
622: if (((*s_objet_argument_2).type == INT) &&
623: (((*s_objet_argument_1).type == REL) ||
624: ((*s_objet_argument_1).type == INT)))
625: {
626: n = (integer4) (*((integer8 *) (*s_objet_argument_2).objet));
627:
628: if (n <= 0)
629: {
630: liberation(s_etat_processus, s_objet_argument_1);
631: liberation(s_etat_processus, s_objet_argument_2);
632:
633: (*s_etat_processus).erreur_execution = d_ex_argument_invalide;
634: return;
635: }
636:
637: if ((s_objet_resultat = allocation(s_etat_processus, REL))
638: == NULL)
639: {
640: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
641: return;
642: }
643:
644: if ((*s_objet_argument_1).type == INT)
645: {
646: x = (real8) (*((integer8 *) (*s_objet_argument_1).objet));
647: }
648: else
649: {
650: x = (*((real8 *) (*s_objet_argument_1).objet));
651: }
652:
653: f90tcd(&x, &n, (real8 *) (*s_objet_resultat).objet);
654: }
655: else
656: {
657: liberation(s_etat_processus, s_objet_argument_1);
658: liberation(s_etat_processus, s_objet_argument_2);
659:
660: (*s_etat_processus).erreur_execution = d_ex_erreur_type_argument;
661: return;
662: }
663:
664: liberation(s_etat_processus, s_objet_argument_1);
665: liberation(s_etat_processus, s_objet_argument_2);
666:
667: if (empilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
668: s_objet_resultat) == d_erreur)
669: {
670: return;
671: }
672:
673: return;
674: }
675:
676:
677: /*
678: ================================================================================
679: Fonction 'use'
680: ================================================================================
681: Entrées : pointeur sur une structure struct_processus
682: --------------------------------------------------------------------------------
683: Sorties :
684: --------------------------------------------------------------------------------
685: Effets de bord : néant
686: ================================================================================
687: */
688:
689: void
690: instruction_use(struct_processus *s_etat_processus)
691: {
692: logical1 erreur;
693: logical1 existence;
694: logical1 ouverture;
695:
696: struct_objet *s_objet_argument;
697: struct_objet *s_objet_resultat;
698:
699: unsigned char *tampon;
700:
701: unsigned long unite;
702:
703: void *bibliotheque;
704:
705: (*s_etat_processus).erreur_execution = d_ex;
706:
707: if ((*s_etat_processus).affichage_arguments == 'Y')
708: {
709: printf("\n USE ");
710:
711: if ((*s_etat_processus).langue == 'F')
712: {
713: printf("(insertion d'une bibliothèque dynamique)\n\n");
714: printf("Si le chemin ne comprend pas de '/', la bibliothèque "
715: "est recherchée\n");
716: printf("successivement dans le répertoire courant puis dans %s."
717: "\n\n", d_exec_path);
718: }
719: else
720: {
721: printf("(insert a shared library)\n\n");
722: printf("If this path does not include '/', RPL/2 tries to find "
723: "it in current\n");
724: printf("directory or %s in this order.\n\n", d_exec_path);
725: }
726:
727: printf(" 1: %s\n", d_CHN);
728: printf("-> 1: %s\n", d_SLB);
729:
730: return;
731: }
732: else if ((*s_etat_processus).test_instruction == 'Y')
733: {
734: (*s_etat_processus).nombre_arguments = -1;
735: return;
736: }
737:
738: if (test_cfsf(s_etat_processus, 31) == d_vrai)
739: {
740: if (empilement_pile_last(s_etat_processus, 1) == d_erreur)
741: {
742: return;
743: }
744: }
745:
746: if (depilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
747: &s_objet_argument) == d_erreur)
748: {
749: (*s_etat_processus).erreur_execution = d_ex_manque_argument;
750: return;
751: }
752:
753: if ((*s_objet_argument).type == CHN)
754: {
755: /*
756: * Si le nom contient un '/', il est traité comme un chemin
757: * absolu. Dans le cas contraire, on essaye successivement
758: * './' puis le répertoire lib de l'installation du langage.
759: */
760:
761: if (index((unsigned char *) (*s_objet_argument).objet, '/') == NULL)
762: {
763: if ((tampon = malloc((strlen((unsigned char *) (*s_objet_argument)
764: .objet) + 3) * sizeof(unsigned char))) == NULL)
765: {
766: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
767: return;
768: }
769:
770: sprintf(tampon, "./%s", (unsigned char *)
771: (*s_objet_argument).objet);
772:
773: erreur = caracteristiques_fichier(s_etat_processus, tampon,
774: &existence, &ouverture, &unite);
775:
776: if (existence != d_faux)
777: {
778: free((unsigned char *) (*s_objet_argument).objet);
779: (*s_objet_argument).objet = tampon;
780: }
781: else
782: {
783: free(tampon);
784:
1.5 bertrand 785: if ((*s_etat_processus).rpl_home == NULL)
1.1 bertrand 786: {
1.5 bertrand 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);
1.1 bertrand 798: }
1.5 bertrand 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: }
1.1 bertrand 810:
1.5 bertrand 811: sprintf(tampon, "/%s/lib/%s", (*s_etat_processus).rpl_home,
812: (unsigned char *) (*s_objet_argument).objet);
813: }
1.1 bertrand 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: {
1.6 bertrand 1080: struct flock lock;
1.1 bertrand 1081:
1.6 bertrand 1082: struct_descripteur_fichier *descripteur;
1.1 bertrand 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:
1.6 bertrand 1140: if (fcntl(fileno((*descripteur).descripteur_c), F_SETLK, &lock)
1141: == -1)
1.1 bertrand 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).s_liste_variables[(*s_etat_processus)
1233: .position_variable_courante]).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).s_liste_variables[(*s_etat_processus)
1261: .position_variable_courante]).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
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