1: /*
2: ================================================================================
3: RPL/2 (R) version 4.0.17
4: Copyright (C) 1989-2010 Dr. BERTRAND Joël
5:
6: This file is part of RPL/2.
7:
8: RPL/2 is free software; you can redistribute it and/or modify it
9: under the terms of the CeCILL V2 License as published by the french
10: CEA, CNRS and INRIA.
11:
12: RPL/2 is distributed in the hope that it will be useful, but WITHOUT
13: ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
14: FITNESS FOR A PARTICULAR PURPOSE. See the CeCILL V2 License
15: for more details.
16:
17: You should have received a copy of the CeCILL License
18: along with RPL/2. If not, write to info@cecill.info.
19: ================================================================================
20: */
21:
22:
23: #include "rpl.conv.h"
24:
25:
26: /*
27: ================================================================================
28: Fonction 'bin'
29: ================================================================================
30: Entrées :
31: --------------------------------------------------------------------------------
32: Sorties :
33: --------------------------------------------------------------------------------
34: Effets de bord : néant
35: ================================================================================
36: */
37:
38: void
39: instruction_bin(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 BIN ");
46:
47: if ((*s_etat_processus).langue == 'F')
48: {
49: printf("(base binaire)\n\n");
50: printf(" Aucun argument\n");
51: }
52: else
53: {
54: printf("(binary base)\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: 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:
74: cf(s_etat_processus, 43);
75: sf(s_etat_processus, 44);
76:
77: return;
78: }
79:
80:
81: /*
82: ================================================================================
83: Fonction 'beep'
84: ================================================================================
85: Entrées :
86: --------------------------------------------------------------------------------
87: Sorties :
88: --------------------------------------------------------------------------------
89: Effets de bord : néant
90: ================================================================================
91: */
92:
93: void
94: instruction_beep(struct_processus *s_etat_processus)
95: {
96: (*s_etat_processus).erreur_execution = d_ex;
97:
98: if ((*s_etat_processus).affichage_arguments == 'Y')
99: {
100: printf("\n BEEP ");
101:
102: if ((*s_etat_processus).langue == 'F')
103: {
104: printf("(son d'avertissement)\n\n");
105: printf(" Aucun argument\n");
106: }
107: else
108: {
109: printf("(warning bell)\n\n");
110: printf(" No argument\n");
111: }
112:
113: return;
114: }
115: else if ((*s_etat_processus).test_instruction == 'Y')
116: {
117: (*s_etat_processus).nombre_arguments = -1;
118: return;
119: }
120:
121: if (test_cfsf(s_etat_processus, 31) == d_vrai)
122: {
123: if (empilement_pile_last(s_etat_processus, 0) == d_erreur)
124: {
125: return;
126: }
127: }
128:
129: if (test_cfsf(s_etat_processus, 51) == d_faux)
130: {
131: printf("%s", ds_beep);
132: }
133:
134: return;
135: }
136:
137:
138: /*
139: ================================================================================
140: Fonction 'b->r'
141: ================================================================================
142: Entrées : pointeur sur une structure struct_processus
143: --------------------------------------------------------------------------------
144: Sorties :
145: --------------------------------------------------------------------------------
146: Effets de bord : néant
147: ================================================================================
148: */
149:
150: void
151: instruction_b_vers_r(struct_processus *s_etat_processus)
152: {
153: struct_objet *s_objet_argument;
154: struct_objet *s_objet_resultat;
155:
156: (*s_etat_processus).erreur_execution = d_ex;
157:
158: if ((*s_etat_processus).affichage_arguments == 'Y')
159: {
160: printf("\n B->R ");
161:
162: if ((*s_etat_processus).langue == 'F')
163: {
164: printf("(binaire vers réel)\n\n");
165: }
166: else
167: {
168: printf("(binary to real)\n\n");
169: }
170:
171: printf(" 1: %s\n", d_BIN);
172: printf("-> 1: %s\n", d_INT);
173:
174: return;
175: }
176: else if ((*s_etat_processus).test_instruction == 'Y')
177: {
178: (*s_etat_processus).nombre_arguments = -1;
179: return;
180: }
181:
182: if (test_cfsf(s_etat_processus, 31) == d_vrai)
183: {
184: if (empilement_pile_last(s_etat_processus, 1) == d_erreur)
185: {
186: return;
187: }
188: }
189:
190: if (depilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
191: &s_objet_argument) == d_erreur)
192: {
193: (*s_etat_processus).erreur_execution = d_ex_manque_argument;
194: return;
195: }
196:
197: if ((*s_objet_argument).type == BIN)
198: {
199: if ((s_objet_resultat = allocation(s_etat_processus, INT))
200: == NULL)
201: {
202: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
203: return;
204: }
205:
206: (*((integer8 *) (*s_objet_resultat).objet)) = (*((logical8 *)
207: (*s_objet_argument).objet));
208: }
209: else
210: {
211: liberation(s_etat_processus, s_objet_argument);
212:
213: (*s_etat_processus).erreur_execution = d_ex_erreur_type_argument;
214: return;
215: }
216:
217: if (empilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
218: s_objet_resultat) == d_erreur)
219: {
220: return;
221: }
222:
223: liberation(s_etat_processus, s_objet_argument);
224:
225: return;
226: }
227:
228:
229: /*
230: ================================================================================
231: Fonction 'backspace'
232: ================================================================================
233: Entrées :
234: --------------------------------------------------------------------------------
235: Sorties :
236: --------------------------------------------------------------------------------
237: Effets de bord : néant
238: ================================================================================
239: */
240:
241: void
242: instruction_backspace(struct_processus *s_etat_processus)
243: {
244: struct_descripteur_fichier *descripteur;
245:
246: integer8 position_finale;
247: integer8 position_initiale;
248:
249: logical1 presence_chaine;
250: logical1 presence_indicateur;
251:
252: long pointeur;
253: long niveau;
254:
255: size_t longueur_effective;
256: size_t longueur_questure;
257:
258: struct flock lock;
259:
260: struct_objet *s_objet_argument;
261:
262: unsigned char *tampon_lecture;
263:
264: (*s_etat_processus).erreur_execution = d_ex;
265:
266: if ((*s_etat_processus).affichage_arguments == 'Y')
267: {
268: printf("\n BACKSPACE ");
269:
270: if ((*s_etat_processus).langue == 'F')
271: {
272: printf("(retour à l'enregistrement précédent)\n\n");
273: }
274: else
275: {
276: printf("(return to the previous record)\n\n");
277: }
278:
279: printf(" 1: %s\n", d_FCH);
280:
281: return;
282: }
283: else if ((*s_etat_processus).test_instruction == 'Y')
284: {
285: (*s_etat_processus).nombre_arguments = -1;
286: return;
287: }
288:
289: if (test_cfsf(s_etat_processus, 31) == d_vrai)
290: {
291: if (empilement_pile_last(s_etat_processus, 1) == d_erreur)
292: {
293: return;
294: }
295: }
296:
297: if (depilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
298: &s_objet_argument) == d_erreur)
299: {
300: (*s_etat_processus).erreur_execution = d_ex_manque_argument;
301: return;
302: }
303:
304: if ((*s_objet_argument).type == FCH)
305: {
306: /*
307: * Fichiers à accès séquentiel
308: */
309:
310: if ((*((struct_fichier *) (*s_objet_argument).objet)).acces == 'S')
311: {
312: /*
313: * Vérification des verrous
314: */
315:
316: lock.l_type = F_RDLCK;
317: lock.l_whence = SEEK_SET;
318: lock.l_start = 0;
319: lock.l_len = 0;
320: lock.l_pid = getpid();
321:
322: if ((descripteur = descripteur_fichier(s_etat_processus,
323: (struct_fichier *) (*s_objet_argument).objet)) == NULL)
324: {
325: liberation(s_etat_processus, s_objet_argument);
326: return;
327: }
328:
329: if (fcntl(fileno((*descripteur).descripteur_c), F_GETLK, &lock)
330: == -1)
331: {
332: liberation(s_etat_processus, s_objet_argument);
333:
334: (*s_etat_processus).erreur_systeme = d_es_erreur_fichier;
335: return;
336: }
337:
338: if (lock.l_type != F_UNLCK)
339: {
340: liberation(s_etat_processus, s_objet_argument);
341:
342: (*s_etat_processus).erreur_execution =
343: d_ex_fichier_verrouille;
344: return;
345: }
346:
347: if ((*((struct_fichier *) (*s_objet_argument).objet)).binaire
348: == 'N')
349: {
350: /*
351: * Fichiers formatés
352: */
353:
354: if ((position_finale = ftell((*descripteur).descripteur_c))
355: == -1)
356: {
357: liberation(s_etat_processus, s_objet_argument);
358:
359: (*s_etat_processus).erreur_systeme = d_es_erreur_fichier;
360: return;
361: }
362:
363: longueur_questure = 256;
364:
365: if ((tampon_lecture = malloc(longueur_questure *
366: sizeof(unsigned char))) == NULL)
367: {
368: (*s_etat_processus).erreur_systeme =
369: d_es_allocation_memoire;
370: return;
371: }
372:
373: do
374: {
375: if ((position_initiale = (position_finale -
376: longueur_questure)) < 0)
377: {
378: position_initiale = 0;
379: longueur_effective = position_finale + 1;
380: }
381: else
382: {
383: longueur_effective = longueur_questure;
384: }
385:
386: if (fseek((*descripteur).descripteur_c, position_initiale,
387: SEEK_SET) != 0)
388: {
389: (*s_etat_processus).erreur_systeme =
390: d_es_erreur_fichier;
391: return;
392: }
393:
394: longueur_effective = fread(tampon_lecture,
395: (size_t) sizeof(unsigned char), longueur_effective,
396: (*descripteur).descripteur_c);
397:
398: pointeur = longueur_effective - 1;
399: presence_indicateur = d_faux;
400:
401: while((pointeur >= 0) && (presence_indicateur == d_faux))
402: {
403: if (tampon_lecture[pointeur] == '}')
404: {
405: presence_indicateur = d_vrai;
406: }
407: else
408: {
409: position_finale--;
410: pointeur--;
411: }
412: }
413: } while((longueur_effective == longueur_questure) &&
414: (presence_indicateur == d_faux));
415:
416: if (presence_indicateur == d_faux)
417: {
418: /*
419: * Le début du fichier est atteint.
420: */
421:
422: if (fseek((*descripteur).descripteur_c, 0, SEEK_SET) != 0)
423: {
424: liberation(s_etat_processus, s_objet_argument);
425: free(tampon_lecture);
426:
427: (*s_etat_processus).erreur_systeme =
428: d_es_erreur_fichier;
429: return;
430: }
431:
432: (*s_etat_processus).erreur_execution =
433: d_ex_debut_de_fichier_atteint;
434:
435: liberation(s_etat_processus, s_objet_argument);
436: free(tampon_lecture);
437:
438: return;
439: }
440:
441: position_finale = position_finale - 1;
442: presence_chaine = d_faux;
443: niveau = 1;
444:
445: if (position_finale < 0)
446: {
447: liberation(s_etat_processus, s_objet_argument);
448: free(tampon_lecture);
449:
450: (*s_etat_processus).erreur_execution =
451: d_ex_debut_de_fichier_atteint;
452: return;
453: }
454:
455: do
456: {
457: if ((position_initiale = (position_finale -
458: longueur_questure)) < 0)
459: {
460: position_initiale = 0;
461: longueur_effective = position_finale + 1;
462: }
463: else
464: {
465: longueur_effective = longueur_questure;
466: position_finale--;
467: }
468:
469: if (fseek((*descripteur).descripteur_c, position_initiale,
470: SEEK_SET) != 0)
471: {
472: (*s_etat_processus).erreur_systeme =
473: d_es_erreur_fichier;
474: return;
475: }
476:
477: longueur_effective = fread(tampon_lecture,
478: (size_t) sizeof(unsigned char), longueur_effective,
479: (*descripteur).descripteur_c);
480:
481: pointeur = longueur_effective - 1;
482: presence_indicateur = d_faux;
483:
484: while((pointeur >= 0) && (presence_indicateur == d_faux))
485: {
486: if (tampon_lecture[pointeur] == '"')
487: {
488: presence_chaine = (presence_chaine == d_vrai)
489: ? d_faux : d_vrai;
490: }
491: else
492: {
493: if (tampon_lecture[pointeur] == '}')
494: {
495: niveau++;
496: }
497: else if (tampon_lecture[pointeur] == '{')
498: {
499: niveau--;
500: }
501: }
502:
503: if (niveau == 0)
504: {
505: presence_indicateur = d_vrai;
506: }
507: else
508: {
509: position_finale--;
510: pointeur--;
511: }
512: }
513: } while((longueur_effective == longueur_questure) &&
514: (presence_indicateur == d_faux));
515:
516: if (presence_indicateur == d_faux)
517: {
518: liberation(s_etat_processus, s_objet_argument);
519: free(tampon_lecture);
520:
521: (*s_etat_processus).erreur_execution =
522: d_ex_fin_de_fichier_atteinte;
523: return;
524: }
525:
526: if (fseek((*descripteur).descripteur_c, position_finale,
527: SEEK_SET) != 0)
528: {
529: liberation(s_etat_processus, s_objet_argument);
530: free(tampon_lecture);
531:
532: (*s_etat_processus).erreur_systeme = d_es_erreur_fichier;
533: return;
534: }
535:
536: free(tampon_lecture);
537: }
538: else
539: {
540: /*
541: * Fichiers non formatés
542: */
543: }
544: }
545: else
546: {
547: liberation(s_etat_processus, s_objet_argument);
548:
549: (*s_etat_processus).erreur_execution = d_ex_erreur_type_fichier;
550: return;
551: }
552: }
553: else
554: {
555: liberation(s_etat_processus, s_objet_argument);
556:
557: (*s_etat_processus).erreur_execution = d_ex_erreur_type_argument;
558: return;
559: }
560:
561: liberation(s_etat_processus, s_objet_argument);
562:
563: return;
564: }
565:
566:
567: /*
568: ================================================================================
569: Fonction 'bessel'
570: ================================================================================
571: Entrées :
572: --------------------------------------------------------------------------------
573: Sorties :
574: --------------------------------------------------------------------------------
575: Effets de bord : néant
576: ================================================================================
577: */
578:
579: void
580: instruction_bessel(struct_processus *s_etat_processus)
581: {
582: logical1 creation_expression;
583:
584: struct_liste_chainee *l_element_atome;
585: struct_liste_chainee *l_element_courant;
586: struct_liste_chainee *l_element_precedent;
587:
588: struct_objet *s_copie_argument_1;
589: struct_objet *s_copie_argument_2;
590: struct_objet *s_copie_argument_3;
591: struct_objet *s_objet_argument_1;
592: struct_objet *s_objet_argument_2;
593: struct_objet *s_objet_argument_3;
594: struct_objet *s_objet_resultat;
595:
596: unsigned long i;
597:
598: (*s_etat_processus).erreur_execution = d_ex;
599:
600: if ((*s_etat_processus).affichage_arguments == 'Y')
601: {
602: printf("\n BESSEL ");
603:
604: if ((*s_etat_processus).langue == 'F')
605: {
606: printf("(fonctions de Bessel)\n\n");
607: }
608: else
609: {
610: printf("(Bessel functions)\n\n");
611: }
612:
613: printf(" 3: \"J\", \"Y\", \"I\", \"K\", \"j\", \"y\", "
614: "\"i\", \"k\"\n");
615: printf(" 2: %s, %s\n", d_INT, d_REL);
616: printf(" 1: %s, %s\n", d_INT, d_REL);
617: printf("-> 1: %s\n\n", d_REL);
618:
619: printf(" 3: \"J\", \"Y\", \"I\", \"K\", \"j\", \"y\", "
620: "\"i\", \"k\"\n");
621: printf(" 2: %s, %s\n", d_INT, d_REL);
622: printf(" 1: %s, %s\n", d_NOM, d_ALG);
623: printf("-> 1: %s\n\n", d_ALG);
624:
625: printf(" 3: \"J\", \"Y\", \"I\", \"K\", \"j\", \"y\", "
626: "\"i\", \"k\"\n");
627: printf(" 2: %s, %s\n", d_INT, d_REL);
628: printf(" 1: %s\n", d_RPN);
629: printf("-> 1: %s\n", d_RPN);
630: return;
631: }
632: else if ((*s_etat_processus).test_instruction == 'Y')
633: {
634: (*s_etat_processus).nombre_arguments = 3;
635: return;
636: }
637:
638: if (test_cfsf(s_etat_processus, 31) == d_vrai)
639: {
640: if (empilement_pile_last(s_etat_processus, 3) == d_erreur)
641: {
642: return;
643: }
644: }
645:
646: /*
647: * Jn fonction cylindrique régulière
648: * Yn fonction cylindrique irrégulière
649: * In fonction cylindrique régulière modifiée
650: * Kn fonction cylindrique irrégulière modifiée
651: * jn fonction sphérique régulière
652: * yn fonction sphérique irrégulière
653: * in fonction sphérique régulière modifiée
654: * kn fonction sphérique irrégulière modifiée
655: *
656: * Attention : Ordre fractionnaire uniquement pour les
657: * fonctions cylindriques
658: */
659:
660: creation_expression = d_faux;
661:
662: if (depilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
663: &s_objet_argument_1) == d_erreur)
664: {
665: (*s_etat_processus).erreur_execution = d_ex_manque_argument;
666: return;
667: }
668:
669: if (depilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
670: &s_objet_argument_2) == d_erreur)
671: {
672: liberation(s_etat_processus, s_objet_argument_1);
673:
674: (*s_etat_processus).erreur_execution = d_ex_manque_argument;
675: return;
676: }
677:
678: if (depilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
679: &s_objet_argument_3) == d_erreur)
680: {
681: liberation(s_etat_processus, s_objet_argument_1);
682: liberation(s_etat_processus, s_objet_argument_2);
683:
684: (*s_etat_processus).erreur_execution = d_ex_manque_argument;
685: return;
686: }
687:
688: if ((*s_objet_argument_3).type == CHN)
689: {
690: if ((strcmp((unsigned char *) (*s_objet_argument_3).objet, "J") == 0) ||
691: (strcmp((unsigned char *) (*s_objet_argument_3).objet, "Y")
692: == 0) || (strcmp((unsigned char *) (*s_objet_argument_3).objet,
693: "I") == 0) || (strcmp((unsigned char *) (*s_objet_argument_3)
694: .objet, "K") == 0) || (strcmp((unsigned char *)
695: (*s_objet_argument_3).objet, "j") == 0) || (strcmp(
696: (unsigned char *) (*s_objet_argument_3).objet, "y") == 0) ||
697: (strcmp((unsigned char *) (*s_objet_argument_3).objet, "i") ==
698: 0) || (strcmp((unsigned char *) (*s_objet_argument_3).objet,
699: "k") == 0))
700: {
701: if ((*s_objet_argument_2).type == INT)
702: {
703: if ((*s_objet_argument_1).type == INT)
704: {
705: if ((s_objet_resultat = allocation(s_etat_processus, REL))
706: == NULL)
707: {
708: (*s_etat_processus).erreur_systeme =
709: d_es_allocation_memoire;
710: return;
711: }
712:
713: switch((*((unsigned char *) (*s_objet_argument_3).objet)))
714: {
715: case 'J' :
716: {
717: (*((real8 *) (*s_objet_resultat).objet)) =
718: gsl_sf_bessel_Jn((int) ((*((integer8 *)
719: (*s_objet_argument_2).objet))),
720: (double) ((*((integer8 *)
721: (*s_objet_argument_1).objet))));
722: break;
723: }
724:
725: case 'Y' :
726: {
727: if ((*((integer8 *) (*s_objet_argument_1).objet))
728: <= 0)
729: {
730: (*s_etat_processus).exception =
731: d_ep_resultat_indefini;
732:
733: liberation(s_etat_processus,
734: s_objet_argument_1);
735: liberation(s_etat_processus,
736: s_objet_argument_2);
737: liberation(s_etat_processus,
738: s_objet_argument_3);
739: liberation(s_etat_processus,
740: s_objet_resultat);
741:
742: return;
743: }
744:
745: (*((real8 *) (*s_objet_resultat).objet)) =
746: gsl_sf_bessel_Yn((int) ((*((integer8 *)
747: (*s_objet_argument_2).objet))),
748: (double) ((*((integer8 *)
749: (*s_objet_argument_1).objet))));
750: break;
751: }
752:
753: case 'I' :
754: {
755: (*((real8 *) (*s_objet_resultat).objet)) =
756: gsl_sf_bessel_In((int) ((*((integer8 *)
757: (*s_objet_argument_2).objet))),
758: (double) ((*((integer8 *)
759: (*s_objet_argument_1).objet))));
760: break;
761: }
762:
763: case 'K' :
764: {
765: if ((*((integer8 *) (*s_objet_argument_1).objet))
766: <= 0)
767: {
768: (*s_etat_processus).exception =
769: d_ep_resultat_indefini;
770:
771: liberation(s_etat_processus,
772: s_objet_argument_1);
773: liberation(s_etat_processus,
774: s_objet_argument_2);
775: liberation(s_etat_processus,
776: s_objet_argument_3);
777: liberation(s_etat_processus,
778: s_objet_resultat);
779:
780: return;
781: }
782:
783: (*((real8 *) (*s_objet_resultat).objet)) =
784: gsl_sf_bessel_Kn((int) ((*((integer8 *)
785: (*s_objet_argument_2).objet))),
786: (double) ((*((integer8 *)
787: (*s_objet_argument_1).objet))));
788: break;
789: }
790:
791: case 'j' :
792: {
793: if (((*((integer8 *) (*s_objet_argument_1).objet))
794: < 0) || ((*((integer8 *)
795: (*s_objet_argument_2).objet)) < 0))
796: {
797: (*s_etat_processus).exception =
798: d_ep_resultat_indefini;
799:
800: liberation(s_etat_processus,
801: s_objet_argument_1);
802: liberation(s_etat_processus,
803: s_objet_argument_2);
804: liberation(s_etat_processus,
805: s_objet_argument_3);
806: liberation(s_etat_processus,
807: s_objet_resultat);
808:
809: return;
810: }
811:
812: (*((real8 *) (*s_objet_resultat).objet)) =
813: gsl_sf_bessel_jl((int) ((*((integer8 *)
814: (*s_objet_argument_2).objet))),
815: (double) ((*((integer8 *)
816: (*s_objet_argument_1).objet))));
817: break;
818: }
819:
820: case 'y' :
821: {
822: if (((*((integer8 *) (*s_objet_argument_1).objet))
823: <= 0) || ((*((integer8 *)
824: (*s_objet_argument_2).objet)) < 0))
825: {
826: (*s_etat_processus).exception =
827: d_ep_resultat_indefini;
828:
829: liberation(s_etat_processus,
830: s_objet_argument_1);
831: liberation(s_etat_processus,
832: s_objet_argument_2);
833: liberation(s_etat_processus,
834: s_objet_argument_3);
835: liberation(s_etat_processus,
836: s_objet_resultat);
837:
838: return;
839: }
840:
841: (*((real8 *) (*s_objet_resultat).objet)) =
842: gsl_sf_bessel_yl((int) ((*((integer8 *)
843: (*s_objet_argument_2).objet))),
844: (double) ((*((integer8 *)
845: (*s_objet_argument_1).objet))));
846: break;
847: }
848:
849: case 'i' :
850: {
851: if ((*((integer8 *) (*s_objet_argument_2).objet))
852: < 0)
853: {
854: (*s_etat_processus).exception =
855: d_ep_resultat_indefini;
856:
857: liberation(s_etat_processus,
858: s_objet_argument_1);
859: liberation(s_etat_processus,
860: s_objet_argument_2);
861: liberation(s_etat_processus,
862: s_objet_argument_3);
863: liberation(s_etat_processus,
864: s_objet_resultat);
865:
866: return;
867: }
868:
869: (*((real8 *) (*s_objet_resultat).objet)) =
870: exp(fabs((double) (*((integer8 *)
871: (*s_objet_argument_1).objet)))) *
872: gsl_sf_bessel_il_scaled(
873: (int) ((*((integer8 *)
874: (*s_objet_argument_2).objet))),
875: (double) ((*((integer8 *)
876: (*s_objet_argument_1).objet))));
877: break;
878: }
879:
880: case 'k' :
881: {
882: if (((*((integer8 *) (*s_objet_argument_1).objet))
883: <= 0) || ((*((integer8 *)
884: (*s_objet_argument_2).objet)) < 0))
885: {
886: (*s_etat_processus).exception =
887: d_ep_resultat_indefini;
888:
889: liberation(s_etat_processus,
890: s_objet_argument_1);
891: liberation(s_etat_processus,
892: s_objet_argument_2);
893: liberation(s_etat_processus,
894: s_objet_argument_3);
895: liberation(s_etat_processus,
896: s_objet_resultat);
897:
898: return;
899: }
900:
901: (*((real8 *) (*s_objet_resultat).objet)) =
902: exp(fabs((double) (*((integer8 *)
903: (*s_objet_argument_1).objet)))) *
904: gsl_sf_bessel_kl_scaled(
905: (int) ((*((integer8 *)
906: (*s_objet_argument_2).objet))),
907: (double) ((*((integer8 *)
908: (*s_objet_argument_1).objet))));
909: break;
910: }
911: }
912: }
913: else if ((*s_objet_argument_1).type == REL)
914: {
915: if ((s_objet_resultat = allocation(s_etat_processus, REL))
916: == NULL)
917: {
918: (*s_etat_processus).erreur_systeme =
919: d_es_allocation_memoire;
920: return;
921: }
922:
923: switch((*((unsigned char *) (*s_objet_argument_3).objet)))
924: {
925: case 'J' :
926: {
927: (*((real8 *) (*s_objet_resultat).objet)) =
928: gsl_sf_bessel_Jn((int) ((*((integer8 *)
929: (*s_objet_argument_2).objet))),
930: (double) ((*((real8 *)
931: (*s_objet_argument_1).objet))));
932: break;
933: }
934:
935: case 'Y' :
936: {
937: if ((*((real8 *) (*s_objet_argument_1).objet))
938: <= 0)
939: {
940: (*s_etat_processus).exception =
941: d_ep_resultat_indefini;
942:
943: liberation(s_etat_processus,
944: s_objet_argument_1);
945: liberation(s_etat_processus,
946: s_objet_argument_2);
947: liberation(s_etat_processus,
948: s_objet_argument_3);
949: liberation(s_etat_processus,
950: s_objet_resultat);
951:
952: return;
953: }
954:
955: (*((real8 *) (*s_objet_resultat).objet)) =
956: gsl_sf_bessel_Yn((int) ((*((integer8 *)
957: (*s_objet_argument_2).objet))),
958: (double) ((*((real8 *)
959: (*s_objet_argument_1).objet))));
960: break;
961: }
962:
963: case 'I' :
964: {
965: (*((real8 *) (*s_objet_resultat).objet)) =
966: gsl_sf_bessel_In((int) ((*((integer8 *)
967: (*s_objet_argument_2).objet))),
968: (double) ((*((real8 *)
969: (*s_objet_argument_1).objet))));
970: break;
971: }
972:
973: case 'K' :
974: {
975: if ((*((real8 *) (*s_objet_argument_1).objet))
976: <= 0)
977: {
978: (*s_etat_processus).exception =
979: d_ep_resultat_indefini;
980:
981: liberation(s_etat_processus,
982: s_objet_argument_1);
983: liberation(s_etat_processus,
984: s_objet_argument_2);
985: liberation(s_etat_processus,
986: s_objet_argument_3);
987: liberation(s_etat_processus,
988: s_objet_resultat);
989:
990: return;
991: }
992:
993: (*((real8 *) (*s_objet_resultat).objet)) =
994: gsl_sf_bessel_Kn((int) ((*((integer8 *)
995: (*s_objet_argument_2).objet))),
996: (double) ((*((real8 *)
997: (*s_objet_argument_1).objet))));
998: break;
999: }
1000:
1001: case 'j' :
1002: {
1003: if (((*((integer8 *) (*s_objet_argument_1).objet))
1004: < 0) || ((*((integer8 *)
1005: (*s_objet_argument_2).objet)) < 0))
1006: {
1007: (*s_etat_processus).exception =
1008: d_ep_resultat_indefini;
1009:
1010: liberation(s_etat_processus,
1011: s_objet_argument_1);
1012: liberation(s_etat_processus,
1013: s_objet_argument_2);
1014: liberation(s_etat_processus,
1015: s_objet_argument_3);
1016: liberation(s_etat_processus,
1017: s_objet_resultat);
1018:
1019: return;
1020: }
1021:
1022: (*((real8 *) (*s_objet_resultat).objet)) =
1023: gsl_sf_bessel_jl((int) ((*((integer8 *)
1024: (*s_objet_argument_2).objet))),
1025: (double) ((*((real8 *)
1026: (*s_objet_argument_1).objet))));
1027: break;
1028: }
1029:
1030: case 'y' :
1031: {
1032: if (((*((integer8 *) (*s_objet_argument_1).objet))
1033: <= 0) || ((*((integer8 *)
1034: (*s_objet_argument_2).objet)) < 0))
1035: {
1036: (*s_etat_processus).exception =
1037: d_ep_resultat_indefini;
1038:
1039: liberation(s_etat_processus,
1040: s_objet_argument_1);
1041: liberation(s_etat_processus,
1042: s_objet_argument_2);
1043: liberation(s_etat_processus,
1044: s_objet_argument_3);
1045: liberation(s_etat_processus,
1046: s_objet_resultat);
1047:
1048: return;
1049: }
1050:
1051: (*((real8 *) (*s_objet_resultat).objet)) =
1052: gsl_sf_bessel_yl((int) ((*((integer8 *)
1053: (*s_objet_argument_2).objet))),
1054: (double) ((*((real8 *)
1055: (*s_objet_argument_1).objet))));
1056: break;
1057: }
1058:
1059: case 'i' :
1060: {
1061: if ((*((integer8 *) (*s_objet_argument_2).objet))
1062: < 0)
1063: {
1064: (*s_etat_processus).exception =
1065: d_ep_resultat_indefini;
1066:
1067: liberation(s_etat_processus,
1068: s_objet_argument_1);
1069: liberation(s_etat_processus,
1070: s_objet_argument_2);
1071: liberation(s_etat_processus,
1072: s_objet_argument_3);
1073: liberation(s_etat_processus,
1074: s_objet_resultat);
1075:
1076: return;
1077: }
1078:
1079: (*((real8 *) (*s_objet_resultat).objet)) =
1080: exp(fabs((double) (*((real8 *)
1081: (*s_objet_argument_1).objet)))) *
1082: gsl_sf_bessel_il_scaled(
1083: (int) ((*((integer8 *)
1084: (*s_objet_argument_2).objet))),
1085: (double) ((*((real8 *)
1086: (*s_objet_argument_1).objet))));
1087: break;
1088: }
1089:
1090: case 'k' :
1091: {
1092: if (((*((integer8 *) (*s_objet_argument_1).objet))
1093: <= 0) || ((*((integer8 *)
1094: (*s_objet_argument_2).objet)) < 0))
1095: {
1096: (*s_etat_processus).exception =
1097: d_ep_resultat_indefini;
1098:
1099: liberation(s_etat_processus,
1100: s_objet_argument_1);
1101: liberation(s_etat_processus,
1102: s_objet_argument_2);
1103: liberation(s_etat_processus,
1104: s_objet_argument_3);
1105: liberation(s_etat_processus,
1106: s_objet_resultat);
1107:
1108: return;
1109: }
1110:
1111: (*((real8 *) (*s_objet_resultat).objet)) =
1112: exp(fabs((double) (*((real8 *)
1113: (*s_objet_argument_1).objet)))) *
1114: gsl_sf_bessel_kl_scaled(
1115: (int) ((*((integer8 *)
1116: (*s_objet_argument_2).objet))),
1117: (double) ((*((real8 *)
1118: (*s_objet_argument_1).objet))));
1119: break;
1120: }
1121: }
1122: }
1123: else if (((*s_objet_argument_1).type == NOM) ||
1124: ((*s_objet_argument_1).type == RPN) ||
1125: ((*s_objet_argument_1).type == ALG))
1126: {
1127: creation_expression = d_vrai;
1128: }
1129: else
1130: {
1131: liberation(s_etat_processus, s_objet_argument_1);
1132: liberation(s_etat_processus, s_objet_argument_2);
1133: liberation(s_etat_processus, s_objet_argument_3);
1134:
1135: (*s_etat_processus).erreur_execution =
1136: d_ex_erreur_type_argument;
1137: return;
1138: }
1139: }
1140: else if ((*s_objet_argument_2).type == REL)
1141: {
1142: if ((*s_objet_argument_1).type == INT)
1143: {
1144: if ((s_objet_resultat = allocation(s_etat_processus, REL))
1145: == NULL)
1146: {
1147: (*s_etat_processus).erreur_systeme =
1148: d_es_allocation_memoire;
1149: return;
1150: }
1151:
1152: switch((*((unsigned char *) (*s_objet_argument_3).objet)))
1153: {
1154: case 'J' :
1155: {
1156: if (((*((integer8 *) (*s_objet_argument_1).objet))
1157: < 0) || ((*((real8 *)
1158: (*s_objet_argument_2).objet)) < 0))
1159: {
1160: (*s_etat_processus).exception =
1161: d_ep_resultat_indefini;
1162:
1163: liberation(s_etat_processus,
1164: s_objet_argument_1);
1165: liberation(s_etat_processus,
1166: s_objet_argument_2);
1167: liberation(s_etat_processus,
1168: s_objet_argument_3);
1169: liberation(s_etat_processus,
1170: s_objet_resultat);
1171:
1172: return;
1173: }
1174:
1175: (*((real8 *) (*s_objet_resultat).objet)) =
1176: gsl_sf_bessel_Jnu((double) ((*((real8 *)
1177: (*s_objet_argument_2).objet))),
1178: (double) ((*((integer8 *)
1179: (*s_objet_argument_1).objet))));
1180:
1181: break;
1182: }
1183:
1184: case 'Y' :
1185: {
1186: if (((*((integer8 *) (*s_objet_argument_1).objet))
1187: <= 0) || ((*((real8 *)
1188: (*s_objet_argument_2).objet)) < 0))
1189: {
1190: (*s_etat_processus).exception =
1191: d_ep_resultat_indefini;
1192:
1193: liberation(s_etat_processus,
1194: s_objet_argument_1);
1195: liberation(s_etat_processus,
1196: s_objet_argument_2);
1197: liberation(s_etat_processus,
1198: s_objet_argument_3);
1199: liberation(s_etat_processus,
1200: s_objet_resultat);
1201:
1202: return;
1203: }
1204:
1205: (*((real8 *) (*s_objet_resultat).objet)) =
1206: gsl_sf_bessel_Ynu((double) ((*((real8 *)
1207: (*s_objet_argument_2).objet))),
1208: (double) ((*((integer8 *)
1209: (*s_objet_argument_1).objet))));
1210: break;
1211: }
1212:
1213: case 'I' :
1214: {
1215: if (((*((integer8 *) (*s_objet_argument_1).objet))
1216: < 0) || ((*((real8 *)
1217: (*s_objet_argument_2).objet)) < 0))
1218: {
1219: (*s_etat_processus).exception =
1220: d_ep_resultat_indefini;
1221:
1222: liberation(s_etat_processus,
1223: s_objet_argument_1);
1224: liberation(s_etat_processus,
1225: s_objet_argument_2);
1226: liberation(s_etat_processus,
1227: s_objet_argument_3);
1228: liberation(s_etat_processus,
1229: s_objet_resultat);
1230:
1231: return;
1232: }
1233:
1234: (*((real8 *) (*s_objet_resultat).objet)) =
1235: gsl_sf_bessel_Inu((double) ((*((real8 *)
1236: (*s_objet_argument_2).objet))),
1237: (double) ((*((integer8 *)
1238: (*s_objet_argument_1).objet))));
1239: break;
1240: }
1241:
1242: case 'K' :
1243: {
1244: if (((*((integer8 *) (*s_objet_argument_1).objet))
1245: <= 0) || ((*((real8 *)
1246: (*s_objet_argument_2).objet)) < 0))
1247: {
1248: (*s_etat_processus).exception =
1249: d_ep_resultat_indefini;
1250:
1251: liberation(s_etat_processus,
1252: s_objet_argument_1);
1253: liberation(s_etat_processus,
1254: s_objet_argument_2);
1255: liberation(s_etat_processus,
1256: s_objet_argument_3);
1257: liberation(s_etat_processus,
1258: s_objet_resultat);
1259:
1260: return;
1261: }
1262:
1263: (*((real8 *) (*s_objet_resultat).objet)) =
1264: gsl_sf_bessel_Knu((double) ((*((real8 *)
1265: (*s_objet_argument_2).objet))),
1266: (double) ((*((integer8 *)
1267: (*s_objet_argument_1).objet))));
1268: break;
1269: }
1270:
1271: default :
1272: {
1273: (*s_etat_processus).exception =
1274: d_ep_resultat_indefini;
1275:
1276: liberation(s_etat_processus, s_objet_argument_1);
1277: liberation(s_etat_processus, s_objet_argument_2);
1278: liberation(s_etat_processus, s_objet_argument_3);
1279: liberation(s_etat_processus, s_objet_resultat);
1280:
1281: return;
1282: break;
1283: }
1284: }
1285: }
1286: else if ((*s_objet_argument_1).type == REL)
1287: {
1288: if ((s_objet_resultat = allocation(s_etat_processus, REL))
1289: == NULL)
1290: {
1291: (*s_etat_processus).erreur_systeme =
1292: d_es_allocation_memoire;
1293: return;
1294: }
1295:
1296: switch((*((unsigned char *) (*s_objet_argument_3).objet)))
1297: {
1298: case 'J' :
1299: {
1300: if (((*((real8 *) (*s_objet_argument_1).objet))
1301: < 0) || ((*((real8 *)
1302: (*s_objet_argument_2).objet)) < 0))
1303: {
1304: (*s_etat_processus).exception =
1305: d_ep_resultat_indefini;
1306:
1307: liberation(s_etat_processus,
1308: s_objet_argument_1);
1309: liberation(s_etat_processus,
1310: s_objet_argument_2);
1311: liberation(s_etat_processus,
1312: s_objet_argument_3);
1313: liberation(s_etat_processus,
1314: s_objet_resultat);
1315:
1316: return;
1317: }
1318:
1319: (*((real8 *) (*s_objet_resultat).objet)) =
1320: gsl_sf_bessel_Jnu((double) ((*((real8 *)
1321: (*s_objet_argument_2).objet))),
1322: (double) ((*((real8 *)
1323: (*s_objet_argument_1).objet))));
1324: break;
1325: }
1326:
1327: case 'Y' :
1328: {
1329: if (((*((real8 *) (*s_objet_argument_1).objet))
1330: <= 0) || ((*((real8 *)
1331: (*s_objet_argument_2).objet)) < 0))
1332: {
1333: (*s_etat_processus).exception =
1334: d_ep_resultat_indefini;
1335:
1336: liberation(s_etat_processus,
1337: s_objet_argument_1);
1338: liberation(s_etat_processus,
1339: s_objet_argument_2);
1340: liberation(s_etat_processus,
1341: s_objet_argument_3);
1342: liberation(s_etat_processus,
1343: s_objet_resultat);
1344:
1345: return;
1346: }
1347:
1348: (*((real8 *) (*s_objet_resultat).objet)) =
1349: gsl_sf_bessel_Yn((double) ((*((real8 *)
1350: (*s_objet_argument_2).objet))),
1351: (double) ((*((real8 *)
1352: (*s_objet_argument_1).objet))));
1353: break;
1354: }
1355:
1356: case 'I' :
1357: {
1358: if (((*((real8 *) (*s_objet_argument_1).objet))
1359: < 0) || ((*((real8 *)
1360: (*s_objet_argument_2).objet)) < 0))
1361: {
1362: (*s_etat_processus).exception =
1363: d_ep_resultat_indefini;
1364:
1365: liberation(s_etat_processus,
1366: s_objet_argument_1);
1367: liberation(s_etat_processus,
1368: s_objet_argument_2);
1369: liberation(s_etat_processus,
1370: s_objet_argument_3);
1371: liberation(s_etat_processus,
1372: s_objet_resultat);
1373:
1374: return;
1375: }
1376:
1377: (*((real8 *) (*s_objet_resultat).objet)) =
1378: gsl_sf_bessel_In((double) ((*((real8 *)
1379: (*s_objet_argument_2).objet))),
1380: (double) ((*((real8 *)
1381: (*s_objet_argument_1).objet))));
1382: break;
1383: }
1384:
1385: case 'K' :
1386: {
1387: if (((*((real8 *) (*s_objet_argument_1).objet))
1388: <= 0) || ((*((real8 *)
1389: (*s_objet_argument_2).objet)) < 0))
1390: {
1391: (*s_etat_processus).exception =
1392: d_ep_resultat_indefini;
1393:
1394: liberation(s_etat_processus,
1395: s_objet_argument_1);
1396: liberation(s_etat_processus,
1397: s_objet_argument_2);
1398: liberation(s_etat_processus,
1399: s_objet_argument_3);
1400: liberation(s_etat_processus,
1401: s_objet_resultat);
1402:
1403: return;
1404: }
1405:
1406: (*((real8 *) (*s_objet_resultat).objet)) =
1407: gsl_sf_bessel_Kn((double) ((*((real8 *)
1408: (*s_objet_argument_2).objet))),
1409: (double) ((*((real8 *)
1410: (*s_objet_argument_1).objet))));
1411: break;
1412: }
1413:
1414: default :
1415: {
1416: (*s_etat_processus).exception =
1417: d_ep_resultat_indefini;
1418:
1419: liberation(s_etat_processus, s_objet_argument_1);
1420: liberation(s_etat_processus, s_objet_argument_2);
1421: liberation(s_etat_processus, s_objet_argument_3);
1422: liberation(s_etat_processus, s_objet_resultat);
1423:
1424: return;
1425: break;
1426: }
1427: }
1428: }
1429: else
1430: {
1431: liberation(s_etat_processus, s_objet_argument_1);
1432: liberation(s_etat_processus, s_objet_argument_2);
1433: liberation(s_etat_processus, s_objet_argument_3);
1434:
1435: (*s_etat_processus).erreur_execution =
1436: d_ex_erreur_type_argument;
1437: return;
1438: }
1439: }
1440: else if (((*s_objet_argument_2).type == NOM) ||
1441: ((*s_objet_argument_2).type == RPN) ||
1442: ((*s_objet_argument_2).type == ALG))
1443: {
1444: creation_expression = d_vrai;
1445: }
1446: else
1447: {
1448: liberation(s_etat_processus, s_objet_argument_1);
1449: liberation(s_etat_processus, s_objet_argument_2);
1450: liberation(s_etat_processus, s_objet_argument_3);
1451:
1452: (*s_etat_processus).erreur_execution =
1453: d_ex_erreur_type_argument;
1454: return;
1455: }
1456: }
1457: else
1458: {
1459: liberation(s_etat_processus, s_objet_argument_1);
1460: liberation(s_etat_processus, s_objet_argument_2);
1461: liberation(s_etat_processus, s_objet_argument_3);
1462:
1463: (*s_etat_processus).erreur_execution = d_ex_argument_invalide;
1464: return;
1465: }
1466: }
1467: else if (((*s_objet_argument_3).type == NOM) ||
1468: ((*s_objet_argument_3).type == RPN) ||
1469: ((*s_objet_argument_3).type == ALG))
1470: {
1471: creation_expression = d_vrai;
1472: }
1473: else
1474: {
1475: liberation(s_etat_processus, s_objet_argument_1);
1476: liberation(s_etat_processus, s_objet_argument_2);
1477: liberation(s_etat_processus, s_objet_argument_3);
1478:
1479: (*s_etat_processus).erreur_execution = d_ex_erreur_type_argument;
1480: return;
1481: }
1482:
1483: if (creation_expression == d_vrai)
1484: {
1485: if ((s_copie_argument_1 = copie_objet(s_etat_processus,
1486: s_objet_argument_1, 'N')) == NULL)
1487: {
1488: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
1489: return;
1490: }
1491:
1492: if ((s_copie_argument_2 = copie_objet(s_etat_processus,
1493: s_objet_argument_2, 'N')) == NULL)
1494: {
1495: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
1496: return;
1497: }
1498:
1499: if ((s_copie_argument_3 = copie_objet(s_etat_processus,
1500: s_objet_argument_3, 'N')) == NULL)
1501: {
1502: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
1503: return;
1504: }
1505:
1506: if (((*s_copie_argument_1).type == RPN) ||
1507: ((*s_copie_argument_2).type == RPN) ||
1508: ((*s_copie_argument_3).type == RPN))
1509: {
1510: if ((s_objet_resultat = allocation(s_etat_processus, RPN))
1511: == NULL)
1512: {
1513: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
1514: return;
1515: }
1516: }
1517: else
1518: {
1519: if ((s_objet_resultat = allocation(s_etat_processus, ALG))
1520: == NULL)
1521: {
1522: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
1523: return;
1524: }
1525: }
1526:
1527: if (((*s_objet_resultat).objet =
1528: allocation_maillon(s_etat_processus)) == NULL)
1529: {
1530: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
1531: return;
1532: }
1533:
1534: l_element_courant = (*s_objet_resultat).objet;
1535:
1536: if (((*l_element_courant).donnee = allocation(s_etat_processus, FCT))
1537: == NULL)
1538: {
1539: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
1540: return;
1541: }
1542:
1543: (*((struct_fonction *) (*(*l_element_courant).donnee).objet))
1544: .nombre_arguments = 0;
1545: (*((struct_fonction *) (*(*l_element_courant).donnee).objet))
1546: .fonction = instruction_vers_niveau_superieur;
1547:
1548: if (((*((struct_fonction *) (*(*l_element_courant).donnee).objet))
1549: .nom_fonction = malloc(3 * sizeof(unsigned char))) == NULL)
1550: {
1551: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
1552: return;
1553: }
1554:
1555: strcpy((*((struct_fonction *) (*(*l_element_courant).donnee).objet))
1556: .nom_fonction, "<<");
1557:
1558: if (((*s_copie_argument_3).type == ALG) ||
1559: ((*s_copie_argument_3).type == RPN))
1560: {
1561:
1562: l_element_atome = (struct_liste_chainee *)
1563: (*s_copie_argument_3).objet;
1564:
1565: i = 0;
1566:
1567: while(l_element_atome != NULL)
1568: {
1569: i++;
1570: l_element_atome = (*l_element_atome).suivant;
1571: }
1572:
1573: if (i < 3)
1574: {
1575: if (((*l_element_courant).suivant =
1576: allocation_maillon(s_etat_processus)) == NULL)
1577: {
1578: (*s_etat_processus).erreur_systeme =
1579: d_es_allocation_memoire;
1580: return;
1581: }
1582:
1583: l_element_courant = (*l_element_courant).suivant;
1584: (*l_element_courant).donnee = s_copie_argument_3;
1585: }
1586: else
1587: {
1588: (*l_element_courant).suivant = (*((struct_liste_chainee *)
1589: (*s_copie_argument_3).objet)).suivant;
1590:
1591: l_element_precedent = NULL;
1592: l_element_courant = (*l_element_courant).suivant;
1593:
1594: liberation(s_etat_processus,
1595: (*((struct_liste_chainee *) (*s_copie_argument_3)
1596: .objet)).donnee);
1597: free((*s_copie_argument_3).objet);
1598: free(s_copie_argument_3);
1599:
1600: while((*l_element_courant).suivant != NULL)
1601: {
1602: l_element_precedent = l_element_courant;
1603: l_element_courant = (*l_element_courant).suivant;
1604: }
1605:
1606: liberation(s_etat_processus, (*l_element_courant).donnee);
1607: free(l_element_courant);
1608:
1609: l_element_courant = l_element_precedent;
1610: }
1611: }
1612: else
1613: {
1614: if (((*l_element_courant).suivant =
1615: allocation_maillon(s_etat_processus)) == NULL)
1616: {
1617: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
1618: return;
1619: }
1620:
1621: l_element_courant = (*l_element_courant).suivant;
1622: (*l_element_courant).donnee = s_copie_argument_3;
1623: }
1624:
1625: if (((*s_copie_argument_2).type == ALG) ||
1626: ((*s_copie_argument_2).type == RPN))
1627: {
1628: l_element_atome = (struct_liste_chainee *)
1629: (*s_copie_argument_2).objet;
1630:
1631: i = 0;
1632:
1633: while(l_element_atome != NULL)
1634: {
1635: i++;
1636: l_element_atome = (*l_element_atome).suivant;
1637: }
1638:
1639: if (i < 3)
1640: {
1641: if (((*l_element_courant).suivant =
1642: allocation_maillon(s_etat_processus)) == NULL)
1643: {
1644: (*s_etat_processus).erreur_systeme =
1645: d_es_allocation_memoire;
1646: return;
1647: }
1648:
1649: l_element_courant = (*l_element_courant).suivant;
1650: (*l_element_courant).donnee = s_copie_argument_2;
1651: }
1652: else
1653: {
1654: (*l_element_courant).suivant = (*((struct_liste_chainee *)
1655: (*s_copie_argument_2).objet)).suivant;
1656:
1657: l_element_courant = (*l_element_courant).suivant;
1658: l_element_precedent = NULL;
1659:
1660: liberation(s_etat_processus,
1661: (*((struct_liste_chainee *) (*s_copie_argument_2)
1662: .objet)).donnee);
1663: free((*s_copie_argument_2).objet);
1664: free(s_copie_argument_2);
1665:
1666: while((*l_element_courant).suivant != NULL)
1667: {
1668: l_element_precedent = l_element_courant;
1669: l_element_courant = (*l_element_courant).suivant;
1670: }
1671:
1672: liberation(s_etat_processus, (*l_element_courant).donnee);
1673: free(l_element_courant);
1674:
1675: l_element_courant = l_element_precedent;
1676: }
1677: }
1678: else
1679: {
1680: if (((*l_element_courant).suivant =
1681: allocation_maillon(s_etat_processus)) == NULL)
1682: {
1683: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
1684: return;
1685: }
1686:
1687: l_element_courant = (*l_element_courant).suivant;
1688: (*l_element_courant).donnee = s_copie_argument_2;
1689: }
1690:
1691: if (((*s_copie_argument_1).type == ALG) ||
1692: ((*s_copie_argument_1).type == RPN))
1693: {
1694: l_element_atome = (struct_liste_chainee *)
1695: (*s_copie_argument_1).objet;
1696:
1697: i = 0;
1698:
1699: while(l_element_atome != NULL)
1700: {
1701: i++;
1702: l_element_atome = (*l_element_atome).suivant;
1703: }
1704:
1705: if (i < 3)
1706: {
1707: if (((*l_element_courant).suivant =
1708: allocation_maillon(s_etat_processus)) == NULL)
1709: {
1710: (*s_etat_processus).erreur_systeme =
1711: d_es_allocation_memoire;
1712: return;
1713: }
1714:
1715: l_element_courant = (*l_element_courant).suivant;
1716: (*l_element_courant).donnee = s_copie_argument_1;
1717: }
1718: else
1719: {
1720: (*l_element_courant).suivant = (*((struct_liste_chainee *)
1721: (*s_copie_argument_1).objet)).suivant;
1722:
1723: l_element_courant = (*l_element_courant).suivant;
1724: l_element_precedent = NULL;
1725:
1726: liberation(s_etat_processus,
1727: (*((struct_liste_chainee *) (*s_copie_argument_1)
1728: .objet)).donnee);
1729: free((*s_copie_argument_1).objet);
1730: free(s_copie_argument_1);
1731:
1732: while((*l_element_courant).suivant != NULL)
1733: {
1734: l_element_precedent = l_element_courant;
1735: l_element_courant = (*l_element_courant).suivant;
1736: }
1737:
1738: liberation(s_etat_processus, (*l_element_courant).donnee);
1739: free(l_element_courant);
1740:
1741: l_element_courant = l_element_precedent;
1742: }
1743: }
1744: else
1745: {
1746: if (((*l_element_courant).suivant =
1747: allocation_maillon(s_etat_processus)) == NULL)
1748: {
1749: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
1750: return;
1751: }
1752:
1753: l_element_courant = (*l_element_courant).suivant;
1754: (*l_element_courant).donnee = s_copie_argument_1;
1755: }
1756:
1757: if (((*l_element_courant).suivant =
1758: allocation_maillon(s_etat_processus)) == NULL)
1759: {
1760: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
1761: return;
1762: }
1763:
1764: l_element_courant = (*l_element_courant).suivant;
1765:
1766: if (((*l_element_courant).donnee =
1767: allocation(s_etat_processus, FCT)) == NULL)
1768: {
1769: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
1770: return;
1771: }
1772:
1773: (*((struct_fonction *) (*(*l_element_courant).donnee).objet))
1774: .nombre_arguments = 3;
1775: (*((struct_fonction *) (*(*l_element_courant).donnee).objet))
1776: .fonction = instruction_bessel;
1777:
1778: if (((*((struct_fonction *) (*(*l_element_courant).donnee).objet))
1779: .nom_fonction = malloc(7 * sizeof(unsigned char))) == NULL)
1780: {
1781: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
1782: return;
1783: }
1784:
1785: strcpy((*((struct_fonction *) (*(*l_element_courant).donnee).objet))
1786: .nom_fonction, "BESSEL");
1787:
1788: if (((*l_element_courant).suivant =
1789: allocation_maillon(s_etat_processus)) == NULL)
1790: {
1791: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
1792: return;
1793: }
1794:
1795: l_element_courant = (*l_element_courant).suivant;
1796:
1797: if (((*l_element_courant).donnee = (struct_objet *)
1798: allocation(s_etat_processus, FCT)) == NULL)
1799: {
1800: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
1801: return;
1802: }
1803:
1804: (*((struct_fonction *) (*(*l_element_courant).donnee).objet))
1805: .nombre_arguments = 0;
1806: (*((struct_fonction *) (*(*l_element_courant).donnee).objet))
1807: .fonction = instruction_vers_niveau_inferieur;
1808:
1809: if (((*((struct_fonction *) (*(*l_element_courant).donnee).objet))
1810: .nom_fonction = malloc(3 * sizeof(unsigned char))) == NULL)
1811: {
1812: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
1813: return;
1814: }
1815:
1816: strcpy((*((struct_fonction *) (*(*l_element_courant).donnee).objet))
1817: .nom_fonction, ">>");
1818:
1819: (*l_element_courant).suivant = NULL;
1820: }
1821:
1822: if (empilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
1823: s_objet_resultat) == d_erreur)
1824: {
1825: return;
1826: }
1827:
1828: liberation(s_etat_processus, s_objet_argument_1);
1829: liberation(s_etat_processus, s_objet_argument_2);
1830: liberation(s_etat_processus, s_objet_argument_3);
1831:
1832: return;
1833: }
1834:
1835:
1836: /*
1837: ================================================================================
1838: Fonction 'backtrace'
1839: ================================================================================
1840: Entrées :
1841: --------------------------------------------------------------------------------
1842: Sorties :
1843: --------------------------------------------------------------------------------
1844: Effets de bord : néant
1845: ================================================================================
1846: */
1847:
1848: void
1849: instruction_backtrace(struct_processus *s_etat_processus)
1850: {
1851: (*s_etat_processus).erreur_execution = d_ex;
1852:
1853: if ((*s_etat_processus).affichage_arguments == 'Y')
1854: {
1855: printf("\n BACKTRACE ");
1856:
1857: if ((*s_etat_processus).langue == 'F')
1858: {
1859: printf("(affichage de la pile système)\n\n");
1860: printf(" Aucun argument\n");
1861: }
1862: else
1863: {
1864: printf("(print system stack)\n\n");
1865: printf(" No argument\n");
1866: }
1867:
1868: return;
1869: }
1870: else if ((*s_etat_processus).test_instruction == 'Y')
1871: {
1872: (*s_etat_processus).nombre_arguments = -1;
1873: return;
1874: }
1875:
1876: if (test_cfsf(s_etat_processus, 31) == d_vrai)
1877: {
1878: if (empilement_pile_last(s_etat_processus, 0) == d_erreur)
1879: {
1880: return;
1881: }
1882: }
1883:
1884: trace(s_etat_processus, stdout);
1885:
1886: return;
1887: }
1888:
1889: // vim: ts=4
CVSweb interface <joel.bertrand@systella.fr>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to instructions_b1.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [local] / rpl / src