Annotation of rpl/src/instructions_r3.c, revision 1.78
1.1 bertrand 1: /*
2: ================================================================================
1.77 bertrand 3: RPL/2 (R) version 4.1.32
1.78 ! 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.14 bertrand 23: #include "rpl-conv.h"
1.1 bertrand 24:
25:
26: /*
27: ================================================================================
28: Fonction 'rsd'
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_rsd(struct_processus *s_etat_processus)
40: {
41: struct_liste_chainee *l_element_courant;
42: struct_liste_chainee *registre_pile_last;
43:
44: (*s_etat_processus).erreur_execution = d_ex;
45:
46: if ((*s_etat_processus).affichage_arguments == 'Y')
47: {
48: printf("\n RSD ");
49:
50: if ((*s_etat_processus).langue == 'F')
51: {
52: printf("(calcul d'un tableau résiduel)\n\n");
53: }
54: else
55: {
56: printf("(compute a resudial array)\n\n");
57: }
58:
59: printf(" 3: %s, %s, %s\n", d_VIN, d_VRL, d_VCX);
60: printf(" 2: %s, %s, %s\n", d_MIN, d_MRL, d_MCX);
61: printf(" 1: %s, %s, %s\n", d_VIN, d_VRL, d_VCX);
62: printf("-> 1: %s, %s ,%s\n\n", d_VIN, d_VRL, d_VCX);
63:
64: printf(" 3: %s, %s, %s\n", d_MIN, d_MRL, d_MCX);
65: printf(" 2: %s, %s, %s\n", d_MIN, d_MRL, d_MCX);
66: printf(" 1: %s, %s, %s\n", d_MIN, d_MRL, d_MCX);
67: printf("-> 1: %s, %s, %s\n", d_MIN, d_MRL, d_MCX);
68:
69: return;
70: }
71: else if ((*s_etat_processus).test_instruction == 'Y')
72: {
73: (*s_etat_processus).nombre_arguments = -1;
74: return;
75: }
76:
77: /*
78: * Test du type et du nombre des arguments
79: */
80:
81: if ((*s_etat_processus).hauteur_pile_operationnelle < 3)
82: {
83: (*s_etat_processus).erreur_execution = d_ex_manque_argument;
84: return;
85: }
86:
87: l_element_courant = (*s_etat_processus).l_base_pile;
88:
89: if (((*(*l_element_courant).donnee).type != VIN) &&
90: ((*(*l_element_courant).donnee).type != VRL) &&
91: ((*(*l_element_courant).donnee).type != VCX) &&
92: ((*(*l_element_courant).donnee).type != MIN) &&
93: ((*(*l_element_courant).donnee).type != MRL) &&
94: ((*(*l_element_courant).donnee).type != MCX))
95: {
96: (*s_etat_processus).erreur_execution = d_ex_erreur_type_argument;
97: return;
98: }
99:
100: l_element_courant = (*l_element_courant).suivant;
101:
102: if (((*(*l_element_courant).donnee).type != MIN) &&
103: ((*(*l_element_courant).donnee).type != MRL) &&
104: ((*(*l_element_courant).donnee).type != MCX))
105: {
106: (*s_etat_processus).erreur_execution = d_ex_erreur_type_argument;
107: return;
108: }
109:
110: l_element_courant = (*l_element_courant).suivant;
111:
112: if (((*(*l_element_courant).donnee).type != VIN) &&
113: ((*(*l_element_courant).donnee).type != VRL) &&
114: ((*(*l_element_courant).donnee).type != VCX) &&
115: ((*(*l_element_courant).donnee).type != MIN) &&
116: ((*(*l_element_courant).donnee).type != MRL) &&
117: ((*(*l_element_courant).donnee).type != MCX))
118: {
119: (*s_etat_processus).erreur_execution = d_ex_erreur_type_argument;
120: return;
121: }
122:
123: /*
124: * Sauvegarde de la pile LAST courante
125: */
126:
127: registre_pile_last = NULL;
128:
129: if (test_cfsf(s_etat_processus, 31) == d_vrai)
130: {
131: if (empilement_pile_last(s_etat_processus, 3) == d_erreur)
132: {
133: return;
134: }
135:
136: registre_pile_last = (*s_etat_processus).l_base_pile_last;
137: (*s_etat_processus).l_base_pile_last = NULL;
138: }
139:
140: instruction_multiplication(s_etat_processus);
141:
142: if (((*s_etat_processus).erreur_systeme != d_es) ||
143: ((*s_etat_processus).erreur_execution != d_ex) ||
144: ((*s_etat_processus).exception != d_ep))
145: {
146: if (test_cfsf(s_etat_processus, 31) == d_vrai)
147: {
148: if (empilement_pile_last(s_etat_processus, 0) == d_erreur)
149: {
150: return;
151: }
152: }
153:
154: (*s_etat_processus).l_base_pile_last = registre_pile_last;
155:
156: return;
157: }
158:
159: instruction_moins(s_etat_processus);
160:
161: /*
162: * Restauration de la pile LAST
163: */
164:
165: if (test_cfsf(s_etat_processus, 31) == d_vrai)
166: {
167: /*
168: * Astuce pour libérer l'ancienne pile last...
169: */
170:
171: if (empilement_pile_last(s_etat_processus, 0) == d_erreur)
172: {
173: return;
174: }
175:
176: (*s_etat_processus).l_base_pile_last = registre_pile_last;
177: }
178:
179: return;
180: }
181:
182:
183: /*
184: ================================================================================
185: Fonction 'regv'
186: ================================================================================
187: Entrées : pointeur sur une structure struct_processus
188: --------------------------------------------------------------------------------
189: Sorties :
190: --------------------------------------------------------------------------------
191: Effets de bord : néant
192: ================================================================================
193: */
194:
195: void
196: instruction_regv(struct_processus *s_etat_processus)
197: {
198: struct_objet *s_objet_argument;
199: struct_objet *s_objet_resultat_1;
200: struct_objet *s_objet_resultat_2;
201:
202: (*s_etat_processus).erreur_execution = d_ex;
203:
204: if ((*s_etat_processus).affichage_arguments == 'Y')
205: {
206: printf("\n REGV ");
207:
208: if ((*s_etat_processus).langue == 'F')
209: {
210: printf("(valeurs et vecteurs propres droits)\n\n");
211: }
212: else
213: {
214: printf("(eigenvalues and right eigenvectors)\n\n");
215: }
216:
217: printf(" 1: %s, %s, %s\n", d_MIN, d_MRL, d_MCX);
218: printf("-> 2: %s\n", d_MCX);
219: printf(" 1: %s\n", d_VCX);
220:
221: return;
222: }
223: else if ((*s_etat_processus).test_instruction == 'Y')
224: {
225: (*s_etat_processus).nombre_arguments = -1;
226: return;
227: }
228:
229: if (test_cfsf(s_etat_processus, 31) == d_vrai)
230: {
231: if (empilement_pile_last(s_etat_processus, 1) == d_erreur)
232: {
233: return;
234: }
235: }
236:
237: if (depilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
238: &s_objet_argument) == d_erreur)
239: {
240: (*s_etat_processus).erreur_execution = d_ex_manque_argument;
241: return;
242: }
243:
244: /*
245: --------------------------------------------------------------------------------
246: L'argument est une matrice carrée
247: --------------------------------------------------------------------------------
248: */
249:
250: if (((*s_objet_argument).type == MIN) ||
251: ((*s_objet_argument).type == MRL) ||
252: ((*s_objet_argument).type == MCX))
253: {
254: if ((*((struct_matrice *) (*s_objet_argument).objet)).nombre_lignes !=
255: (*((struct_matrice *) (*s_objet_argument).objet))
256: .nombre_colonnes)
257: {
258: liberation(s_etat_processus, s_objet_argument);
259:
260: (*s_etat_processus).erreur_execution = d_ex_dimensions_invalides;
261: return;
262: }
263:
264: if ((s_objet_resultat_1 = allocation(s_etat_processus, VCX)) == NULL)
265: {
266: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
267: return;
268: }
269:
270: if ((s_objet_resultat_2 = allocation(s_etat_processus, MCX)) == NULL)
271: {
272: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
273: return;
274: }
275:
276: valeurs_propres(s_etat_processus,
277: (struct_matrice *) (*s_objet_argument).objet,
278: (struct_vecteur *) (*s_objet_resultat_1).objet,
279: NULL, (struct_matrice *) (*s_objet_resultat_2).objet);
280:
281: if ((*s_etat_processus).erreur_systeme != d_es)
282: {
283: return;
284: }
285:
286: if (((*s_etat_processus).exception != d_ep) ||
287: ((*s_etat_processus).erreur_execution != d_ex))
288: {
289: liberation(s_etat_processus, s_objet_argument);
290: liberation(s_etat_processus, s_objet_resultat_1);
291: liberation(s_etat_processus, s_objet_resultat_2);
292: return;
293: }
294: }
295:
296: /*
297: --------------------------------------------------------------------------------
298: Type incompatible
299: --------------------------------------------------------------------------------
300: */
301:
302: else
303: {
304: liberation(s_etat_processus, s_objet_argument);
305:
306: (*s_etat_processus).erreur_execution = d_ex_erreur_type_argument;
307: return;
308: }
309:
310: liberation(s_etat_processus, s_objet_argument);
311:
312: if (empilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
313: s_objet_resultat_2) == d_erreur)
314: {
315: return;
316: }
317:
318: if (empilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
319: s_objet_resultat_1) == d_erreur)
320: {
321: return;
322: }
323:
324: return;
325: }
326:
327:
328: /*
329: ================================================================================
330: Fonction 'rnrm'
331: ================================================================================
332: Entrées : pointeur sur une structure struct_processus
333: --------------------------------------------------------------------------------
334: Sorties :
335: --------------------------------------------------------------------------------
336: Effets de bord : néant
337: ================================================================================
338: */
339:
340: void
341: instruction_rnrm(struct_processus *s_etat_processus)
342: {
343: logical1 depassement;
344: logical1 erreur_memoire;
345:
346: real8 cumul_reel;
347: real8 registre;
348:
349: integer8 cumul_entier;
350: integer8 entier_courant;
351: integer8 tampon;
352:
353: struct_objet *s_objet_argument;
354: struct_objet *s_objet_resultat;
355:
1.51 bertrand 356: integer8 i;
357: integer8 j;
1.1 bertrand 358:
359: void *accumulateur;
360:
361: (*s_etat_processus).erreur_execution = d_ex;
362:
363: if ((*s_etat_processus).affichage_arguments == 'Y')
364: {
365: printf("\n RNRM ");
366:
367: if ((*s_etat_processus).langue == 'F')
368: {
369: printf("(norme de ligne)\n\n");
370: }
371: else
372: {
373: printf("(row norm)\n\n");
374: }
375:
376: printf(" 1: %s, %s\n", d_VIN, d_MIN);
377: printf("-> 1: %s, %s\n\n", d_INT, d_REL);
378:
379: printf(" 1: %s, %s, %s, %s\n", d_VRL, d_VCX, d_MRL, d_MCX);
380: printf("-> 1: %s\n", d_REL);
381:
382: return;
383: }
384: else if ((*s_etat_processus).test_instruction == 'Y')
385: {
386: (*s_etat_processus).nombre_arguments = -1;
387: return;
388: }
389:
390: if (test_cfsf(s_etat_processus, 31) == d_vrai)
391: {
392: if (empilement_pile_last(s_etat_processus, 1) == d_erreur)
393: {
394: return;
395: }
396: }
397:
398: if (depilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
399: &s_objet_argument) == d_erreur)
400: {
401: (*s_etat_processus).erreur_execution = d_ex_manque_argument;
402: return;
403: }
404:
405: /*
406: --------------------------------------------------------------------------------
407: Traitement des vecteurs
408: --------------------------------------------------------------------------------
409: */
410:
411: if ((*s_objet_argument).type == VIN)
412: {
1.50 bertrand 413: depassement = d_faux;
414:
415: for(i = 0; i < (*((struct_vecteur *) (*s_objet_argument).objet)).taille;
416: i++)
1.1 bertrand 417: {
1.50 bertrand 418: if (((integer8 *) (*((struct_vecteur *) (*s_objet_argument)
419: .objet)).tableau)[i] == INT64_MIN)
420: {
421: depassement = d_vrai;
422: break;
423: }
1.1 bertrand 424: }
425:
1.50 bertrand 426: if (depassement == d_faux)
427: {
428: if ((s_objet_resultat = allocation(s_etat_processus, INT)) == NULL)
429: {
430: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
431: return;
432: }
1.1 bertrand 433:
1.50 bertrand 434: (*((integer8 *) (*s_objet_resultat).objet)) = abs(((integer8 *)
435: (*((struct_vecteur *) (*s_objet_argument).objet))
436: .tableau)[0]);
437:
438: for(i = 1; i < (*((struct_vecteur *) (*s_objet_argument).objet))
439: .taille; i++)
440: {
441: if (abs(((integer8 *) (*((struct_vecteur *) (*s_objet_argument)
442: .objet)).tableau)[i]) > (*((integer8 *)
443: (*s_objet_resultat).objet)))
444: {
445: (*((integer8 *) (*s_objet_resultat).objet)) =
446: abs(((integer8 *) (*((struct_vecteur *)
447: (*s_objet_argument).objet)).tableau)[i]);
448: }
449: }
450: }
451: else
1.1 bertrand 452: {
1.50 bertrand 453: if ((s_objet_resultat = allocation(s_etat_processus, REL)) == NULL)
1.1 bertrand 454: {
1.50 bertrand 455: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
456: return;
457: }
458:
459: (*((real8 *) (*s_objet_resultat).objet)) = abs((real8) ((integer8 *)
460: (*((struct_vecteur *) (*s_objet_argument).objet))
461: .tableau)[0]);
462:
463: for(i = 1; i < (*((struct_vecteur *) (*s_objet_argument).objet))
464: .taille; i++)
465: {
466: if (abs((real8) ((integer8 *) (*((struct_vecteur *)
467: (*s_objet_argument).objet)).tableau)[i]) > (*((real8 *)
468: (*s_objet_resultat).objet)))
469: {
470: (*((real8 *) (*s_objet_resultat).objet)) =
471: abs((real8) ((integer8 *) (*((struct_vecteur *)
472: (*s_objet_argument).objet)).tableau)[i]);
473: }
1.1 bertrand 474: }
475: }
476: }
477: else if ((*s_objet_argument).type == VRL)
478: {
479: if ((s_objet_resultat = allocation(s_etat_processus, REL)) == NULL)
480: {
481: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
482: return;
483: }
484:
485: (*((real8 *) (*s_objet_resultat).objet)) = fabs(((real8 *)
486: (*((struct_vecteur *) (*s_objet_argument).objet)).tableau)[0]);
487:
488: for(i = 1; i < (*((struct_vecteur *) (*s_objet_argument).objet)).taille;
489: i++)
490: {
491: if (fabs(((real8 *) (*((struct_vecteur *) (*s_objet_argument)
492: .objet)).tableau)[i]) > (*((real8 *)
493: (*s_objet_resultat).objet)))
494: {
495: (*((real8 *) (*s_objet_resultat).objet)) =
496: fabs(((real8 *) (*((struct_vecteur *)
497: (*s_objet_argument).objet)).tableau)[i]);
498: }
499: }
500: }
501: else if ((*s_objet_argument).type == VCX)
502: {
503: if ((s_objet_resultat = allocation(s_etat_processus, REL)) == NULL)
504: {
505: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
506: return;
507: }
508:
509: f77absc_(&(((struct_complexe16 *) (*((struct_vecteur *)
510: (*s_objet_argument).objet)).tableau)[0]), (real8 *)
511: (*s_objet_resultat).objet);
512:
513: for(i = 1; i < (*((struct_vecteur *) (*s_objet_argument).objet)).taille;
514: i++)
515: {
516: f77absc_(&(((struct_complexe16 *) (*((struct_vecteur *)
517: (*s_objet_argument).objet)).tableau)[i]), ®istre);
518:
519: if (registre > (*((real8 *) (*s_objet_resultat).objet)))
520: {
521: (*((real8 *) (*s_objet_resultat).objet)) = registre;
522: }
523: }
524: }
525:
526: /*
527: --------------------------------------------------------------------------------
528: Traitement des matrices
529: --------------------------------------------------------------------------------
530: */
531:
532: else if ((*s_objet_argument).type == MIN)
533: {
534: if ((s_objet_resultat = allocation(s_etat_processus, INT)) == NULL)
535: {
536: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
537: return;
538: }
539:
540: cumul_entier = 0;
541: depassement = d_faux;
542:
543: for(j = 0; j < (*((struct_matrice *) (*s_objet_argument).objet))
544: .nombre_colonnes; j++)
545: {
1.50 bertrand 546: if (((integer8 **) (*((struct_matrice *) (*s_objet_argument).objet))
547: .tableau)[0][j] == INT64_MIN)
548: {
549: depassement = d_vrai;
550: break;
551: }
552:
1.1 bertrand 553: entier_courant = abs(((integer8 **)
554: (*((struct_matrice *) (*s_objet_argument).objet))
555: .tableau)[0][j]);
556:
557: if (depassement_addition(&cumul_entier, &entier_courant, &tampon)
558: == d_erreur)
559: {
560: depassement = d_vrai;
561: break;
562: }
563: }
564:
565: if (depassement == d_faux)
566: {
567: (*((integer8 *) (*s_objet_resultat).objet)) = cumul_entier;
568:
569: for(i = 1; i < (*((struct_matrice *) (*s_objet_argument).objet))
570: .nombre_lignes; i++)
571: {
572: cumul_entier = 0;
573:
574: for(j = 0; j < (*((struct_matrice *) (*s_objet_argument).objet))
575: .nombre_colonnes; j++)
576: {
1.50 bertrand 577: if (((integer8 **) (*((struct_matrice *)
578: (*s_objet_argument).objet)).tableau)[i][j]
579: == INT64_MIN)
580: {
581: depassement = d_vrai;
582: break;
583: }
584:
1.1 bertrand 585: entier_courant = abs(((integer8 **) (*((struct_matrice *)
586: (*s_objet_argument).objet)).tableau)[i][j]);
587:
588: if (depassement_addition(&cumul_entier, &entier_courant,
589: &tampon) == d_erreur)
590: {
591: depassement = d_vrai;
592: break;
593: }
594:
595: cumul_entier = tampon;
596: }
597:
598: if (depassement == d_vrai)
599: {
600: break;
601: }
602:
603: if (cumul_entier > (*((integer8 *) (*s_objet_resultat).objet)))
604: {
605: (*((integer8 *) (*s_objet_resultat).objet)) = cumul_entier;
606: }
607: }
608: }
609:
610: if (depassement == d_vrai)
611: {
612: /*
613: * Dépassement : il faut refaire le calcul en real*8...
614: */
615:
616: free((*s_objet_resultat).objet);
617: (*s_objet_resultat).type = REL;
618:
619: if (((*s_objet_resultat).objet = malloc(sizeof(real8))) == NULL)
620: {
621: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
622: return;
623: }
624:
1.51 bertrand 625: if ((accumulateur = malloc(((size_t) (*((struct_matrice *)
626: (*s_objet_argument).objet)).nombre_colonnes) *
1.1 bertrand 627: sizeof(real8))) == NULL)
628: {
629: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
630: return;
631: }
632:
633: (*((real8 *) (*s_objet_resultat).objet)) = 0;
634:
635: for(i = 0; i < (*((struct_matrice *) (*s_objet_argument).objet))
636: .nombre_lignes; i++)
637: {
638: for(j = 0; j < (*((struct_matrice *) (*s_objet_argument).objet))
639: .nombre_colonnes; j++)
640: {
641: ((real8 *) accumulateur)[j] = fabs((real8) ((integer8 **)
642: (*((struct_matrice *) (*s_objet_argument).objet))
643: .tableau)[i][j]);
644: }
645:
646: cumul_reel = sommation_vecteur_reel(accumulateur,
647: &((*((struct_matrice *) (*s_objet_argument).objet))
648: .nombre_colonnes), &erreur_memoire);
649:
650: if (erreur_memoire == d_vrai)
651: {
652: (*s_etat_processus).erreur_systeme =
653: d_es_allocation_memoire;
654: return;
655: }
656:
657: if (cumul_reel > (*((real8 *) (*s_objet_resultat).objet)))
658: {
659: (*((real8 *) (*s_objet_resultat).objet)) = cumul_reel;
660: }
661: }
662:
663: free(accumulateur);
664: }
665: }
666: else if ((*s_objet_argument).type == MRL)
667: {
668: if ((s_objet_resultat = allocation(s_etat_processus, REL)) == NULL)
669: {
670: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
671: return;
672: }
673:
1.51 bertrand 674: if ((accumulateur = malloc(((size_t) (*((struct_matrice *)
675: (*s_objet_argument).objet)).nombre_colonnes) * sizeof(real8)))
1.1 bertrand 676: == NULL)
677: {
678: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
679: return;
680: }
681:
682: (*((real8 *) (*s_objet_resultat).objet)) = 0;
683:
684: for(i = 0; i < (*((struct_matrice *) (*s_objet_argument).objet))
685: .nombre_lignes; i++)
686: {
687: for(j = 0; j < (*((struct_matrice *) (*s_objet_argument).objet))
688: .nombre_colonnes; j++)
689: {
690: ((real8 *) accumulateur)[j] = fabs(((real8 **)
691: (*((struct_matrice *) (*s_objet_argument).objet))
692: .tableau)[i][j]);
693: }
694:
695: cumul_reel = sommation_vecteur_reel(accumulateur,
696: &((*((struct_matrice *) (*s_objet_argument).objet))
697: .nombre_colonnes), &erreur_memoire);
698:
699: if (erreur_memoire == d_vrai)
700: {
701: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
702: return;
703: }
704:
705: if (cumul_reel > (*((real8 *) (*s_objet_resultat).objet)))
706: {
707: (*((real8 *) (*s_objet_resultat).objet)) = cumul_reel;
708: }
709: }
710:
711: free(accumulateur);
712: }
713: else if ((*s_objet_argument).type == MCX)
714: {
715: if ((s_objet_resultat = allocation(s_etat_processus, REL)) == NULL)
716: {
717: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
718: return;
719: }
720:
1.51 bertrand 721: if ((accumulateur = malloc(((size_t) (*((struct_matrice *)
722: (*s_objet_argument).objet)).nombre_colonnes) * sizeof(real8)))
1.1 bertrand 723: == NULL)
724: {
725: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
726: return;
727: }
728:
729: (*((real8 *) (*s_objet_resultat).objet)) = 0;
730:
731: for(i = 0; i < (*((struct_matrice *) (*s_objet_argument).objet))
732: .nombre_lignes; i++)
733: {
734: for(j = 0; j < (*((struct_matrice *) (*s_objet_argument).objet))
735: .nombre_colonnes; j++)
736: {
737: f77absc_(&(((struct_complexe16 **) (*((struct_matrice *)
738: (*s_objet_argument).objet)).tableau)[i][j]),
739: &(((real8 *) accumulateur)[j]));
740: }
741:
742: cumul_reel = sommation_vecteur_reel(accumulateur,
743: &((*((struct_matrice *) (*s_objet_argument).objet))
744: .nombre_colonnes), &erreur_memoire);
745:
746: if (erreur_memoire == d_vrai)
747: {
748: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
749: return;
750: }
751:
752: if (cumul_reel > (*((real8 *) (*s_objet_resultat).objet)))
753: {
754: (*((real8 *) (*s_objet_resultat).objet)) = cumul_reel;
755: }
756: }
757:
758: free(accumulateur);
759: }
760: /*
761: --------------------------------------------------------------------------------
762: Traitement impossible du fait du type de l'argument
763: --------------------------------------------------------------------------------
764: */
765:
766: else
767: {
768: liberation(s_etat_processus, s_objet_argument);
769:
770: (*s_etat_processus).erreur_execution = d_ex_erreur_type_argument;
771: return;
772: }
773:
774: if (empilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
775: s_objet_resultat) == d_erreur)
776: {
777: return;
778: }
779:
780: liberation(s_etat_processus, s_objet_argument);
781:
782: return;
783: }
784:
785:
786: /*
787: ================================================================================
788: Fonction 'rceq'
789: ================================================================================
790: Entrées : pointeur sur une structure struct_processus
791: --------------------------------------------------------------------------------
792: Sorties :
793: --------------------------------------------------------------------------------
794: Effets de bord : néant
795: ================================================================================
796: */
797:
798: void
799: instruction_rceq(struct_processus *s_etat_processus)
800: {
801: struct_objet *s_objet_variable;
802:
803: (*s_etat_processus).erreur_execution = d_ex;
804:
805: if ((*s_etat_processus).affichage_arguments == 'Y')
806: {
807: printf("\n RCEQ ");
808:
809: if ((*s_etat_processus).langue == 'F')
810: {
811: printf("(rappel de la variable EQ)\n\n");
812: }
813: else
814: {
815: printf("(recall EQ variable)\n\n");
816: }
817:
818: printf("-> 1: %s, %s, %s, %s, %s, %s,\n"
819: " %s, %s, %s, %s, %s,\n"
820: " %s, %s, %s, %s, %s,\n"
821: " %s, %s, %s, %s,\n"
1.73 bertrand 822: " %s, %s, %s\n",
1.1 bertrand 823: d_INT, d_REL, d_CPL, d_VIN, d_VRL, d_VCX, d_MIN, d_MRL, d_MCX,
824: d_TAB, d_BIN, d_NOM, d_CHN, d_LST, d_ALG, d_RPN, d_FCH, d_SCK,
1.73 bertrand 825: d_SQL, d_SLB, d_PRC, d_MTX, d_REC);
1.1 bertrand 826:
827: return;
828: }
829: else if ((*s_etat_processus).test_instruction == 'Y')
830: {
831: (*s_etat_processus).nombre_arguments = -1;
832: return;
833: }
834:
835: if (test_cfsf(s_etat_processus, 31) == d_vrai)
836: {
837: if (empilement_pile_last(s_etat_processus, 0) == d_erreur)
838: {
839: return;
840: }
841: }
842:
1.26 bertrand 843: if (recherche_variable_globale(s_etat_processus, "EQ") == d_faux)
1.1 bertrand 844: {
1.26 bertrand 845: (*s_etat_processus).erreur_systeme = d_es;
1.1 bertrand 846:
1.26 bertrand 847: if ((*s_etat_processus).erreur_execution == d_ex)
1.1 bertrand 848: {
849: (*s_etat_processus).erreur_execution = d_ex_variable_non_definie;
850: }
851:
852: return;
853: }
854:
855: if ((s_objet_variable = copie_objet(s_etat_processus,
1.26 bertrand 856: (*(*s_etat_processus).pointeur_variable_courante).objet, 'P'))
1.1 bertrand 857: == NULL)
858: {
859: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
860: return;
861: }
862:
863: if (empilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
864: s_objet_variable) == d_erreur)
865: {
866: return;
867: }
868:
869: return;
870: }
871:
872:
873: /*
874: ================================================================================
875: Fonction 'res'
876: ================================================================================
877: Entrées : pointeur sur une structure struct_processus
878: --------------------------------------------------------------------------------
879: Sorties :
880: --------------------------------------------------------------------------------
881: Effets de bord : néant
882: ================================================================================
883: */
884:
885: void
886: instruction_res(struct_processus *s_etat_processus)
887: {
888: struct_objet *s_objet;
889:
890: (*s_etat_processus).erreur_execution = d_ex;
891:
892: if ((*s_etat_processus).affichage_arguments == 'Y')
893: {
894: printf("\n RES ");
895:
896: if ((*s_etat_processus).langue == 'F')
897: {
898: printf("(résolution)\n\n");
899: }
900: else
901: {
902: printf("(resolution)\n\n");
903: }
904:
905: printf(" 1: %s, %s\n", d_INT, d_REL);
906:
907: return;
908: }
909: else if ((*s_etat_processus).test_instruction == 'Y')
910: {
911: (*s_etat_processus).nombre_arguments = -1;
912: return;
913: }
914:
915: if (test_cfsf(s_etat_processus, 31) == d_vrai)
916: {
917: if (empilement_pile_last(s_etat_processus, 1) == d_erreur)
918: {
919: return;
920: }
921: }
922:
923: if (depilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
924: &s_objet) == d_erreur)
925: {
926: (*s_etat_processus).erreur_execution = d_ex_manque_argument;
927: return;
928: }
929:
930: if ((*s_objet).type == INT)
931: {
932: if ((*((integer8 *) (*s_objet).objet)) <= 0)
933: {
934: liberation(s_etat_processus, s_objet);
935:
936: (*s_etat_processus).erreur_execution = d_ex_erreur_type_argument;
937: return;
938: }
939:
940: (*s_etat_processus).resolution = (real8) (*((integer8 *)
941: (*s_objet).objet));
942: }
943: else if ((*s_objet).type == REL)
944: {
945: if ((*((real8 *) (*s_objet).objet)) <= 0)
946: {
947: liberation(s_etat_processus, s_objet);
948:
949: (*s_etat_processus).erreur_execution = d_ex_argument_invalide;
950: return;
951: }
952:
953: (*s_etat_processus).resolution = (*((real8 *) (*s_objet).objet));
954: }
955: else
956: {
957: liberation(s_etat_processus, s_objet);
958:
959: (*s_etat_processus).erreur_execution = d_ex_erreur_type_argument;
960: return;
961: }
962:
963: liberation(s_etat_processus, s_objet);
964: return;
965: }
966:
967:
968: /*
969: ================================================================================
970: Fonction 'recall'
971: ================================================================================
972: Entrées : pointeur sur une structure struct_processus
973: --------------------------------------------------------------------------------
974: Sorties :
975: --------------------------------------------------------------------------------
976: Effets de bord : néant
977: ================================================================================
978: */
979:
980: void
981: instruction_recall(struct_processus *s_etat_processus)
982: {
983: file *pipe;
984: file *fichier;
985:
986: int caractere;
987: int ios;
988:
1.7 bertrand 989: logical1 drapeau_fin;
990: logical1 indicateur_48;
991: logical1 presence_chaine;
992:
1.1 bertrand 993: long i;
994: long nombre_caracteres_source;
995:
996: struct_objet *s_objet;
997:
1.7 bertrand 998: unsigned char autorisation_empilement_programme;
999: unsigned char *chaine;
1.1 bertrand 1000: unsigned char *commande;
1.6 bertrand 1001: unsigned char *executable_candidat;
1.16 bertrand 1002:
1003: # ifndef OS2
1.1 bertrand 1004: unsigned char *instructions = "%s/bin/rpliconv %s "
1005: "`%s/bin/rplfile "
1.18 bertrand 1006: "-m %s/share/rplfiles -i %s | "
1007: "%s/bin/rplawk "
1008: "'{ print $3; }' | %s/bin/rplawk -F= '{ if "
1.1 bertrand 1009: "($2 != \"\") printf(\"-f %%s\", $2); }'` "
1010: "-t `locale charmap` | %s/bin/%s -o %s";
1.16 bertrand 1011: # else
1.20 bertrand 1012: unsigned char *instructions = BOURNE_SHELL
1013: " -c \"%s/bin/rpliconv %s "
1.16 bertrand 1014: "`%s/bin/rplfile "
1.18 bertrand 1015: "-m %s/share/rplfiles -i %s | "
1016: "%s/bin/rplawk "
1017: "'{ print $3; }' | %s/bin/rplawk -F= '{ if "
1.16 bertrand 1018: "($2 != \\\"\\\") printf(\\\"-f %%s\\\", "
1019: "$2); }'` -t `" d_locale
1020: "` | %s/bin/%s -o %s\"";
1021: # endif
1022:
1.1 bertrand 1023: unsigned char *nom_fichier_temporaire;
1.7 bertrand 1024: unsigned char *tampon_definitions_chainees;
1025: unsigned char *tampon_instruction_courante;
1026:
1.51 bertrand 1027: integer8 position_courante;
1.1 bertrand 1028:
1029: (*s_etat_processus).erreur_execution = d_ex;
1030:
1031: if ((*s_etat_processus).affichage_arguments == 'Y')
1032: {
1033: printf("\n RECALL ");
1034:
1035: if ((*s_etat_processus).langue == 'F')
1036: {
1037: printf("(rappel d'une variable stockée sur disque)\n\n");
1038: }
1039: else
1040: {
1041: printf("(recall a variable stored on disk)\n\n");
1042: }
1043:
1044: printf(" 1: %s\n", d_CHN);
1045: printf("-> 1: %s, %s, %s, %s, %s, %s,\n"
1046: " %s, %s, %s, %s, %s,\n"
1047: " %s, %s, %s, %s, %s\n",
1048: d_INT, d_REL, d_CPL, d_VIN, d_VRL, d_VCX, d_MIN, d_MRL, d_MCX,
1049: d_TAB, d_BIN, d_NOM, d_CHN, d_LST, d_ALG, d_RPN);
1050:
1051: return;
1052: }
1053: else if ((*s_etat_processus).test_instruction == 'Y')
1054: {
1055: (*s_etat_processus).nombre_arguments = -1;
1056: return;
1057: }
1058:
1059: if (test_cfsf(s_etat_processus, 31) == d_vrai)
1060: {
1061: if (empilement_pile_last(s_etat_processus, 1) == d_erreur)
1062: {
1063: return;
1064: }
1065: }
1066:
1067: if (depilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
1068: &s_objet) == d_erreur)
1069: {
1070: (*s_etat_processus).erreur_execution = d_ex_manque_argument;
1071: return;
1072: }
1073:
1074: if ((*s_objet).type == CHN)
1075: {
1076: if ((fichier = fopen((unsigned char *) (*s_objet).objet, "r")) == NULL)
1077: {
1078: liberation(s_etat_processus, s_objet);
1079:
1080: (*s_etat_processus).erreur_execution = d_ex_erreur_fichier;
1081: return;
1082: }
1083:
1084: if (fclose(fichier) != 0)
1085: {
1086: (*s_etat_processus).erreur_systeme = d_es_erreur_fichier;
1087: return;
1088: }
1089:
1090: if ((nom_fichier_temporaire = creation_nom_fichier(s_etat_processus,
1091: (*s_etat_processus).chemin_fichiers_temporaires)) == NULL)
1092: {
1093: (*s_etat_processus).erreur_systeme = d_es_erreur_fichier;
1094: return;
1095: }
1096:
1.5 bertrand 1097: if ((*s_etat_processus).rpl_home == NULL)
1.1 bertrand 1098: {
1.5 bertrand 1099: if ((commande = malloc((strlen(ds_preprocesseur) +
1100: (2 * strlen((unsigned char *) (*s_objet).objet)) +
1.18 bertrand 1101: (6 * strlen(d_exec_path)) +
1102: strlen(nom_fichier_temporaire) + strlen(instructions) - 19)
1.5 bertrand 1103: * sizeof(unsigned char))) == NULL)
1104: {
1105: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
1106: return;
1107: }
1108:
1109: sprintf(commande, instructions, d_exec_path,
1110: (unsigned char *) (*s_objet).objet,
1111: d_exec_path, d_exec_path,
1112: (unsigned char *) (*s_objet).objet,
1.18 bertrand 1113: d_exec_path, d_exec_path,
1.5 bertrand 1114: d_exec_path, ds_preprocesseur, nom_fichier_temporaire);
1.6 bertrand 1115:
1.62 bertrand 1116: if (alsprintf(s_etat_processus, &executable_candidat,
1117: "%s/bin/rpliconv", d_exec_path) < 0)
1.6 bertrand 1118: {
1119: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
1120: return;
1121: }
1122:
1.38 bertrand 1123: if (controle_integrite(s_etat_processus, executable_candidat,
1124: "rpliconv") != d_vrai)
1.6 bertrand 1125: {
1126: (*s_etat_processus).erreur_systeme = d_es_somme_controle;
1127: return;
1128: }
1129:
1130: free(executable_candidat);
1131:
1.62 bertrand 1132: if (alsprintf(s_etat_processus, &executable_candidat,
1133: "%s/bin/rplfile", d_exec_path) < 0)
1.6 bertrand 1134: {
1135: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
1136: return;
1137: }
1138:
1.38 bertrand 1139: if (controle_integrite(s_etat_processus, executable_candidat,
1140: "rplfile") != d_vrai)
1.6 bertrand 1141: {
1142: (*s_etat_processus).erreur_systeme = d_es_somme_controle;
1143: return;
1144: }
1145:
1146: free(executable_candidat);
1147:
1.62 bertrand 1148: if (alsprintf(s_etat_processus, &executable_candidat,
1149: "%s/bin/rplpp", d_exec_path) < 0)
1.6 bertrand 1150: {
1151: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
1152: return;
1153: }
1154:
1.38 bertrand 1155: if (controle_integrite(s_etat_processus, executable_candidat,
1156: "rplpp") != d_vrai)
1.6 bertrand 1157: {
1158: (*s_etat_processus).erreur_systeme = d_es_somme_controle;
1159: return;
1160: }
1161:
1162: free(executable_candidat);
1.18 bertrand 1163:
1.62 bertrand 1164: if (alsprintf(s_etat_processus, &executable_candidat,
1165: "%s/bin/rplawk", d_exec_path) < 0)
1.18 bertrand 1166: {
1167: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
1168: return;
1169: }
1170:
1.38 bertrand 1171: if (controle_integrite(s_etat_processus, executable_candidat,
1172: "rplawk") != d_vrai)
1.18 bertrand 1173: {
1174: (*s_etat_processus).erreur_systeme = d_es_somme_controle;
1175: return;
1176: }
1177:
1178: free(executable_candidat);
1.1 bertrand 1179: }
1.5 bertrand 1180: else
1181: {
1182: if ((commande = malloc((strlen(ds_preprocesseur) +
1183: (2 * strlen((unsigned char *) (*s_objet).objet)) +
1.18 bertrand 1184: (6 * strlen((*s_etat_processus).rpl_home)) +
1185: strlen(nom_fichier_temporaire) + strlen(instructions) - 19)
1.5 bertrand 1186: * sizeof(unsigned char))) == NULL)
1187: {
1188: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
1189: return;
1190: }
1.1 bertrand 1191:
1.5 bertrand 1192: sprintf(commande, instructions, (*s_etat_processus).rpl_home,
1193: (unsigned char *) (*s_objet).objet,
1194: (*s_etat_processus).rpl_home, (*s_etat_processus).rpl_home,
1195: (unsigned char *) (*s_objet).objet,
1.18 bertrand 1196: (*s_etat_processus).rpl_home, (*s_etat_processus).rpl_home,
1.5 bertrand 1197: (*s_etat_processus).rpl_home, ds_preprocesseur,
1198: nom_fichier_temporaire);
1.6 bertrand 1199:
1.62 bertrand 1200: if (alsprintf(s_etat_processus, &executable_candidat,
1201: "%s/bin/rpliconv", (*s_etat_processus).rpl_home) < 0)
1.6 bertrand 1202: {
1203: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
1204: return;
1205: }
1206:
1.38 bertrand 1207: if (controle_integrite(s_etat_processus, executable_candidat,
1208: "rpliconv") != d_vrai)
1.6 bertrand 1209: {
1210: (*s_etat_processus).erreur_systeme = d_es_somme_controle;
1211: return;
1212: }
1213:
1214: free(executable_candidat);
1215:
1.62 bertrand 1216: if (alsprintf(s_etat_processus, &executable_candidat,
1217: "%s/bin/rplfile", (*s_etat_processus).rpl_home) < 0)
1.6 bertrand 1218: {
1219: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
1220: return;
1221: }
1222:
1.38 bertrand 1223: if (controle_integrite(s_etat_processus, executable_candidat,
1224: "rplfile") != d_vrai)
1.6 bertrand 1225: {
1226: (*s_etat_processus).erreur_systeme = d_es_somme_controle;
1227: return;
1228: }
1229:
1230: free(executable_candidat);
1231:
1.62 bertrand 1232: if (alsprintf(s_etat_processus, &executable_candidat,
1233: "%s/bin/rplpp", (*s_etat_processus).rpl_home) < 0)
1.6 bertrand 1234: {
1235: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
1236: return;
1237: }
1238:
1.38 bertrand 1239: if (controle_integrite(s_etat_processus, executable_candidat,
1240: "rplpp") != d_vrai)
1.6 bertrand 1241: {
1242: (*s_etat_processus).erreur_systeme = d_es_somme_controle;
1243: return;
1244: }
1245:
1246: free(executable_candidat);
1.18 bertrand 1247:
1.62 bertrand 1248: if (alsprintf(s_etat_processus, &executable_candidat,
1249: "%s/bin/rplawk", d_exec_path) < 0)
1.18 bertrand 1250: {
1251: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
1252: return;
1253: }
1254:
1.38 bertrand 1255: if (controle_integrite(s_etat_processus, executable_candidat,
1256: "rplawk") != d_vrai)
1.18 bertrand 1257: {
1258: (*s_etat_processus).erreur_systeme = d_es_somme_controle;
1259: return;
1260: }
1261:
1262: free(executable_candidat);
1.5 bertrand 1263: }
1.1 bertrand 1264:
1265: if ((pipe = popen(commande, "r")) == NULL)
1266: {
1267: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
1268: return;
1269: }
1270:
1271: if ((ios = pclose(pipe)) != EXIT_SUCCESS)
1272: {
1273: liberation(s_etat_processus, s_objet);
1274: free(commande);
1275:
1276: (*s_etat_processus).erreur_execution = d_ex_erreur_fichier;
1277: return;
1278: }
1279: else if (ios == -1)
1280: {
1281: (*s_etat_processus).erreur_systeme = d_es_processus;
1282: return;
1283: }
1284:
1285: free(commande);
1286:
1287: nombre_caracteres_source = 0;
1288:
1289: if ((pipe = fopen(nom_fichier_temporaire, "r")) == NULL)
1290: {
1291: (*s_etat_processus).erreur_systeme = d_es_erreur_fichier;
1292: return;
1293: }
1294:
1295: while(getc(pipe) != EOF)
1296: {
1297: nombre_caracteres_source++;
1298: }
1299:
1300: if (nombre_caracteres_source == 0)
1301: {
1302: if (fclose(pipe) == -1)
1303: {
1304: (*s_etat_processus).erreur_systeme = d_es_processus;
1305: return;
1306: }
1307:
1308: liberation(s_etat_processus, s_objet);
1309:
1310: if (destruction_fichier(nom_fichier_temporaire) == d_erreur)
1311: {
1312: (*s_etat_processus).erreur_systeme = d_es_erreur_fichier;
1313: return;
1314: }
1315:
1316: free(nom_fichier_temporaire);
1317:
1318: (*s_etat_processus).erreur_execution = d_ex_fichier_vide;
1319: return;
1320: }
1321:
1.51 bertrand 1322: if ((chaine = malloc((((size_t) nombre_caracteres_source) + 1)
1.1 bertrand 1323: * sizeof(unsigned char))) == NULL)
1324: {
1325: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
1326: return;
1327: }
1328:
1329: rewind(pipe);
1330:
1331: i = 0;
1.7 bertrand 1332: drapeau_fin = d_faux;
1333: presence_chaine = d_faux;
1334:
1335: while(drapeau_fin == d_faux)
1.1 bertrand 1336: {
1.7 bertrand 1337: if ((caractere = getc(pipe)) != EOF)
1.1 bertrand 1338: {
1.7 bertrand 1339: if ((caractere == d_code_retour_chariot) ||
1340: (caractere == d_code_tabulation) ||
1341: ((caractere == d_code_espace) &&
1342: (presence_chaine == d_faux)))
1.1 bertrand 1343: {
1.7 bertrand 1344: do
1345: {
1346: caractere = getc(pipe);
1347: } while(((caractere == d_code_retour_chariot) ||
1348: (caractere == d_code_tabulation) ||
1349: ((caractere == d_code_espace) &&
1350: (presence_chaine == d_faux))) &&
1351: (caractere != EOF));
1352:
1353: if (caractere != EOF)
1354: {
1355: chaine[i++] = d_code_espace;
1356: }
1357: else
1358: {
1359: drapeau_fin = d_vrai;
1360: }
1361: }
1.1 bertrand 1362:
1.51 bertrand 1363: if ((chaine[i] = (unsigned char) caractere) == '\"')
1.1 bertrand 1364: {
1.7 bertrand 1365: if (i > 0)
1366: {
1367: if (chaine[i - 1] != '\\')
1368: {
1369: presence_chaine = (presence_chaine == d_faux)
1370: ? d_vrai : d_faux;
1371: }
1372: }
1373:
1374: i++;
1.1 bertrand 1375: }
1.7 bertrand 1376: else
1377: {
1378: i++;
1379: }
1380: }
1381: else
1382: {
1383: drapeau_fin = d_vrai;
1.1 bertrand 1384: }
1385: }
1386:
1.7 bertrand 1387: if ((caractere == EOF) && (i > 0))
1.1 bertrand 1388: {
1389: i--;
1390: }
1391:
1.7 bertrand 1392: chaine[i] = d_code_fin_chaine;
1.1 bertrand 1393:
1394: if (fclose(pipe) != 0)
1395: {
1396: (*s_etat_processus).erreur_systeme = d_es_erreur_fichier;
1397: return;
1398: }
1399:
1.7 bertrand 1400: indicateur_48 = test_cfsf(s_etat_processus, 48);
1401: cf(s_etat_processus, 48);
1402:
1403: tampon_definitions_chainees = (*s_etat_processus).definitions_chainees;
1404: tampon_instruction_courante = (*s_etat_processus).instruction_courante;
1405: position_courante = (*s_etat_processus).position_courante;
1406: autorisation_empilement_programme = (*s_etat_processus)
1407: .autorisation_empilement_programme;
1408:
1409: (*s_etat_processus).instruction_courante = NULL;
1410:
1411: if (((*s_etat_processus).definitions_chainees = transliteration(
1412: s_etat_processus, chaine, "UTF-8", d_locale)) == NULL)
1.1 bertrand 1413: {
1.7 bertrand 1414: if (indicateur_48 == d_vrai)
1415: {
1416: sf(s_etat_processus, 48);
1417: }
1418: else
1419: {
1420: cf(s_etat_processus, 48);
1421: }
1422:
1423: if (destruction_fichier(nom_fichier_temporaire) == d_erreur)
1424: {
1425: (*s_etat_processus).erreur_systeme = d_es_erreur_fichier;
1426: return;
1427: }
1428:
1.1 bertrand 1429: free(nom_fichier_temporaire);
1.7 bertrand 1430: free((*s_etat_processus).instruction_courante);
1431: free(chaine);
1432:
1433: (*s_etat_processus).position_courante = position_courante;
1434: (*s_etat_processus).instruction_courante =
1435: tampon_instruction_courante;
1436: (*s_etat_processus).definitions_chainees =
1437: tampon_definitions_chainees;
1438: (*s_etat_processus).autorisation_empilement_programme =
1439: autorisation_empilement_programme;
1440:
1441: liberation(s_etat_processus, s_objet);
1.1 bertrand 1442: return;
1443: }
1444:
1.7 bertrand 1445: (*s_etat_processus).autorisation_empilement_programme = 'Y';
1446: (*s_etat_processus).position_courante = 0;
1447:
1448: if (analyse_syntaxique(s_etat_processus) == d_erreur)
1449: {
1450: if (indicateur_48 == d_vrai)
1451: {
1452: sf(s_etat_processus, 48);
1453: }
1454: else
1455: {
1456: cf(s_etat_processus, 48);
1457: }
1458:
1459: if (destruction_fichier(nom_fichier_temporaire) == d_erreur)
1460: {
1461: (*s_etat_processus).erreur_systeme = d_es_erreur_fichier;
1462: return;
1463: }
1464:
1465: free(nom_fichier_temporaire);
1466: free((*s_etat_processus).instruction_courante);
1467: free((*s_etat_processus).definitions_chainees);
1468: free(chaine);
1469:
1470: (*s_etat_processus).position_courante = position_courante;
1471: (*s_etat_processus).instruction_courante =
1472: tampon_instruction_courante;
1473: (*s_etat_processus).definitions_chainees =
1474: tampon_definitions_chainees;
1475: (*s_etat_processus).autorisation_empilement_programme =
1476: autorisation_empilement_programme;
1477:
1478: liberation(s_etat_processus, s_objet);
1479: return;
1480: }
1481:
1482: (*s_etat_processus).position_courante = 0;
1483:
1484: if (recherche_instruction_suivante(s_etat_processus) !=
1485: d_absence_erreur)
1486: {
1487: if (indicateur_48 == d_vrai)
1488: {
1489: sf(s_etat_processus, 48);
1490: }
1491: else
1492: {
1493: cf(s_etat_processus, 48);
1494: }
1495:
1496: if (destruction_fichier(nom_fichier_temporaire) == d_erreur)
1497: {
1498: (*s_etat_processus).erreur_systeme = d_es_erreur_fichier;
1499: return;
1500: }
1501:
1502: free(nom_fichier_temporaire);
1503: free((*s_etat_processus).instruction_courante);
1504: free((*s_etat_processus).definitions_chainees);
1505: free(chaine);
1506:
1507: (*s_etat_processus).position_courante = position_courante;
1508: (*s_etat_processus).instruction_courante =
1509: tampon_instruction_courante;
1510: (*s_etat_processus).definitions_chainees =
1511: tampon_definitions_chainees;
1512: (*s_etat_processus).autorisation_empilement_programme =
1513: autorisation_empilement_programme;
1514:
1515: liberation(s_etat_processus, s_objet);
1516: return;
1517: }
1518:
1.59 bertrand 1519: (*s_etat_processus).type_en_cours = NON;
1.7 bertrand 1520: recherche_type(s_etat_processus);
1521:
1522: while((*s_etat_processus).definitions_chainees
1523: [(*s_etat_processus).position_courante] != d_code_fin_chaine)
1524: {
1525: if ((*s_etat_processus).definitions_chainees
1526: [(*s_etat_processus).position_courante++] != d_code_espace)
1527: {
1528: (*s_etat_processus).erreur_execution = d_ex_syntaxe;
1529: }
1530: }
1531:
1532: free((*s_etat_processus).instruction_courante);
1533: free((*s_etat_processus).definitions_chainees);
1534: free(chaine);
1535:
1536: (*s_etat_processus).position_courante = position_courante;
1537: (*s_etat_processus).instruction_courante =
1538: tampon_instruction_courante;
1539: (*s_etat_processus).definitions_chainees =
1540: tampon_definitions_chainees;
1541: (*s_etat_processus).autorisation_empilement_programme =
1542: autorisation_empilement_programme;
1543:
1544: if (indicateur_48 == d_vrai)
1545: {
1546: sf(s_etat_processus, 48);
1547: }
1548: else
1549: {
1550: cf(s_etat_processus, 48);
1551: }
1.1 bertrand 1552:
1553: if (destruction_fichier(nom_fichier_temporaire) == d_erreur)
1554: {
1555: (*s_etat_processus).erreur_systeme = d_es_erreur_fichier;
1556: return;
1557: }
1558:
1559: free(nom_fichier_temporaire);
1560: }
1561: else
1562: {
1563: liberation(s_etat_processus, s_objet);
1564:
1565: (*s_etat_processus).erreur_execution = d_ex_erreur_type_argument;
1566: return;
1567: }
1568:
1569: liberation(s_etat_processus, s_objet);
1570: return;
1571: }
1572:
1573:
1574: /*
1575: ================================================================================
1576: Fonction 'rcws'
1577: ================================================================================
1578: Entrées : pointeur sur une structure struct_processus
1579: --------------------------------------------------------------------------------
1580: Sorties :
1581: --------------------------------------------------------------------------------
1582: Effets de bord : néant
1583: ================================================================================
1584: */
1585:
1586: void
1587: instruction_rcws(struct_processus *s_etat_processus)
1588: {
1589: struct_objet *s_objet_resultat;
1590:
1.51 bertrand 1591: integer8 i;
1592: integer8 j;
1593: integer8 longueur;
1.1 bertrand 1594:
1595: (*s_etat_processus).erreur_execution = d_ex;
1596:
1597: if ((*s_etat_processus).affichage_arguments == 'Y')
1598: {
1599: printf("\n RCWS ");
1600:
1601: if ((*s_etat_processus).langue == 'F')
1602: {
1603: printf("(rappel de la longueur des entiers binaires)\n\n");
1604: }
1605: else
1606: {
1607: printf("(recall the length of the binary integers)\n\n");
1608: }
1609:
1610: printf("-> 1: %s\n", d_INT);
1611:
1612: return;
1613: }
1614: else if ((*s_etat_processus).test_instruction == 'Y')
1615: {
1616: (*s_etat_processus).nombre_arguments = -1;
1617: return;
1618: }
1619:
1620: if (test_cfsf(s_etat_processus, 31) == d_vrai)
1621: {
1622: if (empilement_pile_last(s_etat_processus, 0) == d_erreur)
1623: {
1624: return;
1625: }
1626: }
1627:
1628: if ((s_objet_resultat = allocation(s_etat_processus, INT)) == NULL)
1629: {
1630: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
1631: return;
1632: }
1633:
1634: longueur = 1;
1635: j = 1;
1636:
1637: for(i = 37; i <= 42; i++)
1638: {
1639: longueur += (test_cfsf(s_etat_processus, (unsigned char) i)
1640: == d_vrai) ? j : 0;
1641: j *= 2;
1642: }
1643:
1644: (*((integer8 *) (*s_objet_resultat).objet)) = longueur;
1645:
1646: if (empilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
1647: s_objet_resultat) == d_erreur)
1648: {
1649: return;
1650: }
1651:
1652: return;
1653: }
1654:
1655:
1656: /*
1657: ================================================================================
1658: Fonction 'rcls'
1659: ================================================================================
1660: Entrées : pointeur sur une structure struct_processus
1661: --------------------------------------------------------------------------------
1662: Sorties :
1663: --------------------------------------------------------------------------------
1664: Effets de bord : néant
1665: ================================================================================
1666: */
1667:
1668: void
1669: instruction_rcls(struct_processus *s_etat_processus)
1670: {
1671: struct_objet *s_objet_variable;
1672:
1673: (*s_etat_processus).erreur_execution = d_ex;
1674:
1675: if ((*s_etat_processus).affichage_arguments == 'Y')
1676: {
1677: printf("\n RCLS ");
1678:
1679: if ((*s_etat_processus).langue == 'F')
1680: {
1681: printf("(rappel de la variable %s)\n\n", ds_sdat);
1682: }
1683: else
1684: {
1685: printf("(recall %s variable)\n\n", ds_sdat);
1686: }
1687:
1688: printf("-> 1: %s, %s, %s, %s, %s, %s,\n"
1689: " %s, %s, %s, %s, %s,\n"
1690: " %s, %s, %s, %s, %s,\n"
1691: " %s\n",
1692: d_INT, d_REL, d_CPL, d_VIN, d_VRL, d_VCX, d_MIN, d_MRL, d_MCX,
1693: d_BIN, d_NOM, d_CHN, d_LST, d_ALG, d_RPN, d_FCH, d_SLB);
1694:
1695: return;
1696: }
1697: else if ((*s_etat_processus).test_instruction == 'Y')
1698: {
1699: (*s_etat_processus).nombre_arguments = -1;
1700: return;
1701: }
1702:
1703: if (test_cfsf(s_etat_processus, 31) == d_vrai)
1704: {
1705: if (empilement_pile_last(s_etat_processus, 0) == d_erreur)
1706: {
1707: return;
1708: }
1709: }
1710:
1.26 bertrand 1711: if (recherche_variable_globale(s_etat_processus, ds_sdat) == d_faux)
1.1 bertrand 1712: {
1.26 bertrand 1713: (*s_etat_processus).erreur_systeme = d_es;
1.1 bertrand 1714:
1.26 bertrand 1715: if ((*s_etat_processus).erreur_execution == d_ex)
1.1 bertrand 1716: {
1717: (*s_etat_processus).erreur_execution = d_ex_variable_non_definie;
1718: }
1719:
1720: return;
1721: }
1722:
1723: if ((s_objet_variable = copie_objet(s_etat_processus,
1.26 bertrand 1724: (*(*s_etat_processus).pointeur_variable_courante).objet, 'O'))
1.1 bertrand 1725: == NULL)
1726: {
1727: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
1728: return;
1729: }
1730:
1731: if (empilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
1732: s_objet_variable) == d_erreur)
1733: {
1734: return;
1735: }
1736:
1737: return;
1738: }
1739:
1740: // vim: ts=4
CVSweb interface <joel.bertrand@systella.fr>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to instructions_r3.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [local] / rpl / src