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