1: /*
2: ================================================================================
3: RPL/2 (R) version 4.1.4
4: Copyright (C) 1989-2011 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 'clmf'
29: ================================================================================
30: Entrées : structure processus
31: --------------------------------------------------------------------------------
32: Sorties :
33: --------------------------------------------------------------------------------
34: Effets de bord : néant
35: ================================================================================
36: */
37:
38: void
39: instruction_clmf(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 CLMF ");
46:
47: if ((*s_etat_processus).langue == 'F')
48: {
49: printf("(affiche la pile opérationnelle)\n\n");
50: printf(" Aucun argument\n");
51: }
52: else
53: {
54: printf("(print stack)\n\n");
55: printf(" No argument\n");
56: }
57:
58: return;
59: }
60: else if ((*s_etat_processus).test_instruction == 'Y')
61: {
62: (*s_etat_processus).nombre_arguments = -1;
63: return;
64: }
65:
66: affichage_pile(s_etat_processus, (*s_etat_processus).l_base_pile, 1);
67:
68: return;
69: }
70:
71:
72: /*
73: ================================================================================
74: Fonction 'cont'
75: ================================================================================
76: Entrées :
77: --------------------------------------------------------------------------------
78: Sorties :
79: --------------------------------------------------------------------------------
80: Effets de bord : néant
81: ================================================================================
82: */
83:
84: void
85: instruction_cont(struct_processus *s_etat_processus)
86: {
87: (*s_etat_processus).erreur_execution = d_ex;
88:
89: if ((*s_etat_processus).affichage_arguments == 'Y')
90: {
91: printf("\n CONT ");
92:
93: if ((*s_etat_processus).langue == 'F')
94: {
95: printf("(continue un programme arrêté par HALT)\n\n");
96: printf(" Aucun argument\n");
97: }
98: else
99: {
100: printf("(continue a program stopped by HALT)\n\n");
101: printf(" No argument\n");
102: }
103:
104: return;
105: }
106: else if ((*s_etat_processus).test_instruction == 'Y')
107: {
108: (*s_etat_processus).nombre_arguments = -1;
109: return;
110: }
111:
112: (*s_etat_processus).debug_programme = d_faux;
113: (*s_etat_processus).execution_pas_suivant = d_vrai;
114:
115: return;
116: }
117:
118:
119: /*
120: ================================================================================
121: Fonction 'cnrm'
122: ================================================================================
123: Entrées : pointeur sur une structure struct_processus
124: --------------------------------------------------------------------------------
125: Sorties :
126: --------------------------------------------------------------------------------
127: Effets de bord : néant
128: ================================================================================
129: */
130:
131: void
132: instruction_cnrm(struct_processus *s_etat_processus)
133: {
134: integer8 cumul_entier;
135: integer8 entier_courant;
136: integer8 tampon;
137:
138: logical1 depassement;
139: logical1 erreur_memoire;
140:
141: real8 cumul_reel;
142:
143: struct_objet *s_objet_argument;
144: struct_objet *s_objet_resultat;
145:
146: unsigned long i;
147: unsigned long j;
148:
149: void *accumulateur;
150:
151: (*s_etat_processus).erreur_execution = d_ex;
152:
153: if ((*s_etat_processus).affichage_arguments == 'Y')
154: {
155: printf("\n CNRM ");
156:
157: if ((*s_etat_processus).langue == 'F')
158: {
159: printf("(norme de colonne)\n\n");
160: }
161: else
162: {
163: printf("(column norm)\n\n");
164: }
165:
166: printf(" 1: %s, %s\n", d_VIN, d_MIN);
167: printf("-> 1: %s, %s\n\n", d_INT, d_REL);
168:
169: printf(" 1: %s, %s, %s, %s\n", d_VRL, d_VCX, d_MRL, d_MCX);
170: printf("-> 1: %s\n", d_REL);
171:
172: return;
173: }
174: else if ((*s_etat_processus).test_instruction == 'Y')
175: {
176: (*s_etat_processus).nombre_arguments = -1;
177: return;
178: }
179:
180: if (test_cfsf(s_etat_processus, 31) == d_vrai)
181: {
182: if (empilement_pile_last(s_etat_processus, 1) == d_erreur)
183: {
184: return;
185: }
186: }
187:
188: if (depilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
189: &s_objet_argument) == d_erreur)
190: {
191: (*s_etat_processus).erreur_execution = d_ex_manque_argument;
192: return;
193: }
194:
195: /*
196: --------------------------------------------------------------------------------
197: Traitement des vecteurs
198: --------------------------------------------------------------------------------
199: */
200:
201: if ((*s_objet_argument).type == VIN)
202: {
203: cumul_entier = 0;
204: depassement = d_faux;
205:
206: for(i = 0; i < (*((struct_vecteur *) (*s_objet_argument).objet)).taille;
207: i++)
208: {
209: entier_courant = abs(((integer8 *) (*((struct_vecteur *)
210: (*s_objet_argument).objet)).tableau)[i]);
211:
212: if (depassement_addition(&cumul_entier, &entier_courant,
213: &tampon) == d_erreur)
214: {
215: depassement = d_vrai;
216: break;
217: }
218:
219: cumul_entier = tampon;
220: }
221:
222: if (depassement == d_faux)
223: {
224: if ((s_objet_resultat = allocation(s_etat_processus, INT))
225: == NULL)
226: {
227: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
228: return;
229: }
230:
231: (*((integer8 *) (*s_objet_resultat).objet)) = cumul_entier;
232: }
233: else
234: {
235: cumul_reel = 0;
236:
237: for(i = 0; i < (*((struct_vecteur *) (*s_objet_argument).objet))
238: .taille; i++)
239: {
240: cumul_reel += (real8) abs(((integer8 *) (*((struct_vecteur *)
241: (*s_objet_argument).objet)).tableau)[i]);
242: }
243:
244: if ((s_objet_resultat = allocation(s_etat_processus, REL))
245: == NULL)
246: {
247: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
248: return;
249: }
250:
251: (*((real8 *) (*s_objet_resultat).objet)) = cumul_reel;
252: }
253: }
254: else if ((*s_objet_argument).type == VRL)
255: {
256: if ((s_objet_resultat = allocation(s_etat_processus, REL))
257: == NULL)
258: {
259: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
260: return;
261: }
262:
263: if ((accumulateur = malloc((*((struct_vecteur *)
264: (*s_objet_argument).objet)).taille * sizeof(real8))) == NULL)
265: {
266: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
267: return;
268: }
269:
270: for(i = 0; i < (*((struct_vecteur *) (*s_objet_argument).objet)).taille;
271: i++)
272: {
273: ((real8 *) accumulateur)[i] =
274: fabs(((real8 *) (*((struct_vecteur *)
275: (*s_objet_argument).objet)).tableau)[i]);
276: }
277:
278: (*((real8 *) (*s_objet_resultat).objet)) = sommation_vecteur_reel(
279: accumulateur, &((*((struct_vecteur *) (*s_objet_argument)
280: .objet)).taille), &erreur_memoire);
281:
282: if (erreur_memoire == d_vrai)
283: {
284: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
285: return;
286: }
287:
288: free(accumulateur);
289: }
290: else if ((*s_objet_argument).type == VCX)
291: {
292: if ((s_objet_resultat = allocation(s_etat_processus, REL))
293: == NULL)
294: {
295: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
296: return;
297: }
298:
299: if ((accumulateur = malloc((*((struct_vecteur *)
300: (*s_objet_argument).objet)).taille * sizeof(real8))) == NULL)
301: {
302: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
303: return;
304: }
305:
306: for(i = 0; i < (*((struct_vecteur *) (*s_objet_argument).objet)).taille;
307: i++)
308: {
309: f77absc_(&(((struct_complexe16 *) (*((struct_vecteur *)
310: (*s_objet_argument).objet)).tableau)[i]),
311: &(((real8 *) accumulateur)[i]));
312: }
313:
314: (*((real8 *) (*s_objet_resultat).objet)) = sommation_vecteur_reel(
315: accumulateur, &((*((struct_vecteur *) (*s_objet_argument)
316: .objet)).taille), &erreur_memoire);
317:
318: if (erreur_memoire == d_vrai)
319: {
320: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
321: return;
322: }
323:
324: free(accumulateur);
325: }
326:
327: /*
328: --------------------------------------------------------------------------------
329: Traitement des matrices
330: --------------------------------------------------------------------------------
331: */
332:
333: else if ((*s_objet_argument).type == MIN)
334: {
335: if ((s_objet_resultat = allocation(s_etat_processus, INT))
336: == NULL)
337: {
338: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
339: return;
340: }
341:
342: depassement = d_faux;
343: cumul_entier = 0;
344:
345: for(i = 0; i < (*((struct_matrice *) (*s_objet_argument).objet))
346: .nombre_lignes; i++)
347: {
348: entier_courant = abs(((integer8 **)
349: (*((struct_matrice *) (*s_objet_argument).objet))
350: .tableau)[i][0]);
351:
352: if (depassement_addition(&cumul_entier, &entier_courant,
353: &tampon) == d_erreur)
354: {
355: depassement = d_vrai;
356: break;
357: }
358:
359: cumul_entier = tampon;
360: }
361:
362: if (depassement == d_faux)
363: {
364: (*((integer8 *) (*s_objet_resultat).objet)) = cumul_entier;
365:
366: for(j = 1; j < (*((struct_matrice *) (*s_objet_argument).objet))
367: .nombre_colonnes; j++)
368: {
369: cumul_entier = 0;
370:
371: for(i = 0; i < (*((struct_matrice *) (*s_objet_argument).objet))
372: .nombre_lignes; i++)
373: {
374: entier_courant = abs(((integer8 **) (*((struct_matrice *)
375: (*s_objet_argument).objet)).tableau)[i][j]);
376:
377: if (depassement_addition(&cumul_entier, &entier_courant,
378: &tampon) == d_erreur)
379: {
380: depassement = d_vrai;
381: break;
382: }
383:
384: cumul_entier = tampon;
385: }
386:
387: if (depassement == d_vrai)
388: {
389: break;
390: }
391:
392: if (cumul_entier > (*((integer8 *) (*s_objet_resultat).objet)))
393: {
394: (*((integer8 *) (*s_objet_resultat).objet)) = cumul_entier;
395: }
396: }
397: }
398:
399: if (depassement == d_vrai)
400: {
401: /*
402: * Dépassement : il faut refaire le calcul en real*8...
403: */
404:
405: free((*s_objet_resultat).objet);
406: (*s_objet_resultat).type = REL;
407:
408: if (((*s_objet_resultat).objet = malloc(sizeof(real8))) == NULL)
409: {
410: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
411: return;
412: }
413:
414: if ((accumulateur = malloc((*((struct_matrice *)
415: (*s_objet_argument).objet)).nombre_lignes * sizeof(real8)))
416: == NULL)
417: {
418: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
419: return;
420: }
421:
422: (*((real8 *) (*s_objet_resultat).objet)) = 0;
423:
424: for(j = 0; j < (*((struct_matrice *) (*s_objet_argument).objet))
425: .nombre_colonnes; j++)
426: {
427: for(i = 0; i < (*((struct_matrice *) (*s_objet_argument).objet))
428: .nombre_lignes; i++)
429: {
430: ((real8 *) accumulateur)[i] = fabs((real8) ((integer8 **)
431: (*((struct_matrice *)
432: (*s_objet_argument).objet)).tableau)[i][j]);
433: }
434:
435: cumul_reel = sommation_vecteur_reel(accumulateur,
436: &((*((struct_matrice *) (*s_objet_argument).objet))
437: .nombre_lignes), &erreur_memoire);
438:
439: if (erreur_memoire == d_vrai)
440: {
441: (*s_etat_processus).erreur_systeme =
442: d_es_allocation_memoire;
443: return;
444: }
445:
446: if (cumul_reel > (*((real8 *) (*s_objet_resultat).objet)))
447: {
448: (*((real8 *) (*s_objet_resultat).objet)) = cumul_reel;
449: }
450: }
451:
452: free(accumulateur);
453: }
454: }
455: else if ((*s_objet_argument).type == MRL)
456: {
457: if ((s_objet_resultat = allocation(s_etat_processus, REL))
458: == NULL)
459: {
460: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
461: return;
462: }
463:
464: if ((accumulateur = malloc((*((struct_matrice *)
465: (*s_objet_argument).objet)).nombre_lignes * sizeof(real8)))
466: == NULL)
467: {
468: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
469: return;
470: }
471:
472: (*((real8 *) (*s_objet_resultat).objet)) = 0;
473:
474: for(j = 0; j < (*((struct_matrice *) (*s_objet_argument).objet))
475: .nombre_colonnes; j++)
476: {
477: for(i = 0; i < (*((struct_matrice *) (*s_objet_argument).objet))
478: .nombre_lignes; i++)
479: {
480: ((real8 *) accumulateur)[i] = fabs(((real8 **)
481: (*((struct_matrice *)
482: (*s_objet_argument).objet)).tableau)[i][j]);
483: }
484:
485: cumul_reel = sommation_vecteur_reel(accumulateur,
486: &((*((struct_matrice *) (*s_objet_argument).objet))
487: .nombre_lignes), &erreur_memoire);
488:
489: if (erreur_memoire == d_vrai)
490: {
491: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
492: return;
493: }
494:
495: if (cumul_reel > (*((real8 *) (*s_objet_resultat).objet)))
496: {
497: (*((real8 *) (*s_objet_resultat).objet)) = cumul_reel;
498: }
499: }
500:
501: free(accumulateur);
502: }
503: else if ((*s_objet_argument).type == MCX)
504: {
505: if ((s_objet_resultat = allocation(s_etat_processus, REL))
506: == NULL)
507: {
508: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
509: return;
510: }
511:
512: if ((accumulateur = malloc((*((struct_matrice *)
513: (*s_objet_argument).objet)).nombre_lignes * sizeof(real8)))
514: == NULL)
515: {
516: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
517: return;
518: }
519:
520: (*((real8 *) (*s_objet_resultat).objet)) = 0;
521:
522: for(j = 0; j < (*((struct_matrice *) (*s_objet_argument).objet))
523: .nombre_colonnes; j++)
524: {
525: for(i = 0; i < (*((struct_matrice *) (*s_objet_argument).objet))
526: .nombre_lignes; i++)
527: {
528: f77absc_(&(((struct_complexe16 **) (*((struct_matrice *)
529: (*s_objet_argument).objet)).tableau)[i][j]),
530: &(((real8 *) accumulateur)[i]));
531: }
532:
533: cumul_reel = sommation_vecteur_reel(accumulateur,
534: &((*((struct_matrice *) (*s_objet_argument).objet))
535: .nombre_lignes), &erreur_memoire);
536:
537: if (erreur_memoire == d_vrai)
538: {
539: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
540: return;
541: }
542:
543: if (cumul_reel > (*((real8 *) (*s_objet_resultat).objet)))
544: {
545: (*((real8 *) (*s_objet_resultat).objet)) = cumul_reel;
546: }
547: }
548:
549: free(accumulateur);
550: }
551:
552: /*
553: --------------------------------------------------------------------------------
554: Traitement impossible du fait du type de l'argument
555: --------------------------------------------------------------------------------
556: */
557:
558: else
559: {
560: liberation(s_etat_processus, s_objet_argument);
561:
562: (*s_etat_processus).erreur_execution = d_ex_erreur_type_argument;
563: return;
564: }
565:
566: liberation(s_etat_processus, s_objet_argument);
567:
568: if (empilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
569: s_objet_resultat) == d_erreur)
570: {
571: return;
572: }
573:
574: return;
575: }
576:
577:
578: /*
579: ================================================================================
580: Fonction 'chr'
581: ================================================================================
582: Entrées : structure processus
583: --------------------------------------------------------------------------------
584: Sorties :
585: --------------------------------------------------------------------------------
586: Effets de bord : néant
587: ================================================================================
588: */
589:
590: void
591: instruction_chr(struct_processus *s_etat_processus)
592: {
593: struct_objet *s_objet_argument;
594: struct_objet *s_objet_resultat;
595:
596: (*s_etat_processus).erreur_execution = d_ex;
597:
598: if ((*s_etat_processus).affichage_arguments == 'Y')
599: {
600: printf("\n CHR ");
601:
602: if ((*s_etat_processus).langue == 'F')
603: {
604: printf("(conversion d'un entier en caractère)\n\n");
605: }
606: else
607: {
608: printf("(integer to character conversion)\n\n");
609: }
610:
611: printf(" 1: %s\n", d_INT);
612: printf("-> 1: %s\n", d_CHN);
613:
614: return;
615: }
616: else if ((*s_etat_processus).test_instruction == 'Y')
617: {
618: (*s_etat_processus).nombre_arguments = -1;
619: return;
620: }
621:
622: if (test_cfsf(s_etat_processus, 31) == d_vrai)
623: {
624: if (empilement_pile_last(s_etat_processus, 1) == d_erreur)
625: {
626: return;
627: }
628: }
629:
630: if (depilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
631: &s_objet_argument) == d_erreur)
632: {
633: (*s_etat_processus).erreur_execution = d_ex_manque_argument;
634: return;
635: }
636:
637: /*
638: --------------------------------------------------------------------------------
639: Entier
640: --------------------------------------------------------------------------------
641: */
642:
643: if ((*s_objet_argument).type == INT)
644: {
645: if ((*((integer8 *) (*s_objet_argument).objet)) !=
646: (unsigned char) (*((integer8 *) (*s_objet_argument).objet)))
647: {
648: liberation(s_etat_processus, s_objet_argument);
649:
650: (*s_etat_processus).erreur_execution = d_ex_argument_invalide;
651: return;
652: }
653:
654: if (isprint((unsigned char) (*((integer8 *) (*s_objet_argument).objet)))
655: != 0)
656: {
657: if ((s_objet_resultat = allocation(s_etat_processus, CHN)) == NULL)
658: {
659: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
660: return;
661: }
662:
663: if (((*s_objet_resultat).objet = malloc(2 * sizeof(unsigned char)))
664: == NULL)
665: {
666: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
667: return;
668: }
669:
670: ((unsigned char *) (*s_objet_resultat).objet)[0] = (*((integer8 *)
671: (*s_objet_argument).objet));
672: ((unsigned char *) (*s_objet_resultat).objet)[1] =
673: d_code_fin_chaine;
674: }
675: else
676: {
677: if ((s_objet_resultat = allocation(s_etat_processus, CHN)) == NULL)
678: {
679: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
680: return;
681: }
682:
683: if (((*s_objet_resultat).objet = malloc(5 * sizeof(unsigned char)))
684: == NULL)
685: {
686: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
687: return;
688: }
689:
690: sprintf((unsigned char *) (*s_objet_resultat).objet, "\\x%02X",
691: (unsigned char) (*((integer8 *)
692: (*s_objet_argument).objet)));
693: }
694: }
695:
696: /*
697: --------------------------------------------------------------------------------
698: Type invalide
699: --------------------------------------------------------------------------------
700: */
701:
702: else
703: {
704: liberation(s_etat_processus, s_objet_argument);
705:
706: (*s_etat_processus).erreur_execution = d_ex_erreur_type_argument;
707: return;
708: }
709:
710: liberation(s_etat_processus, s_objet_argument);
711:
712: if (empilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
713: s_objet_resultat) == d_erreur)
714: {
715: return;
716: }
717:
718: return;
719: }
720:
721:
722: /*
723: ================================================================================
724: Fonction 'cr'
725: ================================================================================
726: Entrées : structure processus
727: --------------------------------------------------------------------------------
728: Sorties :
729: --------------------------------------------------------------------------------
730: Effets de bord : néant
731: ================================================================================
732: */
733:
734: void
735: instruction_cr(struct_processus *s_etat_processus)
736: {
737: struct_objet s_objet;
738:
739: unsigned char commande[] = "\\\\par";
740:
741: (*s_etat_processus).erreur_execution = d_ex;
742:
743: if ((*s_etat_processus).affichage_arguments == 'Y')
744: {
745: printf("\n CR ");
746:
747: if ((*s_etat_processus).langue == 'F')
748: {
749: printf("(retour à la ligne dans la sortie imprimée)\n\n");
750: printf(" Aucun argument\n");
751: }
752: else
753: {
754: printf("(carriage return in the printer output)\n\n");
755: printf(" No argument\n");
756: }
757:
758: return;
759: }
760: else if ((*s_etat_processus).test_instruction == 'Y')
761: {
762: (*s_etat_processus).nombre_arguments = -1;
763: return;
764: }
765:
766: if (test_cfsf(s_etat_processus, 31) == d_vrai)
767: {
768: if (empilement_pile_last(s_etat_processus, 0) == d_erreur)
769: {
770: return;
771: }
772: }
773:
774: s_objet.objet = commande;
775: s_objet.type = CHN;
776:
777: formateur_tex(s_etat_processus, &s_objet, 'N');
778: return;
779: }
780:
781:
782: /*
783: ================================================================================
784: Fonction 'centr'
785: ================================================================================
786: Entrées : pointeur sur une structure struct_processus
787: --------------------------------------------------------------------------------
788: Sorties :
789: --------------------------------------------------------------------------------
790: Effets de bord : néant
791: ================================================================================
792: */
793:
794: void
795: instruction_centr(struct_processus *s_etat_processus)
796: {
797: real8 x_max;
798: real8 x_min;
799: real8 y_max;
800: real8 y_min;
801:
802: struct_objet *s_objet_argument;
803:
804: (*s_etat_processus).erreur_execution = d_ex;
805:
806:
807: if ((*s_etat_processus).affichage_arguments == 'Y')
808: {
809: printf("\n CENTR ");
810:
811: if ((*s_etat_processus).langue == 'F')
812: {
813: printf("(centre des graphiques)\n\n");
814: }
815: else
816: {
817: printf("(center of the graphics)\n\n");
818: }
819:
820: printf(" 1: %s\n", d_CPL);
821:
822: return;
823: }
824: else if ((*s_etat_processus).test_instruction == 'Y')
825: {
826: (*s_etat_processus).nombre_arguments = -1;
827: return;
828: }
829:
830: if (test_cfsf(s_etat_processus, 31) == d_vrai)
831: {
832: if (empilement_pile_last(s_etat_processus, 1) == d_erreur)
833: {
834: return;
835: }
836: }
837:
838: if (depilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
839: &s_objet_argument) == d_erreur)
840: {
841: (*s_etat_processus).erreur_execution = d_ex_manque_argument;
842: return;
843: }
844:
845: if ((*s_objet_argument).type == CPL)
846: {
847: if ((*s_etat_processus).systeme_axes == 0)
848: {
849: x_min = (*s_etat_processus).x_min;
850: x_max = (*s_etat_processus).x_max;
851:
852: y_min = (*s_etat_processus).y_min;
853: y_max = (*s_etat_processus).y_max;
854:
855: (*s_etat_processus).x_min = (*((complex16 *)
856: (*s_objet_argument).objet))
857: .partie_reelle - ((x_max - x_min) / ((double) 2));
858: (*s_etat_processus).x_max = (*((complex16 *)
859: (*s_objet_argument).objet))
860: .partie_reelle + ((x_max - x_min) / ((double) 2));
861:
862: (*s_etat_processus).y_min = (*((complex16 *)
863: (*s_objet_argument).objet))
864: .partie_imaginaire - ((y_max - y_min) / ((double) 2));
865: (*s_etat_processus).y_max = (*((complex16 *)
866: (*s_objet_argument).objet))
867: .partie_imaginaire + ((y_max - y_min) / ((double) 2));
868: }
869: else
870: {
871: x_min = (*s_etat_processus).x2_min;
872: x_max = (*s_etat_processus).x2_max;
873:
874: y_min = (*s_etat_processus).y2_min;
875: y_max = (*s_etat_processus).y2_max;
876:
877: (*s_etat_processus).x2_min = (*((complex16 *)
878: (*s_objet_argument).objet))
879: .partie_reelle - ((x_max - x_min) / ((double) 2));
880: (*s_etat_processus).x2_max = (*((complex16 *)
881: (*s_objet_argument).objet))
882: .partie_reelle + ((x_max - x_min) / ((double) 2));
883:
884: (*s_etat_processus).y2_min = (*((complex16 *)
885: (*s_objet_argument).objet))
886: .partie_imaginaire - ((y_max - y_min) / ((double) 2));
887: (*s_etat_processus).y2_max = (*((complex16 *)
888: (*s_objet_argument).objet))
889: .partie_imaginaire + ((y_max - y_min) / ((double) 2));
890: }
891: }
892: else
893: {
894: liberation(s_etat_processus, s_objet_argument);
895:
896: (*s_etat_processus).erreur_execution = d_ex_erreur_type_argument;
897: return;
898: }
899:
900: liberation(s_etat_processus, s_objet_argument);
901:
902: if (test_cfsf(s_etat_processus, 52) == d_faux)
903: {
904: if ((*s_etat_processus).fichiers_graphiques != NULL)
905: {
906: appel_gnuplot(s_etat_processus, 'N');
907: }
908: }
909:
910: return;
911: }
912:
913:
914: /*
915: ================================================================================
916: Fonction 'cls'
917: ================================================================================
918: Entrées : pointeur sur une structure struct_processus
919: --------------------------------------------------------------------------------
920: Sorties :
921: --------------------------------------------------------------------------------
922: Effets de bord : néant
923: ================================================================================
924: */
925:
926: void
927: instruction_cls(struct_processus *s_etat_processus)
928: {
929: (*s_etat_processus).erreur_execution = d_ex;
930:
931: if ((*s_etat_processus).affichage_arguments == 'Y')
932: {
933: printf("\n CLS ");
934:
935: if ((*s_etat_processus).langue == 'F')
936: {
937: printf("(effacement de la matrice statistique)\n\n");
938: printf(" Aucun argument\n");
939: }
940: else
941: {
942: printf("(purge of the statistical matrix)\n\n");
943: printf(" No argument\n");
944: }
945:
946: return;
947: }
948: else if ((*s_etat_processus).test_instruction == 'Y')
949: {
950: (*s_etat_processus).nombre_arguments = -1;
951: return;
952: }
953:
954: if (test_cfsf(s_etat_processus, 31) == d_vrai)
955: {
956: if (empilement_pile_last(s_etat_processus, 0) == d_erreur)
957: {
958: return;
959: }
960: }
961:
962: if (retrait_variable(s_etat_processus, ds_sdat, 'G') == d_erreur)
963: {
964: (*s_etat_processus).erreur_systeme = d_es;
965: return;
966: }
967:
968: return;
969: }
970:
971:
972: /*
973: ================================================================================
974: Fonction 'comb'
975: ================================================================================
976: Entrées : structure processus
977: --------------------------------------------------------------------------------
978: Sorties :
979: --------------------------------------------------------------------------------
980: Effets de bord : néant
981: ================================================================================
982: */
983:
984: void
985: instruction_comb(struct_processus *s_etat_processus)
986: {
987: integer8 k;
988: integer8 n;
989: integer8 cint_max;
990:
991: real8 c;
992:
993: struct_objet *s_objet_argument_1;
994: struct_objet *s_objet_argument_2;
995: struct_objet *s_objet_resultat;
996:
997: unsigned long i;
998:
999: (*s_etat_processus).erreur_execution = d_ex;
1000:
1001: if ((*s_etat_processus).affichage_arguments == 'Y')
1002: {
1003: printf("\n COMB ");
1004:
1005: if ((*s_etat_processus).langue == 'F')
1006: {
1007: printf("(combinaison)\n\n");
1008: }
1009: else
1010: {
1011: printf("(combinaison)\n\n");
1012: }
1013:
1014: printf(" 1: %s\n", d_INT);
1015: printf("-> 1: %s, %s\n", d_INT, d_REL);
1016:
1017: return;
1018: }
1019: else if ((*s_etat_processus).test_instruction == 'Y')
1020: {
1021: (*s_etat_processus).nombre_arguments = 2;
1022: return;
1023: }
1024:
1025: if (test_cfsf(s_etat_processus, 31) == d_vrai)
1026: {
1027: if (empilement_pile_last(s_etat_processus, 2) == d_erreur)
1028: {
1029: return;
1030: }
1031: }
1032:
1033: if (depilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
1034: &s_objet_argument_1) == d_erreur)
1035: {
1036: (*s_etat_processus).erreur_execution = d_ex_manque_argument;
1037: return;
1038: }
1039:
1040: if (depilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
1041: &s_objet_argument_2) == d_erreur)
1042: {
1043: liberation(s_etat_processus, s_objet_argument_1);
1044:
1045: (*s_etat_processus).erreur_execution = d_ex_manque_argument;
1046: return;
1047: }
1048:
1049: if (((*s_objet_argument_1).type == INT) &&
1050: ((*s_objet_argument_2).type == INT))
1051: {
1052: n = (*((integer8 *) (*s_objet_argument_2).objet));
1053: k = (*((integer8 *) (*s_objet_argument_1).objet));
1054:
1055: if ((n < 0) || (k < 0) || (k > n))
1056: {
1057: liberation(s_etat_processus, s_objet_argument_1);
1058: liberation(s_etat_processus, s_objet_argument_2);
1059:
1060: (*s_etat_processus).erreur_execution = d_ex_argument_invalide;
1061: return;
1062: }
1063:
1064: f90combinaison(&n, &k, &c);
1065:
1066: for(i = 1, cint_max = 1; i < (8 * sizeof(integer8)) - 1; cint_max =
1067: (cint_max << 1) + 1, i++);
1068:
1069: if (c > cint_max)
1070: {
1071: if ((s_objet_resultat = allocation(s_etat_processus, REL))
1072: == NULL)
1073: {
1074: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
1075: return;
1076: }
1077:
1078: (*((real8 *) (*s_objet_resultat).objet)) = c;
1079: }
1080: else
1081: {
1082: if ((s_objet_resultat = allocation(s_etat_processus, INT))
1083: == NULL)
1084: {
1085: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
1086: return;
1087: }
1088:
1089: if (fabs(c - floor(c)) < fabs(ceil(c) - c))
1090: {
1091: (*((integer8 *) (*s_objet_resultat).objet)) =
1092: (integer8) floor(c);
1093: }
1094: else
1095: {
1096: (*((integer8 *) (*s_objet_resultat).objet)) =
1097: 1 + (integer8) floor(c);
1098: }
1099: }
1100: }
1101: else
1102: {
1103: liberation(s_etat_processus, s_objet_argument_1);
1104: liberation(s_etat_processus, s_objet_argument_2);
1105:
1106: (*s_etat_processus).erreur_execution = d_ex_erreur_type_argument;
1107: return;
1108: }
1109:
1110: liberation(s_etat_processus, s_objet_argument_1);
1111: liberation(s_etat_processus, s_objet_argument_2);
1112:
1113: if (empilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
1114: s_objet_resultat) == d_erreur)
1115: {
1116: return;
1117: }
1118:
1119: return;
1120: }
1121:
1122:
1123: /*
1124: ================================================================================
1125: Fonction 'cols'
1126: ================================================================================
1127: Entrées : pointeur sur une structure struct_processus
1128: --------------------------------------------------------------------------------
1129: Sorties :
1130: --------------------------------------------------------------------------------
1131: Effets de bord : néant
1132: ================================================================================
1133: */
1134:
1135: void
1136: instruction_cols(struct_processus *s_etat_processus)
1137: {
1138: struct_objet *s_objet_argument_1;
1139: struct_objet *s_objet_argument_2;
1140:
1141: (*s_etat_processus).erreur_execution = d_ex;
1142:
1143: if ((*s_etat_processus).affichage_arguments == 'Y')
1144: {
1145: printf("\n COLS ");
1146:
1147: if ((*s_etat_processus).langue == 'F')
1148: {
1149: printf("(définition des colonnes X et Y de la matrice "
1150: "statistique)\n\n");
1151: }
1152: else
1153: {
1154: printf("(definition of X and Y columns in statistical matrix)\n\n");
1155: }
1156:
1157: printf(" 2: %s\n", d_INT);
1158: printf(" 1: %s\n", d_INT);
1159:
1160: return;
1161: }
1162: else if ((*s_etat_processus).test_instruction == 'Y')
1163: {
1164: (*s_etat_processus).nombre_arguments = -1;
1165: return;
1166: }
1167:
1168: if (test_cfsf(s_etat_processus, 31) == d_vrai)
1169: {
1170: if (empilement_pile_last(s_etat_processus, 2) == d_erreur)
1171: {
1172: return;
1173: }
1174: }
1175:
1176: if (depilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
1177: &s_objet_argument_1) == d_erreur)
1178: {
1179: (*s_etat_processus).erreur_execution = d_ex_manque_argument;
1180: return;
1181: }
1182:
1183: if (depilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
1184: &s_objet_argument_2) == d_erreur)
1185: {
1186: liberation(s_etat_processus, s_objet_argument_1);
1187:
1188: (*s_etat_processus).erreur_execution = d_ex_manque_argument;
1189: return;
1190: }
1191:
1192: if (((*s_objet_argument_1).type == INT) &&
1193: ((*s_objet_argument_2).type == INT))
1194: {
1195: if (((*((integer8 *) (*s_objet_argument_1).objet)) <= 0) ||
1196: ((*((integer8 *) (*s_objet_argument_2).objet)) <= 0))
1197: {
1198: liberation(s_etat_processus, s_objet_argument_1);
1199: liberation(s_etat_processus, s_objet_argument_2);
1200:
1201: (*s_etat_processus).erreur_execution = d_ex_argument_invalide;
1202: return;
1203: }
1204:
1205: (*s_etat_processus).colonne_statistique_1 =
1206: (*((integer8 *) (*s_objet_argument_2).objet));
1207: (*s_etat_processus).colonne_statistique_2 =
1208: (*((integer8 *) (*s_objet_argument_1).objet));
1209: }
1210: else
1211: {
1212: liberation(s_etat_processus, s_objet_argument_1);
1213: liberation(s_etat_processus, s_objet_argument_2);
1214:
1215: (*s_etat_processus).erreur_execution = d_ex_erreur_type_argument;
1216: return;
1217: }
1218:
1219: liberation(s_etat_processus, s_objet_argument_1);
1220: liberation(s_etat_processus, s_objet_argument_2);
1221:
1222: return;
1223: }
1224:
1225: // vim: ts=4
CVSweb interface <joel.bertrand@systella.fr>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to instructions_c3.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [local] / rpl / src