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