1: /*
2: ================================================================================
3: RPL/2 (R) version 4.1.36
4: Copyright (C) 1989-2025 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 'inquire'
29: ================================================================================
30: Entrées :
31: --------------------------------------------------------------------------------
32: Sorties :
33: --------------------------------------------------------------------------------
34: Effets de bord : néant
35: ================================================================================
36: */
37:
38: void
39: instruction_inquire(struct_processus *s_etat_processus)
40: {
41: file *fichier;
42:
43: logical1 erreur;
44: logical1 existence;
45: logical1 ouverture;
46:
47: logical1 fin_fichier;
48:
49: long position_courante;
50:
51: struct_descripteur_fichier *dfichier;
52:
53: struct flock lock;
54:
55: struct_objet *s_objet_argument_1;
56: struct_objet *s_objet_argument_2;
57: struct_objet *s_objet_resultat;
58:
59: unsigned char caractere;
60: unsigned char *nom;
61: unsigned char *requete;
62: unsigned char verrou;
63:
64: unsigned long unite;
65:
66: (*s_etat_processus).erreur_execution = d_ex;
67:
68: if ((*s_etat_processus).affichage_arguments == 'Y')
69: {
70: printf("\n INQUIRE ");
71:
72: if ((*s_etat_processus).langue == 'F')
73: {
74: printf("(caractéristiques d'un fichier)\n\n");
75: }
76: else
77: {
78: printf("(file properties)\n\n");
79: }
80:
81: printf(" 2: %s, %s\n", d_FCH, d_CHN);
82: printf(" 1: %s\n", d_CHN);
83: printf("-> 1: %s, %s, %s\n\n", d_INT, d_CHN, d_LST);
84:
85: if ((*s_etat_processus).langue == 'F')
86: {
87: printf(" Requêtes par descripteur :\n\n");
88: }
89: else
90: {
91: printf(" Queries by descriptor:\n\n");
92: }
93:
94: printf(" END OF FILE : %s (true/false)\n", d_INT);
95: printf(" ACCESS : %s (SEQUENTIAL/DIRECT/KEYED)\n", d_CHN);
96: printf(" NAME : %s\n", d_CHN);
97: printf(" FORMATTED : %s (true/false)\n", d_INT);
98: printf(" KEY FIELD : %s\n", d_INT);
99: printf(" FORMAT : %s\n", d_LST);
100: printf(" PROTECTION : %s (WRITEONLY/READONLY/READWRITE)\n\n",
101: d_CHN);
102:
103: if ((*s_etat_processus).langue == 'F')
104: {
105: printf(" Requêtes par nom :\n\n");
106: }
107: else
108: {
109: printf(" Queries by name:\n\n");
110: }
111:
112: printf(" EXISTENCE : %s (true/false)\n", d_INT);
113: printf(" LOCK : %s (NONE/READ/WRITE)\n", d_CHN);
114:
115: return;
116: }
117: else if ((*s_etat_processus).test_instruction == 'Y')
118: {
119: (*s_etat_processus).nombre_arguments = -1;
120: return;
121: }
122:
123: if (test_cfsf(s_etat_processus, 31) == d_vrai)
124: {
125: if (empilement_pile_last(s_etat_processus, 2) == d_erreur)
126: {
127: return;
128: }
129: }
130:
131: if (depilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
132: &s_objet_argument_1) == d_erreur)
133: {
134: (*s_etat_processus).erreur_execution = d_ex_manque_argument;
135: return;
136: }
137:
138: if (depilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
139: &s_objet_argument_2) == d_erreur)
140: {
141: liberation(s_etat_processus, s_objet_argument_1);
142:
143: (*s_etat_processus).erreur_execution = d_ex_manque_argument;
144: return;
145: }
146:
147: if ((*s_objet_argument_1).type != CHN)
148: {
149: liberation(s_etat_processus, s_objet_argument_1);
150: liberation(s_etat_processus, s_objet_argument_2);
151:
152: (*s_etat_processus).erreur_execution = d_ex_erreur_type_argument;
153: return;
154: }
155:
156: if ((requete = conversion_majuscule(s_etat_processus, (unsigned char *)
157: (*s_objet_argument_1).objet)) == NULL)
158: {
159: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
160: return;
161: }
162:
163: if ((*s_objet_argument_2).type == FCH)
164: {
165: /*
166: * La question porte sur un fichier ouvert.
167: */
168:
169: if (strcmp(requete, "END OF FILE") == 0)
170: {
171: if ((*((struct_fichier *) (*s_objet_argument_2).objet)).acces
172: != 'S')
173: {
174: liberation(s_etat_processus, s_objet_argument_1);
175: liberation(s_etat_processus, s_objet_argument_2);
176:
177: free(requete);
178:
179: (*s_etat_processus).erreur_execution =
180: d_ex_erreur_requete_fichier;
181: return;
182: }
183:
184: if ((s_objet_resultat = allocation(s_etat_processus, INT))
185: == NULL)
186: {
187: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
188: return;
189: }
190:
191: if ((dfichier = descripteur_fichier(s_etat_processus,
192: (struct_fichier *) (*s_objet_argument_2).objet)) ==
193: NULL)
194: {
195: return;
196: }
197:
198: if ((*dfichier).type != 'C')
199: {
200: liberation(s_etat_processus, s_objet_argument_1);
201: liberation(s_etat_processus, s_objet_argument_2);
202:
203: free(requete);
204:
205: (*s_etat_processus).erreur_execution =
206: d_ex_erreur_type_fichier;
207: return;
208: }
209:
210: if ((*((struct_fichier *) (*s_objet_argument_2).objet)).binaire
211: != 'F')
212: {
213: /*
214: * La fin du fichier renvoyée ne correspond pas à la fin
215: * physique du fichier mais à un défaut d'enregistrement.
216: */
217:
218: if ((position_courante = ftell((*dfichier).descripteur_c))
219: == -1)
220: {
221: (*s_etat_processus).erreur_systeme = d_es_erreur_fichier;
222: return;
223: }
224:
225: fin_fichier = d_vrai;
226:
227: while(feof((*dfichier).descripteur_c) == 0)
228: {
229: if (fread(&caractere, sizeof(unsigned char), (size_t) 1,
230: (*dfichier).descripteur_c) > 0)
231: {
232: if (caractere == '{')
233: {
234: fin_fichier = d_faux;
235: break;
236: }
237: }
238: }
239:
240: if (fseek((*dfichier).descripteur_c, position_courante,
241: SEEK_SET) != 0)
242: {
243: (*s_etat_processus).erreur_systeme = d_es_erreur_fichier;
244: return;
245: }
246: }
247: else
248: {
249: // Fichier de type FLOW
250: if (feof((*dfichier).descripteur_c) == 0)
251: {
252: fin_fichier = d_faux;
253: }
254: else
255: {
256: fin_fichier = d_vrai;
257: }
258: }
259:
260: if (fin_fichier == d_faux)
261: {
262: /*
263: * Fichier à suivre
264: */
265:
266: (*((integer8 *) (*s_objet_resultat).objet)) = 0;
267: }
268: else
269: {
270: /*
271: * Fin de fichier
272: */
273:
274: (*((integer8 *) (*s_objet_resultat).objet)) = -1;
275: }
276: }
277: else if (strcmp(requete, "ACCESS") == 0)
278: {
279: if ((s_objet_resultat = allocation(s_etat_processus, CHN))
280: == NULL)
281: {
282: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
283: return;
284: }
285:
286: if ((*((struct_fichier *) (*s_objet_argument_2).objet)).acces
287: == 'S')
288: {
289: if (((*s_objet_resultat).objet = malloc(11 *
290: sizeof(unsigned char))) == NULL)
291: {
292: (*s_etat_processus).erreur_systeme =
293: d_es_allocation_memoire;
294: return;
295: }
296:
297: strcpy((unsigned char *) (*s_objet_resultat).objet,
298: "SEQUENTIAL");
299: }
300: else if ((*((struct_fichier *) (*s_objet_argument_2).objet)).acces
301: == 'D')
302: {
303: if (((*s_objet_resultat).objet = malloc(7 *
304: sizeof(unsigned char))) == NULL)
305: {
306: (*s_etat_processus).erreur_systeme =
307: d_es_allocation_memoire;
308: return;
309: }
310:
311: strcpy((unsigned char *) (*s_objet_resultat).objet,
312: "DIRECT");
313: }
314: else
315: {
316: if (((*s_objet_resultat).objet = malloc(6 *
317: sizeof(unsigned char))) == NULL)
318: {
319: (*s_etat_processus).erreur_systeme =
320: d_es_allocation_memoire;
321: return;
322: }
323:
324: strcpy((unsigned char *) (*s_objet_resultat).objet,
325: "KEYED");
326: }
327: }
328: else if (strcmp(requete, "NAME") == 0)
329: {
330: if ((s_objet_resultat = allocation(s_etat_processus, CHN))
331: == NULL)
332: {
333: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
334: return;
335: }
336:
337: if (((*s_objet_resultat).objet = malloc(
338: (strlen((*((struct_fichier *) (*s_objet_argument_2).objet))
339: .nom) + 1) *
340: sizeof(unsigned char))) == NULL)
341: {
342: (*s_etat_processus).erreur_systeme =
343: d_es_allocation_memoire;
344: return;
345: }
346:
347: strcpy((unsigned char *) (*s_objet_resultat).objet,
348: (*((struct_fichier *) (*s_objet_argument_2).objet)).nom);
349: }
350: else if (strcmp(requete, "FORMATTED") == 0)
351: {
352: if ((s_objet_resultat = allocation(s_etat_processus, INT))
353: == NULL)
354: {
355: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
356: return;
357: }
358:
359: (*((integer8 *) (*s_objet_resultat).objet)) =
360: ((*((struct_fichier *) (*s_objet_argument_2).objet)).binaire
361: == 'N') ? -1 : 0;
362: }
363: else if (strcmp(requete, "KEY FIELD") == 0)
364: {
365: if ((*((struct_fichier *) (*s_objet_argument_2).objet))
366: .acces == 'S')
367: {
368: free(requete);
369:
370: liberation(s_etat_processus, s_objet_argument_1);
371: liberation(s_etat_processus, s_objet_argument_2);
372:
373: (*s_etat_processus).erreur_execution =
374: d_ex_erreur_requete_fichier;
375: return;
376: }
377:
378: if ((s_objet_resultat = allocation(s_etat_processus, INT))
379: == NULL)
380: {
381: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
382: return;
383: }
384:
385: (*((integer8 *) (*s_objet_resultat).objet)) =
386: (*((struct_fichier *) (*s_objet_argument_2).objet))
387: .position_clef;
388: }
389: else if (strcmp(requete, "PROTECTION") == 0)
390: {
391: if ((s_objet_resultat = allocation(s_etat_processus, CHN))
392: == NULL)
393: {
394: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
395: return;
396: }
397:
398: if ((*((struct_fichier *) (*s_objet_argument_2).objet)).protection
399: == 'W')
400: {
401: if (((*s_objet_resultat).objet = malloc(10 *
402: sizeof(unsigned char))) == NULL)
403: {
404: (*s_etat_processus).erreur_systeme =
405: d_es_allocation_memoire;
406: return;
407: }
408:
409: strcpy((unsigned char *) (*s_objet_argument_2).objet,
410: "WRITEONLY");
411: }
412: else if ((*((struct_fichier *) (*s_objet_argument_2).objet)).acces
413: == 'R')
414: {
415: if (((*s_objet_resultat).objet = malloc(9 *
416: sizeof(unsigned char))) == NULL)
417: {
418: (*s_etat_processus).erreur_systeme =
419: d_es_allocation_memoire;
420: return;
421: }
422:
423: strcpy((unsigned char *) (*s_objet_argument_2).objet,
424: "READONLY");
425: }
426: else
427: {
428: if (((*s_objet_resultat).objet = malloc(10 *
429: sizeof(unsigned char))) == NULL)
430: {
431: (*s_etat_processus).erreur_systeme =
432: d_es_allocation_memoire;
433: return;
434: }
435:
436: strcpy((unsigned char *) (*s_objet_resultat).objet,
437: "READWRITE");
438: }
439: }
440: else if (strcmp(requete, "FORMAT") == 0)
441: {
442: if ((s_objet_resultat = copie_objet(s_etat_processus,
443: (*((struct_fichier *) (*s_objet_argument_2).objet)).format,
444: 'O')) == NULL)
445: {
446: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
447: return;
448: }
449: }
450: else
451: {
452: free(requete);
453:
454: liberation(s_etat_processus, s_objet_argument_1);
455: liberation(s_etat_processus, s_objet_argument_2);
456:
457: (*s_etat_processus).erreur_execution = d_ex_erreur_requete_fichier;
458: return;
459: }
460: }
461: else if ((*s_objet_argument_2).type == CHN)
462: {
463: /*
464: * La question porte sur un fichier fermé.
465: */
466:
467: if ((nom = transliteration(s_etat_processus,
468: (unsigned char *) (*s_objet_argument_2).objet,
469: d_locale, "UTF-8")) == NULL)
470: {
471: liberation(s_etat_processus, s_objet_argument_1);
472: liberation(s_etat_processus, s_objet_argument_2);
473: return;
474: }
475:
476: if (strcmp(requete, "EXISTENCE") == 0)
477: {
478: erreur = caracteristiques_fichier(s_etat_processus, nom,
479: &existence, &ouverture, &unite);
480:
481: if (erreur != d_absence_erreur)
482: {
483: free(nom);
484: free(requete);
485:
486: liberation(s_etat_processus, s_objet_argument_1);
487: liberation(s_etat_processus, s_objet_argument_2);
488:
489: (*s_etat_processus).erreur_execution =
490: d_ex_erreur_acces_fichier;
491: return;
492: }
493:
494: if ((s_objet_resultat = allocation(s_etat_processus, INT))
495: == NULL)
496: {
497: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
498: return;
499: }
500:
501: if (existence == d_faux)
502: {
503: /*
504: * Fichier inexistant
505: */
506:
507: (*((integer8 *) (*s_objet_resultat).objet)) = 0;
508: }
509: else
510: {
511: /*
512: * Fichier existant
513: */
514:
515: (*((integer8 *) (*s_objet_resultat).objet)) = -1;
516: }
517: }
518: else if (strcmp(requete, "LOCK") == 0)
519: {
520: erreur = caracteristiques_fichier(s_etat_processus, nom,
521: &existence, &ouverture, &unite);
522:
523: if (erreur != d_absence_erreur)
524: {
525: free(requete);
526: free(nom);
527:
528: liberation(s_etat_processus, s_objet_argument_1);
529: liberation(s_etat_processus, s_objet_argument_2);
530:
531: (*s_etat_processus).erreur_execution =
532: d_ex_erreur_acces_fichier;
533: return;
534: }
535:
536: if ((s_objet_resultat = allocation(s_etat_processus, CHN))
537: == NULL)
538: {
539: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
540: return;
541: }
542:
543: if (existence == d_faux)
544: {
545: /*
546: * Fichier inexistant
547: */
548:
549: free(requete);
550: free(nom);
551:
552: liberation(s_etat_processus, s_objet_argument_1);
553: liberation(s_etat_processus, s_objet_argument_2);
554: liberation(s_etat_processus, s_objet_resultat);
555:
556: (*s_etat_processus).erreur_execution =
557: d_ex_erreur_acces_fichier;
558: return;
559: }
560: else
561: {
562: /*
563: * Fichier existant
564: */
565:
566: if ((fichier = fopen(nom, "r+")) == NULL)
567: {
568: free(requete);
569: free(nom);
570:
571: liberation(s_etat_processus, s_objet_argument_1);
572: liberation(s_etat_processus, s_objet_argument_2);
573: liberation(s_etat_processus, s_objet_resultat);
574:
575: (*s_etat_processus).erreur_execution =
576: d_ex_erreur_acces_fichier;
577: return;
578: }
579:
580: lock.l_whence = SEEK_SET;
581: lock.l_start = 0;
582: lock.l_len = 0;
583: lock.l_pid = getpid();
584: lock.l_type = F_RDLCK;
585:
586: if (fcntl(fileno(fichier), F_GETLK, &lock) == -1)
587: {
588: free(nom);
589:
590: if (fclose(fichier) != 0)
591: {
592: free(requete);
593:
594: liberation(s_etat_processus, s_objet_argument_1);
595: liberation(s_etat_processus, s_objet_argument_2);
596: liberation(s_etat_processus, s_objet_resultat);
597:
598: (*s_etat_processus).erreur_systeme =
599: d_es_erreur_fichier;
600: return;
601: }
602:
603: free(requete);
604:
605: liberation(s_etat_processus, s_objet_argument_1);
606: liberation(s_etat_processus, s_objet_argument_2);
607: liberation(s_etat_processus, s_objet_resultat);
608:
609: (*s_etat_processus).erreur_systeme =
610: d_es_erreur_fichier;
611: return;
612: }
613:
614: if (lock.l_type == F_UNLCK)
615: {
616: verrou = 'N';
617: }
618: else
619: {
620: verrou = 'R';
621: }
622:
623: if (verrou == 'N')
624: {
625: lock.l_type = F_WRLCK;
626:
627: if (fcntl(fileno(fichier), F_GETLK, &lock) == -1)
628: {
629: free(nom);
630:
631: if (fclose(fichier) != 0)
632: {
633: free(requete);
634:
635: liberation(s_etat_processus, s_objet_argument_1);
636: liberation(s_etat_processus, s_objet_argument_2);
637: liberation(s_etat_processus, s_objet_resultat);
638:
639: (*s_etat_processus).erreur_systeme =
640: d_es_erreur_fichier;
641: return;
642: }
643:
644: free(requete);
645:
646: liberation(s_etat_processus, s_objet_argument_1);
647: liberation(s_etat_processus, s_objet_argument_2);
648: liberation(s_etat_processus, s_objet_resultat);
649:
650: (*s_etat_processus).erreur_systeme =
651: d_es_erreur_fichier;
652: return;
653: }
654:
655: if (lock.l_type == F_UNLCK)
656: {
657: verrou = 'N';
658: }
659: else
660: {
661: verrou = 'W';
662: }
663: }
664:
665: switch(verrou)
666: {
667: case 'N' :
668: {
669: if (((*s_objet_resultat).objet =
670: malloc(5 * sizeof(unsigned char))) == NULL)
671: {
672: (*s_etat_processus).erreur_systeme =
673: d_es_allocation_memoire;
674: return;
675: }
676:
677: strcpy((unsigned char *) (*s_objet_resultat).objet,
678: "NONE");
679:
680: break;
681: }
682:
683: case 'R' :
684: {
685: if (((*s_objet_resultat).objet =
686: malloc(5 * sizeof(unsigned char))) == NULL)
687: {
688: (*s_etat_processus).erreur_systeme =
689: d_es_allocation_memoire;
690: return;
691: }
692:
693: strcpy((unsigned char *) (*s_objet_resultat).objet,
694: "READ");
695:
696: break;
697: }
698:
699: case 'W' :
700: {
701: if (((*s_objet_resultat).objet =
702: malloc(6 * sizeof(unsigned char))) == NULL)
703: {
704: (*s_etat_processus).erreur_systeme =
705: d_es_allocation_memoire;
706: return;
707: }
708:
709: strcpy((unsigned char *) (*s_objet_resultat).objet,
710: "WRITE");
711:
712: break;
713: }
714: }
715:
716: if (fclose(fichier) != 0)
717: {
718: free(requete);
719: free(nom);
720:
721: liberation(s_etat_processus, s_objet_argument_1);
722: liberation(s_etat_processus, s_objet_argument_2);
723: liberation(s_etat_processus, s_objet_resultat);
724:
725: (*s_etat_processus).erreur_systeme = d_es_erreur_fichier;
726: return;
727: }
728: }
729: }
730: else
731: {
732: free(nom);
733: free(requete);
734:
735: liberation(s_etat_processus, s_objet_argument_1);
736: liberation(s_etat_processus, s_objet_argument_2);
737:
738: (*s_etat_processus).erreur_execution = d_ex_erreur_requete_fichier;
739: return;
740: }
741:
742: free(nom);
743: }
744: else
745: {
746: free(requete);
747:
748: liberation(s_etat_processus, s_objet_argument_1);
749: liberation(s_etat_processus, s_objet_argument_2);
750:
751: (*s_etat_processus).erreur_execution = d_ex_erreur_type_argument;
752: return;
753: }
754:
755: free(requete);
756:
757: liberation(s_etat_processus, s_objet_argument_1);
758: liberation(s_etat_processus, s_objet_argument_2);
759:
760: if (empilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
761: s_objet_resultat) == d_erreur)
762: {
763: return;
764: }
765:
766: return;
767: }
768:
769:
770: /*
771: ================================================================================
772: Fonction 'IDFT'
773: ================================================================================
774: Entrées : structure processus
775: --------------------------------------------------------------------------------
776: Sorties :
777: --------------------------------------------------------------------------------
778: Effets de bord : néant
779: ================================================================================
780: */
781:
782: void
783: instruction_idft(struct_processus *s_etat_processus)
784: {
785: integer4 erreur;
786: integer4 inverse;
787: integer4 nombre_colonnes;
788: integer4 nombre_lignes;
789:
790: logical1 presence_longueur_dft;
791:
792: integer8 longueur_dft_signee;
793:
794: struct_complexe16 *matrice_f77;
795:
796: struct_objet *s_objet_argument;
797: struct_objet *s_objet_longueur_dft;
798: struct_objet *s_objet_resultat;
799:
800: integer8 i;
801: integer8 j;
802: integer8 k;
803: integer8 longueur_dft;
804:
805: (*s_etat_processus).erreur_execution = d_ex;
806:
807: if ((*s_etat_processus).affichage_arguments == 'Y')
808: {
809: printf("\n IDFT ");
810:
811: if ((*s_etat_processus).langue == 'F')
812: {
813: printf("(transformée de Fourier inverse discrète)\n\n");
814: }
815: else
816: {
817: printf("(inverse of discrete Fourier transform)\n\n");
818: }
819:
820: printf(" 1: %s, %s, %s\n", d_VIN, d_VRL, d_VCX);
821: printf("-> 1: %s\n\n", d_VCX);
822:
823: printf(" 2: %s, %s, %s\n", d_VIN, d_VRL, d_VCX);
824: printf(" 1: %s\n", d_INT);
825: printf("-> 1: %s\n\n", d_VCX);
826:
827: printf(" 1: %s, %s, %s\n", d_MIN, d_MRL, d_MCX);
828: printf("-> 1: %s\n\n", d_VCX);
829:
830: printf(" 2: %s, %s, %s\n", d_MIN, d_MRL, d_MCX);
831: printf(" 1: %s\n", d_INT);
832: printf("-> 1: %s\n", d_MCX);
833:
834: return;
835: }
836: else if ((*s_etat_processus).test_instruction == 'Y')
837: {
838: (*s_etat_processus).nombre_arguments = -1;
839: return;
840: }
841:
842: /*
843: * Il est possible d'imposer une longueur de DFT au premier niveau
844: * de la pile.
845: */
846:
847: if ((*s_etat_processus).l_base_pile == NULL)
848: {
849: (*s_etat_processus).erreur_execution = d_ex_manque_argument;
850: return;
851: }
852:
853: if ((*(*(*s_etat_processus).l_base_pile).donnee).type == INT)
854: {
855: presence_longueur_dft = d_vrai;
856:
857: if (test_cfsf(s_etat_processus, 31) == d_vrai)
858: {
859: if (empilement_pile_last(s_etat_processus, 2) == d_erreur)
860: {
861: return;
862: }
863: }
864:
865: if (depilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
866: &s_objet_longueur_dft) == d_erreur)
867: {
868: (*s_etat_processus).erreur_execution = d_ex_manque_argument;
869: return;
870: }
871:
872: longueur_dft_signee = (*((integer8 *) (*s_objet_longueur_dft).objet));
873:
874: liberation(s_etat_processus, s_objet_longueur_dft);
875:
876: if (longueur_dft_signee <= 0)
877: {
878: (*s_etat_processus).erreur_execution = d_ex_longueur_dft;
879: return;
880: }
881:
882: longueur_dft = longueur_dft_signee;
883: }
884: else
885: {
886: presence_longueur_dft = d_faux;
887: longueur_dft = 0;
888:
889: if (test_cfsf(s_etat_processus, 31) == d_vrai)
890: {
891: if (empilement_pile_last(s_etat_processus, 1) == d_erreur)
892: {
893: return;
894: }
895: }
896: }
897:
898: if (depilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
899: &s_objet_argument) == d_erreur)
900: {
901: (*s_etat_processus).erreur_execution = d_ex_manque_argument;
902: return;
903: }
904:
905: /*
906: --------------------------------------------------------------------------------
907: Vecteur
908: --------------------------------------------------------------------------------
909: */
910:
911: if (((*s_objet_argument).type == VIN) ||
912: ((*s_objet_argument).type == VRL) ||
913: ((*s_objet_argument).type == VCX))
914: {
915: if (presence_longueur_dft == d_faux)
916: {
917: longueur_dft = (*((struct_vecteur *)
918: (*s_objet_argument).objet)).taille;
919: }
920:
921: if ((matrice_f77 = malloc(((size_t) longueur_dft) *
922: sizeof(struct_complexe16))) == NULL)
923: {
924: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
925: return;
926: }
927:
928: if ((*s_objet_argument).type == VIN)
929: {
930: for(i = 0; i < (*((struct_vecteur *) (*s_objet_argument).objet))
931: .taille; i++)
932: {
933: matrice_f77[i].partie_reelle = (real8) ((integer8 *)
934: (*((struct_vecteur *) (*s_objet_argument).objet))
935: .tableau)[i];
936: matrice_f77[i].partie_imaginaire = (real8) 0;
937: }
938: }
939: else if ((*s_objet_argument).type == VRL)
940: {
941: for(i = 0; i < (*((struct_vecteur *) (*s_objet_argument).objet))
942: .taille; i++)
943: {
944: matrice_f77[i].partie_reelle = ((real8 *)
945: (*((struct_vecteur *) (*s_objet_argument).objet))
946: .tableau)[i];
947: matrice_f77[i].partie_imaginaire = (real8) 0;
948: }
949: }
950: else
951: {
952: for(i = 0; i < (*((struct_vecteur *) (*s_objet_argument).objet))
953: .taille; i++)
954: {
955: matrice_f77[i].partie_reelle = ((struct_complexe16 *)
956: (*((struct_vecteur *) (*s_objet_argument).objet))
957: .tableau)[i].partie_reelle;
958: matrice_f77[i].partie_imaginaire = ((struct_complexe16 *)
959: (*((struct_vecteur *) (*s_objet_argument).objet))
960: .tableau)[i].partie_imaginaire;
961: }
962: }
963:
964: for(; i < longueur_dft; i++)
965: {
966: matrice_f77[i].partie_reelle = (real8) 0;
967: matrice_f77[i].partie_imaginaire = (real8) 0;
968: }
969:
970: nombre_lignes = 1;
971: nombre_colonnes = (integer4) longueur_dft;
972: inverse = -1;
973:
974: dft(matrice_f77, &nombre_lignes, &nombre_colonnes, &inverse, &erreur);
975:
976: if (erreur != 0)
977: {
978: liberation(s_etat_processus, s_objet_argument);
979: free(matrice_f77);
980:
981: (*s_etat_processus).erreur_execution = d_ex_longueur_dft;
982: return;
983: }
984:
985: if ((s_objet_resultat = allocation(s_etat_processus, VCX)) == NULL)
986: {
987: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
988: return;
989: }
990:
991: (*((struct_vecteur *) (*s_objet_resultat).objet)).taille = longueur_dft;
992: (*((struct_vecteur *) (*s_objet_resultat).objet)).tableau = matrice_f77;
993: }
994:
995: /*
996: --------------------------------------------------------------------------------
997: Matrice
998: --------------------------------------------------------------------------------
999: */
1000:
1001: else if (((*s_objet_argument).type == MIN) ||
1002: ((*s_objet_argument).type == MRL) ||
1003: ((*s_objet_argument).type == MCX))
1004: {
1005: if (presence_longueur_dft == d_faux)
1006: {
1007: longueur_dft = (*((struct_matrice *)
1008: (*s_objet_argument).objet)).nombre_colonnes;
1009: }
1010:
1011: if ((matrice_f77 = malloc(((size_t) longueur_dft) * ((size_t)
1012: (*((struct_matrice *) (*s_objet_argument).objet))
1013: .nombre_lignes) * sizeof(struct_complexe16))) == NULL)
1014: {
1015: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
1016: return;
1017: }
1018:
1019: if ((*s_objet_argument).type == MIN)
1020: {
1021: for(k = 0, j = 0; j < (*((struct_matrice *) (*s_objet_argument)
1022: .objet)).nombre_lignes; j++)
1023: {
1024: for(i = 0; i < (*((struct_matrice *) (*s_objet_argument)
1025: .objet)).nombre_colonnes; i++)
1026: {
1027: matrice_f77[k].partie_reelle = (real8) ((integer8 **)
1028: (*((struct_matrice *) (*s_objet_argument).objet))
1029: .tableau)[j][i];
1030: matrice_f77[k++].partie_imaginaire = (real8) 0;
1031: }
1032: }
1033:
1034: for(; k < longueur_dft * (*((struct_matrice *) (*s_objet_argument)
1035: .objet)).nombre_lignes; k++)
1036: {
1037: matrice_f77[k].partie_reelle = (real8) 0;
1038: matrice_f77[k].partie_imaginaire = (real8) 0;
1039: }
1040: }
1041: else if ((*s_objet_argument).type == MRL)
1042: {
1043: for(k = 0, j = 0; j < (*((struct_matrice *) (*s_objet_argument)
1044: .objet)).nombre_lignes; j++)
1045: {
1046: for(i = 0; i < (*((struct_matrice *) (*s_objet_argument)
1047: .objet)).nombre_colonnes; i++)
1048: {
1049: matrice_f77[k].partie_reelle = ((real8 **)
1050: (*((struct_matrice *) (*s_objet_argument).objet))
1051: .tableau)[j][i];
1052: matrice_f77[k++].partie_imaginaire = (real8) 0;
1053: }
1054: }
1055:
1056: for(; k < longueur_dft * (*((struct_matrice *) (*s_objet_argument)
1057: .objet)).nombre_lignes; k++)
1058: {
1059: matrice_f77[k].partie_reelle = (real8) 0;
1060: matrice_f77[k].partie_imaginaire = (real8) 0;
1061: }
1062: }
1063: else
1064: {
1065: for(k = 0, j = 0; j < (*((struct_matrice *) (*s_objet_argument)
1066: .objet)).nombre_lignes; j++)
1067: {
1068: for(i = 0; i < (*((struct_matrice *) (*s_objet_argument)
1069: .objet)).nombre_colonnes; i++)
1070: {
1071: matrice_f77[k].partie_reelle = ((struct_complexe16 **)
1072: (*((struct_matrice *) (*s_objet_argument).objet))
1073: .tableau)[j][i].partie_reelle;
1074: matrice_f77[k++].partie_imaginaire =
1075: ((struct_complexe16 **) (*((struct_matrice *)
1076: (*s_objet_argument).objet)).tableau)[j][i]
1077: .partie_imaginaire;
1078: }
1079: }
1080:
1081: for(; k < longueur_dft * (*((struct_matrice *) (*s_objet_argument)
1082: .objet)).nombre_lignes; k++)
1083: {
1084: matrice_f77[k].partie_reelle = (real8) 0;
1085: matrice_f77[k].partie_imaginaire = (real8) 0;
1086: }
1087: }
1088:
1089: nombre_lignes = (integer4) (*((struct_matrice *) (*s_objet_argument)
1090: .objet)).nombre_lignes;
1091: nombre_colonnes = (integer4) longueur_dft;
1092: inverse = -1;
1093:
1094: dft(matrice_f77, &nombre_lignes, &nombre_colonnes, &inverse, &erreur);
1095:
1096: if (erreur != 0)
1097: {
1098: liberation(s_etat_processus, s_objet_argument);
1099: free(matrice_f77);
1100:
1101: (*s_etat_processus).erreur_execution = d_ex_longueur_dft;
1102: return;
1103: }
1104:
1105: if ((s_objet_resultat = allocation(s_etat_processus, MCX)) == NULL)
1106: {
1107: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
1108: return;
1109: }
1110:
1111: (*((struct_matrice *) (*s_objet_resultat).objet)).nombre_lignes =
1112: (*((struct_matrice *) (*s_objet_argument).objet))
1113: .nombre_lignes;
1114: (*((struct_matrice *) (*s_objet_resultat).objet)).nombre_colonnes =
1115: longueur_dft;
1116:
1117: if (((*((struct_matrice *) (*s_objet_resultat).objet)).tableau =
1118: malloc(((size_t) (*((struct_matrice *) (*s_objet_resultat)
1119: .objet)).nombre_lignes) * sizeof(struct_complexe16 *))) == NULL)
1120: {
1121: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
1122: return;
1123: }
1124:
1125: for(i = 0; i < (*((struct_matrice *) (*s_objet_resultat).objet))
1126: .nombre_lignes; i++)
1127: {
1128: if ((((struct_complexe16 **) (*((struct_matrice *)
1129: (*s_objet_resultat).objet)).tableau)[i] =
1130: malloc(((size_t) (*((struct_matrice *)
1131: (*s_objet_resultat).objet)).nombre_colonnes) *
1132: sizeof(struct_complexe16))) == NULL)
1133: {
1134: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
1135: return;
1136: }
1137: }
1138:
1139: for(k = 0, j = 0; j < (*((struct_matrice *) (*s_objet_resultat).objet))
1140: .nombre_lignes; j++)
1141: {
1142: for(i = 0; i < (*((struct_matrice *) (*s_objet_resultat).objet))
1143: .nombre_colonnes; i++)
1144: {
1145: ((struct_complexe16 **) (*((struct_matrice *)
1146: (*s_objet_resultat).objet)).tableau)[j][i]
1147: .partie_reelle = matrice_f77[k].partie_reelle;
1148: ((struct_complexe16 **) (*((struct_matrice *)
1149: (*s_objet_resultat).objet)).tableau)[j][i]
1150: .partie_imaginaire = matrice_f77[k++].partie_imaginaire;
1151: }
1152: }
1153:
1154: free(matrice_f77);
1155: }
1156:
1157: /*
1158: --------------------------------------------------------------------------------
1159: Calcul de DFT impossible
1160: --------------------------------------------------------------------------------
1161: */
1162:
1163: else
1164: {
1165: liberation(s_etat_processus, s_objet_argument);
1166:
1167: (*s_etat_processus).erreur_execution = d_ex_erreur_type_argument;
1168: return;
1169: }
1170:
1171: liberation(s_etat_processus, s_objet_argument);
1172:
1173: if (empilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
1174: s_objet_resultat) == d_erreur)
1175: {
1176: return;
1177: }
1178:
1179: return;
1180: }
1181:
1182:
1183: /*
1184: ================================================================================
1185: Fonction 'ISWI'
1186: ================================================================================
1187: Entrées : structure processus
1188: --------------------------------------------------------------------------------
1189: Sorties :
1190: --------------------------------------------------------------------------------
1191: Effets de bord : néant
1192: ================================================================================
1193: */
1194:
1195: void
1196: instruction_iswi(struct_processus *s_etat_processus)
1197: {
1198: (*s_etat_processus).erreur_execution = d_ex;
1199:
1200: if ((*s_etat_processus).affichage_arguments == 'Y')
1201: {
1202: printf("\n ISWI ");
1203:
1204: if ((*s_etat_processus).langue == 'F')
1205: {
1206: printf("(autorise le traitement interruptif des interruptions)"
1207: "\n\n");
1208: printf(" Aucun argument\n");
1209: }
1210: else
1211: {
1212: printf("(authorize interrupts called from interrupts)\n\n");
1213: printf(" No argument\n");
1214: }
1215:
1216: return;
1217: }
1218: else if ((*s_etat_processus).test_instruction == 'Y')
1219: {
1220: (*s_etat_processus).nombre_arguments = -1;
1221: return;
1222: }
1223:
1224: if (test_cfsf(s_etat_processus, 31) == d_vrai)
1225: {
1226: if (empilement_pile_last(s_etat_processus, 0) == d_erreur)
1227: {
1228: return;
1229: }
1230: }
1231:
1232: if ((*s_etat_processus).traitement_interruption == 'Y')
1233: {
1234: (*s_etat_processus).traitement_interruption = 'N';
1235: }
1236: else
1237: {
1238: (*s_etat_processus).erreur_execution = d_ex_iswi_hors_interruption;
1239: }
1240:
1241: return;
1242: }
1243:
1244:
1245: /*
1246: ================================================================================
1247: Fonction 'ITRACE'
1248: ================================================================================
1249: Entrées : structure processus
1250: --------------------------------------------------------------------------------
1251: Sorties :
1252: --------------------------------------------------------------------------------
1253: Effets de bord : néant
1254: ================================================================================
1255: */
1256:
1257: void
1258: instruction_itrace(struct_processus *s_etat_processus)
1259: {
1260: struct_objet *s_objet_argument;
1261:
1262: (*s_etat_processus).erreur_execution = d_ex;
1263:
1264: if ((*s_etat_processus).affichage_arguments == 'Y')
1265: {
1266: printf("\n ITRACE ");
1267:
1268: if ((*s_etat_processus).langue == 'F')
1269: {
1270: printf("(trace interne)"
1271: "\n\n");
1272: }
1273: else
1274: {
1275: printf("(internal trace)\n\n");
1276: }
1277:
1278: printf(" 1: %s\n\n", d_BIN);
1279:
1280: if ((*s_etat_processus).langue == 'F')
1281: {
1282: printf(" Drapeaux :\n\n");
1283: }
1284: else
1285: {
1286: printf(" Flags:\n\n");
1287: }
1288:
1289: printf(" 0000 : none\n");
1290: printf(" 0001 : user stack\n");
1291: printf(" 0002 : system stack\n");
1292: printf(" 0004 : function calls\n");
1293: printf(" 0008 : process management\n");
1294: printf(" 0010 : analyze\n");
1295: printf(" 0020 : fuse management\n");
1296: printf(" 0040 : variables management\n");
1297: printf(" 0080 : intrinsic functions\n");
1298: printf(" 0100 : execution levels\n");
1299: printf(" 0200 : algebraic to RPN conversion\n");
1300: printf(" 0400 : interruptions supervision\n");
1301: printf(" 0800 : signals\n");
1302:
1303: return;
1304: }
1305: else if ((*s_etat_processus).test_instruction == 'Y')
1306: {
1307: (*s_etat_processus).nombre_arguments = -1;
1308: return;
1309: }
1310:
1311: if (test_cfsf(s_etat_processus, 31) == d_vrai)
1312: {
1313: if (empilement_pile_last(s_etat_processus, 1) == d_erreur)
1314: {
1315: return;
1316: }
1317: }
1318:
1319: if (depilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
1320: &s_objet_argument) == d_erreur)
1321: {
1322: (*s_etat_processus).erreur_execution = d_ex_manque_argument;
1323: return;
1324: }
1325:
1326: if ((*s_objet_argument).type == BIN)
1327: {
1328: if ((*((logical8 *) (*s_objet_argument).objet)) == 0)
1329: {
1330: (*s_etat_processus).debug = d_faux;
1331: (*s_etat_processus).type_debug = 0;
1332: }
1333: else
1334: {
1335: (*s_etat_processus).debug = d_vrai;
1336: (*s_etat_processus).type_debug = (*((logical8 *)
1337: (*s_objet_argument).objet));
1338: }
1339: }
1340: else
1341: {
1342: (*s_etat_processus).erreur_execution = d_ex_erreur_type_argument;
1343: liberation(s_etat_processus, s_objet_argument);
1344: }
1345:
1346: return;
1347: }
1348:
1349:
1350: // vim: ts=4
CVSweb interface <joel.bertrand@systella.fr>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to instructions_i3.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [local] / rpl / src