![[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|
Return to instructions_b1.c CVS log | Up to [local] / rpl / src |
1.1 bertrand 1: /*
2: ================================================================================
1.72 ! bertrand 3: RPL/2 (R) version 4.1.34
1.71 bertrand 4: Copyright (C) 1989-2021 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.13 bertrand 23: #include "rpl-conv.h"
1.1 bertrand 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:
1.45 bertrand 206: (*((integer8 *) (*s_objet_resultat).objet)) = (integer8) (*((logical8 *)
1.1 bertrand 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: {
1.5 bertrand 244: struct_descripteur_fichier *descripteur;
1.1 bertrand 245:
1.45 bertrand 246: integer8 i;
247: integer8 nombre_octets;
1.1 bertrand 248: integer8 position_finale;
249: integer8 position_initiale;
1.43 bertrand 250: integer8 saut;
1.45 bertrand 251: integer8 pointeur;
252: integer8 niveau;
253: integer8 longueur_effective;
254: integer8 longueur_questure;
255:
1.1 bertrand 256:
1.43 bertrand 257: logical1 guillemets_a_cheval;
1.1 bertrand 258: logical1 presence_chaine;
259: logical1 presence_indicateur;
260:
261: struct flock lock;
262:
263: struct_objet *s_objet_argument;
264:
265: unsigned char *tampon_lecture;
1.43 bertrand 266: unsigned char tampon[9];
1.1 bertrand 267:
268: (*s_etat_processus).erreur_execution = d_ex;
269:
270: if ((*s_etat_processus).affichage_arguments == 'Y')
271: {
272: printf("\n BACKSPACE ");
273:
274: if ((*s_etat_processus).langue == 'F')
275: {
276: printf("(retour à l'enregistrement précédent)\n\n");
277: }
278: else
279: {
280: printf("(return to the previous record)\n\n");
281: }
282:
283: printf(" 1: %s\n", d_FCH);
284:
285: return;
286: }
287: else if ((*s_etat_processus).test_instruction == 'Y')
288: {
289: (*s_etat_processus).nombre_arguments = -1;
290: return;
291: }
292:
293: if (test_cfsf(s_etat_processus, 31) == d_vrai)
294: {
295: if (empilement_pile_last(s_etat_processus, 1) == d_erreur)
296: {
297: return;
298: }
299: }
300:
301: if (depilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
302: &s_objet_argument) == d_erreur)
303: {
304: (*s_etat_processus).erreur_execution = d_ex_manque_argument;
305: return;
306: }
307:
308: if ((*s_objet_argument).type == FCH)
309: {
310: /*
1.5 bertrand 311: * Fichiers à accès séquentiel
1.1 bertrand 312: */
313:
1.5 bertrand 314: if ((*((struct_fichier *) (*s_objet_argument).objet)).acces == 'S')
315: {
316: /*
317: * Vérification des verrous
318: */
1.1 bertrand 319:
1.5 bertrand 320: lock.l_type = F_RDLCK;
321: lock.l_whence = SEEK_SET;
322: lock.l_start = 0;
323: lock.l_len = 0;
324: lock.l_pid = getpid();
1.1 bertrand 325:
1.5 bertrand 326: if ((descripteur = descripteur_fichier(s_etat_processus,
327: (struct_fichier *) (*s_objet_argument).objet)) == NULL)
328: {
329: liberation(s_etat_processus, s_objet_argument);
330: return;
331: }
1.1 bertrand 332:
1.5 bertrand 333: if (fcntl(fileno((*descripteur).descripteur_c), F_GETLK, &lock)
334: == -1)
335: {
336: liberation(s_etat_processus, s_objet_argument);
1.1 bertrand 337:
1.5 bertrand 338: (*s_etat_processus).erreur_systeme = d_es_erreur_fichier;
339: return;
340: }
1.1 bertrand 341:
1.5 bertrand 342: if (lock.l_type != F_UNLCK)
343: {
344: liberation(s_etat_processus, s_objet_argument);
1.1 bertrand 345:
1.5 bertrand 346: (*s_etat_processus).erreur_execution =
347: d_ex_fichier_verrouille;
348: return;
349: }
1.1 bertrand 350:
351: if ((*((struct_fichier *) (*s_objet_argument).objet)).binaire
352: == 'N')
353: {
354: /*
355: * Fichiers formatés
356: */
357:
1.5 bertrand 358: if ((position_finale = ftell((*descripteur).descripteur_c))
359: == -1)
1.1 bertrand 360: {
361: liberation(s_etat_processus, s_objet_argument);
362:
363: (*s_etat_processus).erreur_systeme = d_es_erreur_fichier;
364: return;
365: }
366:
367: longueur_questure = 256;
368:
1.45 bertrand 369: if ((tampon_lecture = malloc(((size_t) longueur_questure) *
1.1 bertrand 370: sizeof(unsigned char))) == NULL)
371: {
372: (*s_etat_processus).erreur_systeme =
373: d_es_allocation_memoire;
374: return;
375: }
376:
377: do
378: {
379: if ((position_initiale = (position_finale -
380: longueur_questure)) < 0)
381: {
382: position_initiale = 0;
383: longueur_effective = position_finale + 1;
384: }
385: else
386: {
387: longueur_effective = longueur_questure;
388: }
389:
1.46 bertrand 390: if (fseek((*descripteur).descripteur_c,
391: (long) position_initiale, SEEK_SET) != 0)
1.1 bertrand 392: {
393: (*s_etat_processus).erreur_systeme =
394: d_es_erreur_fichier;
395: return;
396: }
397:
1.45 bertrand 398: longueur_effective = (integer8) fread(tampon_lecture,
399: sizeof(unsigned char), (size_t) longueur_effective,
1.5 bertrand 400: (*descripteur).descripteur_c);
1.1 bertrand 401:
402: pointeur = longueur_effective - 1;
403: presence_indicateur = d_faux;
404:
405: while((pointeur >= 0) && (presence_indicateur == d_faux))
406: {
407: if (tampon_lecture[pointeur] == '}')
408: {
409: presence_indicateur = d_vrai;
410: }
411: else
412: {
413: position_finale--;
414: pointeur--;
415: }
416: }
417: } while((longueur_effective == longueur_questure) &&
418: (presence_indicateur == d_faux));
419:
420: if (presence_indicateur == d_faux)
421: {
422: /*
423: * Le début du fichier est atteint.
424: */
425:
1.5 bertrand 426: if (fseek((*descripteur).descripteur_c, 0, SEEK_SET) != 0)
1.1 bertrand 427: {
428: liberation(s_etat_processus, s_objet_argument);
429: free(tampon_lecture);
430:
431: (*s_etat_processus).erreur_systeme =
432: d_es_erreur_fichier;
433: return;
434: }
435:
436: (*s_etat_processus).erreur_execution =
437: d_ex_debut_de_fichier_atteint;
438:
439: liberation(s_etat_processus, s_objet_argument);
440: free(tampon_lecture);
441:
442: return;
443: }
444:
445: position_finale = position_finale - 1;
446: presence_chaine = d_faux;
447: niveau = 1;
448:
449: if (position_finale < 0)
450: {
451: liberation(s_etat_processus, s_objet_argument);
452: free(tampon_lecture);
453:
454: (*s_etat_processus).erreur_execution =
455: d_ex_debut_de_fichier_atteint;
456: return;
457: }
458:
459: do
460: {
461: if ((position_initiale = (position_finale -
462: longueur_questure)) < 0)
463: {
464: position_initiale = 0;
465: longueur_effective = position_finale + 1;
466: }
467: else
468: {
469: longueur_effective = longueur_questure;
470: position_finale--;
471: }
472:
1.46 bertrand 473: if (fseek((*descripteur).descripteur_c,
474: (long) position_initiale, SEEK_SET) != 0)
1.1 bertrand 475: {
476: (*s_etat_processus).erreur_systeme =
477: d_es_erreur_fichier;
478: return;
479: }
480:
1.45 bertrand 481: longueur_effective = (integer8) fread(tampon_lecture,
482: sizeof(unsigned char), (size_t) longueur_effective,
1.5 bertrand 483: (*descripteur).descripteur_c);
1.1 bertrand 484:
485: pointeur = longueur_effective - 1;
486: presence_indicateur = d_faux;
1.43 bertrand 487: guillemets_a_cheval = d_faux;
1.1 bertrand 488:
1.43 bertrand 489: while((pointeur >= 0) && (presence_indicateur == d_faux)
490: && (guillemets_a_cheval == d_faux))
1.1 bertrand 491: {
492: if (tampon_lecture[pointeur] == '"')
493: {
1.43 bertrand 494: if (pointeur > 0)
495: {
496: // On n'est pas au début du buffer, on regarde
497: // si les guillemets sont échappés.
498:
499: if (tampon_lecture[pointeur - 1] != '\\')
500: {
501: presence_chaine = (presence_chaine
502: == d_vrai) ? d_faux : d_vrai;
503: }
504: }
505: else
506: {
507: // On est au début du buffer. Un guillemet
508: // peut-être échappé par le dernier caractère
509: // du buffer précédent.
510:
511: guillemets_a_cheval = d_vrai;
512: }
1.1 bertrand 513: }
514: else
515: {
516: if (tampon_lecture[pointeur] == '}')
517: {
518: niveau++;
519: }
520: else if (tampon_lecture[pointeur] == '{')
521: {
522: niveau--;
523: }
524: }
525:
1.43 bertrand 526: if (guillemets_a_cheval == d_faux)
1.1 bertrand 527: {
1.43 bertrand 528: if (niveau == 0)
529: {
530: presence_indicateur = d_vrai;
531: }
532: else
533: {
534: position_finale--;
535: pointeur--;
536: }
1.1 bertrand 537: }
538: }
539: } while((longueur_effective == longueur_questure) &&
540: (presence_indicateur == d_faux));
541:
542: if (presence_indicateur == d_faux)
543: {
544: liberation(s_etat_processus, s_objet_argument);
545: free(tampon_lecture);
546:
547: (*s_etat_processus).erreur_execution =
548: d_ex_fin_de_fichier_atteinte;
549: return;
550: }
551:
1.46 bertrand 552: if (fseek((*descripteur).descripteur_c, (long) position_finale,
1.5 bertrand 553: SEEK_SET) != 0)
1.1 bertrand 554: {
555: liberation(s_etat_processus, s_objet_argument);
556: free(tampon_lecture);
557:
558: (*s_etat_processus).erreur_systeme = d_es_erreur_fichier;
559: return;
560: }
561:
562: free(tampon_lecture);
563: }
564: else
565: {
566: /*
567: * Fichiers non formatés
568: */
1.43 bertrand 569:
570: /*
571: Chaque enregistrement est terminé par un champ
572: * indiquant la longueur totale de cet enregistrement.
573: *
574: * XXXXXXX0 longueur sur 7 bits
575: * XXXX0011 XXXXXXXX XXXX0011 longueur sur 16 bits
576: * LSB(1/2) MSB LSB(2/2)
577: * XXXX0101 XXXXXXXX XXXXXXXX XXXX0101 longueur sur 24 bits
578: * XXXX0111 XXXXXXXX XXXXXXXX XXXXXXXX
579: * XXXX0111 longueur sur 32 bits
580: * XXXX1001 XXXXXXXX XXXXXXXX XXXXXXXX
581: * XXXXXXXX XXXX1001 longueur sur 40 bits
582: * XXXX1011 XXXXXXXX XXXXXXXX XXXXXXXX
583: * XXXXXXXX XXXXXXXX XXXX1011 longueur sur 48 bits
584: * XXXX1101 XXXXXXXX XXXXXXXX XXXXXXXX
585: * XXXXXXXX XXXXXXXX XXXXXXXX
586: * XXXX1101 longueur sur 56 bits
587: * XXXX1111 XXXXXXXX XXXXXXXX XXXXXXXX
588: * XXXXXXXX XXXXXXXX XXXXXXXX
589: * XXXXXXXX XXXX1111 longueur sur 64 bits
590: */
591:
592: if ((position_finale = ftell((*descripteur).descripteur_c))
593: == -1)
594: {
595: liberation(s_etat_processus, s_objet_argument);
596:
597: (*s_etat_processus).erreur_systeme = d_es_erreur_fichier;
598: return;
599: }
600:
601: // Lecture du premier octet. Le pointeur de lecture se
602: // trouve après l'opération à sa position initiale.
603:
604: if (position_finale == 0)
605: {
606: liberation(s_etat_processus, s_objet_argument);
607:
608: (*s_etat_processus).erreur_execution =
609: d_ex_debut_de_fichier_atteint;
610: return;
611: }
612:
1.46 bertrand 613: if (fseek((*descripteur).descripteur_c,
614: ((long) position_finale) - 1, SEEK_SET) != 0)
1.43 bertrand 615: {
616: liberation(s_etat_processus, s_objet_argument);
617:
618: (*s_etat_processus).erreur_systeme = d_es_erreur_fichier;
619: return;
620: }
621:
622: if (fread(tampon, (size_t) sizeof(unsigned char), 1,
623: (*descripteur).descripteur_c) != 1)
624: {
625: liberation(s_etat_processus, s_objet_argument);
626:
627: (*s_etat_processus).erreur_systeme = d_es_erreur_fichier;
628: return;
629: }
630:
631: if ((tampon[0] & 0x01) == 0)
632: {
633: // Longueur sur sept bits
634: saut = tampon[0] >> 1;
635: }
636: else
637: {
638: // Longueurs supérieures
639: nombre_octets = 2 + ((tampon[0] >> 1) & 0x07);
640:
641: if ((position_finale - nombre_octets) < 0)
642: {
643: liberation(s_etat_processus, s_objet_argument);
644:
645: (*s_etat_processus).erreur_systeme = d_ex_syntaxe;
646: return;
647: }
648:
1.46 bertrand 649: if (fseek((*descripteur).descripteur_c,
650: ((long) (position_finale - nombre_octets)),
651: SEEK_SET) != 0)
1.43 bertrand 652: {
653: liberation(s_etat_processus, s_objet_argument);
654:
655: (*s_etat_processus).erreur_systeme =
656: d_es_erreur_fichier;
657: return;
658: }
659:
660: if (fread(tampon, (size_t) sizeof(unsigned char),
1.45 bertrand 661: (size_t) nombre_octets,
662: (*descripteur).descripteur_c)
1.43 bertrand 663: != (size_t) nombre_octets)
664: {
665: liberation(s_etat_processus, s_objet_argument);
666:
667: (*s_etat_processus).erreur_systeme =
668: d_es_erreur_fichier;
669: return;
670: }
671:
672: // Récupération du LSB
673:
674: saut = (tampon[0] & 0xF0)
675: | ((tampon[nombre_octets - 1] & 0x0F) >> 4);
676:
677: // Autres octets
678:
679: for(i = 1; i < (nombre_octets - 1); i++)
680: {
1.44 bertrand 681: saut |= ((integer8) tampon[i]) <<
682: (((nombre_octets - 1) - i) * 8);
1.43 bertrand 683: }
684: }
685:
686: if (position_finale - saut >= 0)
687: {
688: if (fseek((*descripteur).descripteur_c,
1.46 bertrand 689: (long) (position_finale - saut), SEEK_SET) != 0)
1.43 bertrand 690: {
691: liberation(s_etat_processus, s_objet_argument);
692:
693: (*s_etat_processus).erreur_systeme =
694: d_es_erreur_fichier;
695: return;
696: }
697: }
698: else
699: {
700: liberation(s_etat_processus, s_objet_argument);
701:
702: (*s_etat_processus).erreur_execution =
703: d_ex_debut_de_fichier_atteint;
704: return;
705: }
1.1 bertrand 706: }
707: }
708: else
709: {
710: liberation(s_etat_processus, s_objet_argument);
711:
712: (*s_etat_processus).erreur_execution = d_ex_erreur_type_fichier;
713: return;
714: }
715: }
716: else
717: {
718: liberation(s_etat_processus, s_objet_argument);
719:
720: (*s_etat_processus).erreur_execution = d_ex_erreur_type_argument;
721: return;
722: }
723:
724: liberation(s_etat_processus, s_objet_argument);
725:
726: return;
727: }
728:
729:
730: /*
731: ================================================================================
732: Fonction 'bessel'
733: ================================================================================
734: Entrées :
735: --------------------------------------------------------------------------------
736: Sorties :
737: --------------------------------------------------------------------------------
738: Effets de bord : néant
739: ================================================================================
740: */
741:
742: void
743: instruction_bessel(struct_processus *s_etat_processus)
744: {
745: logical1 creation_expression;
746:
747: struct_liste_chainee *l_element_atome;
748: struct_liste_chainee *l_element_courant;
749: struct_liste_chainee *l_element_precedent;
750:
751: struct_objet *s_copie_argument_1;
752: struct_objet *s_copie_argument_2;
753: struct_objet *s_copie_argument_3;
754: struct_objet *s_objet_argument_1;
755: struct_objet *s_objet_argument_2;
756: struct_objet *s_objet_argument_3;
757: struct_objet *s_objet_resultat;
758:
759: unsigned long i;
760:
761: (*s_etat_processus).erreur_execution = d_ex;
762:
763: if ((*s_etat_processus).affichage_arguments == 'Y')
764: {
765: printf("\n BESSEL ");
766:
767: if ((*s_etat_processus).langue == 'F')
768: {
769: printf("(fonctions de Bessel)\n\n");
770: }
771: else
772: {
773: printf("(Bessel functions)\n\n");
774: }
775:
776: printf(" 3: \"J\", \"Y\", \"I\", \"K\", \"j\", \"y\", "
777: "\"i\", \"k\"\n");
778: printf(" 2: %s, %s\n", d_INT, d_REL);
779: printf(" 1: %s, %s\n", d_INT, d_REL);
780: printf("-> 1: %s\n\n", d_REL);
781:
782: printf(" 3: \"J\", \"Y\", \"I\", \"K\", \"j\", \"y\", "
783: "\"i\", \"k\"\n");
784: printf(" 2: %s, %s\n", d_INT, d_REL);
785: printf(" 1: %s, %s\n", d_NOM, d_ALG);
786: printf("-> 1: %s\n\n", d_ALG);
787:
788: printf(" 3: \"J\", \"Y\", \"I\", \"K\", \"j\", \"y\", "
789: "\"i\", \"k\"\n");
790: printf(" 2: %s, %s\n", d_INT, d_REL);
791: printf(" 1: %s\n", d_RPN);
792: printf("-> 1: %s\n", d_RPN);
793: return;
794: }
795: else if ((*s_etat_processus).test_instruction == 'Y')
796: {
797: (*s_etat_processus).nombre_arguments = 3;
798: return;
799: }
800:
801: if (test_cfsf(s_etat_processus, 31) == d_vrai)
802: {
803: if (empilement_pile_last(s_etat_processus, 3) == d_erreur)
804: {
805: return;
806: }
807: }
808:
809: /*
810: * Jn fonction cylindrique régulière
811: * Yn fonction cylindrique irrégulière
812: * In fonction cylindrique régulière modifiée
813: * Kn fonction cylindrique irrégulière modifiée
814: * jn fonction sphérique régulière
815: * yn fonction sphérique irrégulière
816: * in fonction sphérique régulière modifiée
817: * kn fonction sphérique irrégulière modifiée
818: *
819: * Attention : Ordre fractionnaire uniquement pour les
820: * fonctions cylindriques
821: */
822:
823: creation_expression = d_faux;
824:
825: if (depilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
826: &s_objet_argument_1) == d_erreur)
827: {
828: (*s_etat_processus).erreur_execution = d_ex_manque_argument;
829: return;
830: }
831:
832: if (depilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
833: &s_objet_argument_2) == d_erreur)
834: {
835: liberation(s_etat_processus, s_objet_argument_1);
836:
837: (*s_etat_processus).erreur_execution = d_ex_manque_argument;
838: return;
839: }
840:
841: if (depilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
842: &s_objet_argument_3) == d_erreur)
843: {
844: liberation(s_etat_processus, s_objet_argument_1);
845: liberation(s_etat_processus, s_objet_argument_2);
846:
847: (*s_etat_processus).erreur_execution = d_ex_manque_argument;
848: return;
849: }
850:
851: if ((*s_objet_argument_3).type == CHN)
852: {
853: if ((strcmp((unsigned char *) (*s_objet_argument_3).objet, "J") == 0) ||
854: (strcmp((unsigned char *) (*s_objet_argument_3).objet, "Y")
855: == 0) || (strcmp((unsigned char *) (*s_objet_argument_3).objet,
856: "I") == 0) || (strcmp((unsigned char *) (*s_objet_argument_3)
857: .objet, "K") == 0) || (strcmp((unsigned char *)
858: (*s_objet_argument_3).objet, "j") == 0) || (strcmp(
859: (unsigned char *) (*s_objet_argument_3).objet, "y") == 0) ||
860: (strcmp((unsigned char *) (*s_objet_argument_3).objet, "i") ==
861: 0) || (strcmp((unsigned char *) (*s_objet_argument_3).objet,
862: "k") == 0))
863: {
864: if ((*s_objet_argument_2).type == INT)
865: {
866: if ((*s_objet_argument_1).type == INT)
867: {
868: if ((s_objet_resultat = allocation(s_etat_processus, REL))
869: == NULL)
870: {
871: (*s_etat_processus).erreur_systeme =
872: d_es_allocation_memoire;
873: return;
874: }
875:
876: switch((*((unsigned char *) (*s_objet_argument_3).objet)))
877: {
878: case 'J' :
879: {
880: (*((real8 *) (*s_objet_resultat).objet)) =
881: gsl_sf_bessel_Jn((int) ((*((integer8 *)
882: (*s_objet_argument_2).objet))),
883: (double) ((*((integer8 *)
884: (*s_objet_argument_1).objet))));
885: break;
886: }
887:
888: case 'Y' :
889: {
890: if ((*((integer8 *) (*s_objet_argument_1).objet))
891: <= 0)
892: {
893: (*s_etat_processus).exception =
894: d_ep_resultat_indefini;
895:
896: liberation(s_etat_processus,
897: s_objet_argument_1);
898: liberation(s_etat_processus,
899: s_objet_argument_2);
900: liberation(s_etat_processus,
901: s_objet_argument_3);
902: liberation(s_etat_processus,
903: s_objet_resultat);
904:
905: return;
906: }
907:
908: (*((real8 *) (*s_objet_resultat).objet)) =
909: gsl_sf_bessel_Yn((int) ((*((integer8 *)
910: (*s_objet_argument_2).objet))),
911: (double) ((*((integer8 *)
912: (*s_objet_argument_1).objet))));
913: break;
914: }
915:
916: case 'I' :
917: {
918: (*((real8 *) (*s_objet_resultat).objet)) =
919: gsl_sf_bessel_In((int) ((*((integer8 *)
920: (*s_objet_argument_2).objet))),
921: (double) ((*((integer8 *)
922: (*s_objet_argument_1).objet))));
923: break;
924: }
925:
926: case 'K' :
927: {
928: if ((*((integer8 *) (*s_objet_argument_1).objet))
929: <= 0)
930: {
931: (*s_etat_processus).exception =
932: d_ep_resultat_indefini;
933:
934: liberation(s_etat_processus,
935: s_objet_argument_1);
936: liberation(s_etat_processus,
937: s_objet_argument_2);
938: liberation(s_etat_processus,
939: s_objet_argument_3);
940: liberation(s_etat_processus,
941: s_objet_resultat);
942:
943: return;
944: }
945:
946: (*((real8 *) (*s_objet_resultat).objet)) =
947: gsl_sf_bessel_Kn((int) ((*((integer8 *)
948: (*s_objet_argument_2).objet))),
949: (double) ((*((integer8 *)
950: (*s_objet_argument_1).objet))));
951: break;
952: }
953:
954: case 'j' :
955: {
956: if (((*((integer8 *) (*s_objet_argument_1).objet))
957: < 0) || ((*((integer8 *)
958: (*s_objet_argument_2).objet)) < 0))
959: {
960: (*s_etat_processus).exception =
961: d_ep_resultat_indefini;
962:
963: liberation(s_etat_processus,
964: s_objet_argument_1);
965: liberation(s_etat_processus,
966: s_objet_argument_2);
967: liberation(s_etat_processus,
968: s_objet_argument_3);
969: liberation(s_etat_processus,
970: s_objet_resultat);
971:
972: return;
973: }
974:
975: (*((real8 *) (*s_objet_resultat).objet)) =
976: gsl_sf_bessel_jl((int) ((*((integer8 *)
977: (*s_objet_argument_2).objet))),
978: (double) ((*((integer8 *)
979: (*s_objet_argument_1).objet))));
980: break;
981: }
982:
983: case 'y' :
984: {
985: if (((*((integer8 *) (*s_objet_argument_1).objet))
986: <= 0) || ((*((integer8 *)
987: (*s_objet_argument_2).objet)) < 0))
988: {
989: (*s_etat_processus).exception =
990: d_ep_resultat_indefini;
991:
992: liberation(s_etat_processus,
993: s_objet_argument_1);
994: liberation(s_etat_processus,
995: s_objet_argument_2);
996: liberation(s_etat_processus,
997: s_objet_argument_3);
998: liberation(s_etat_processus,
999: s_objet_resultat);
1000:
1001: return;
1002: }
1003:
1004: (*((real8 *) (*s_objet_resultat).objet)) =
1005: gsl_sf_bessel_yl((int) ((*((integer8 *)
1006: (*s_objet_argument_2).objet))),
1007: (double) ((*((integer8 *)
1008: (*s_objet_argument_1).objet))));
1009: break;
1010: }
1011:
1012: case 'i' :
1013: {
1014: if ((*((integer8 *) (*s_objet_argument_2).objet))
1015: < 0)
1016: {
1017: (*s_etat_processus).exception =
1018: d_ep_resultat_indefini;
1019:
1020: liberation(s_etat_processus,
1021: s_objet_argument_1);
1022: liberation(s_etat_processus,
1023: s_objet_argument_2);
1024: liberation(s_etat_processus,
1025: s_objet_argument_3);
1026: liberation(s_etat_processus,
1027: s_objet_resultat);
1028:
1029: return;
1030: }
1031:
1032: (*((real8 *) (*s_objet_resultat).objet)) =
1033: exp(fabs((double) (*((integer8 *)
1034: (*s_objet_argument_1).objet)))) *
1035: gsl_sf_bessel_il_scaled(
1036: (int) ((*((integer8 *)
1037: (*s_objet_argument_2).objet))),
1038: (double) ((*((integer8 *)
1039: (*s_objet_argument_1).objet))));
1040: break;
1041: }
1042:
1043: case 'k' :
1044: {
1045: if (((*((integer8 *) (*s_objet_argument_1).objet))
1046: <= 0) || ((*((integer8 *)
1047: (*s_objet_argument_2).objet)) < 0))
1048: {
1049: (*s_etat_processus).exception =
1050: d_ep_resultat_indefini;
1051:
1052: liberation(s_etat_processus,
1053: s_objet_argument_1);
1054: liberation(s_etat_processus,
1055: s_objet_argument_2);
1056: liberation(s_etat_processus,
1057: s_objet_argument_3);
1058: liberation(s_etat_processus,
1059: s_objet_resultat);
1060:
1061: return;
1062: }
1063:
1064: (*((real8 *) (*s_objet_resultat).objet)) =
1065: exp(fabs((double) (*((integer8 *)
1066: (*s_objet_argument_1).objet)))) *
1067: gsl_sf_bessel_kl_scaled(
1068: (int) ((*((integer8 *)
1069: (*s_objet_argument_2).objet))),
1070: (double) ((*((integer8 *)
1071: (*s_objet_argument_1).objet))));
1072: break;
1073: }
1074: }
1075: }
1076: else if ((*s_objet_argument_1).type == REL)
1077: {
1078: if ((s_objet_resultat = allocation(s_etat_processus, REL))
1079: == NULL)
1080: {
1081: (*s_etat_processus).erreur_systeme =
1082: d_es_allocation_memoire;
1083: return;
1084: }
1085:
1086: switch((*((unsigned char *) (*s_objet_argument_3).objet)))
1087: {
1088: case 'J' :
1089: {
1090: (*((real8 *) (*s_objet_resultat).objet)) =
1091: gsl_sf_bessel_Jn((int) ((*((integer8 *)
1092: (*s_objet_argument_2).objet))),
1093: (double) ((*((real8 *)
1094: (*s_objet_argument_1).objet))));
1095: break;
1096: }
1097:
1098: case 'Y' :
1099: {
1100: if ((*((real8 *) (*s_objet_argument_1).objet))
1101: <= 0)
1102: {
1103: (*s_etat_processus).exception =
1104: d_ep_resultat_indefini;
1105:
1106: liberation(s_etat_processus,
1107: s_objet_argument_1);
1108: liberation(s_etat_processus,
1109: s_objet_argument_2);
1110: liberation(s_etat_processus,
1111: s_objet_argument_3);
1112: liberation(s_etat_processus,
1113: s_objet_resultat);
1114:
1115: return;
1116: }
1117:
1118: (*((real8 *) (*s_objet_resultat).objet)) =
1119: gsl_sf_bessel_Yn((int) ((*((integer8 *)
1120: (*s_objet_argument_2).objet))),
1121: (double) ((*((real8 *)
1122: (*s_objet_argument_1).objet))));
1123: break;
1124: }
1125:
1126: case 'I' :
1127: {
1128: (*((real8 *) (*s_objet_resultat).objet)) =
1129: gsl_sf_bessel_In((int) ((*((integer8 *)
1130: (*s_objet_argument_2).objet))),
1131: (double) ((*((real8 *)
1132: (*s_objet_argument_1).objet))));
1133: break;
1134: }
1135:
1136: case 'K' :
1137: {
1138: if ((*((real8 *) (*s_objet_argument_1).objet))
1139: <= 0)
1140: {
1141: (*s_etat_processus).exception =
1142: d_ep_resultat_indefini;
1143:
1144: liberation(s_etat_processus,
1145: s_objet_argument_1);
1146: liberation(s_etat_processus,
1147: s_objet_argument_2);
1148: liberation(s_etat_processus,
1149: s_objet_argument_3);
1150: liberation(s_etat_processus,
1151: s_objet_resultat);
1152:
1153: return;
1154: }
1155:
1156: (*((real8 *) (*s_objet_resultat).objet)) =
1157: gsl_sf_bessel_Kn((int) ((*((integer8 *)
1158: (*s_objet_argument_2).objet))),
1159: (double) ((*((real8 *)
1160: (*s_objet_argument_1).objet))));
1161: break;
1162: }
1163:
1164: case 'j' :
1165: {
1166: if (((*((integer8 *) (*s_objet_argument_1).objet))
1167: < 0) || ((*((integer8 *)
1168: (*s_objet_argument_2).objet)) < 0))
1169: {
1170: (*s_etat_processus).exception =
1171: d_ep_resultat_indefini;
1172:
1173: liberation(s_etat_processus,
1174: s_objet_argument_1);
1175: liberation(s_etat_processus,
1176: s_objet_argument_2);
1177: liberation(s_etat_processus,
1178: s_objet_argument_3);
1179: liberation(s_etat_processus,
1180: s_objet_resultat);
1181:
1182: return;
1183: }
1184:
1185: (*((real8 *) (*s_objet_resultat).objet)) =
1186: gsl_sf_bessel_jl((int) ((*((integer8 *)
1187: (*s_objet_argument_2).objet))),
1188: (double) ((*((real8 *)
1189: (*s_objet_argument_1).objet))));
1190: break;
1191: }
1192:
1193: case 'y' :
1194: {
1195: if (((*((integer8 *) (*s_objet_argument_1).objet))
1196: <= 0) || ((*((integer8 *)
1197: (*s_objet_argument_2).objet)) < 0))
1198: {
1199: (*s_etat_processus).exception =
1200: d_ep_resultat_indefini;
1201:
1202: liberation(s_etat_processus,
1203: s_objet_argument_1);
1204: liberation(s_etat_processus,
1205: s_objet_argument_2);
1206: liberation(s_etat_processus,
1207: s_objet_argument_3);
1208: liberation(s_etat_processus,
1209: s_objet_resultat);
1210:
1211: return;
1212: }
1213:
1214: (*((real8 *) (*s_objet_resultat).objet)) =
1215: gsl_sf_bessel_yl((int) ((*((integer8 *)
1216: (*s_objet_argument_2).objet))),
1217: (double) ((*((real8 *)
1218: (*s_objet_argument_1).objet))));
1219: break;
1220: }
1221:
1222: case 'i' :
1223: {
1224: if ((*((integer8 *) (*s_objet_argument_2).objet))
1225: < 0)
1226: {
1227: (*s_etat_processus).exception =
1228: d_ep_resultat_indefini;
1229:
1230: liberation(s_etat_processus,
1231: s_objet_argument_1);
1232: liberation(s_etat_processus,
1233: s_objet_argument_2);
1234: liberation(s_etat_processus,
1235: s_objet_argument_3);
1236: liberation(s_etat_processus,
1237: s_objet_resultat);
1238:
1239: return;
1240: }
1241:
1242: (*((real8 *) (*s_objet_resultat).objet)) =
1243: exp(fabs((double) (*((real8 *)
1244: (*s_objet_argument_1).objet)))) *
1245: gsl_sf_bessel_il_scaled(
1246: (int) ((*((integer8 *)
1247: (*s_objet_argument_2).objet))),
1248: (double) ((*((real8 *)
1249: (*s_objet_argument_1).objet))));
1250: break;
1251: }
1252:
1253: case 'k' :
1254: {
1255: if (((*((integer8 *) (*s_objet_argument_1).objet))
1256: <= 0) || ((*((integer8 *)
1257: (*s_objet_argument_2).objet)) < 0))
1258: {
1259: (*s_etat_processus).exception =
1260: d_ep_resultat_indefini;
1261:
1262: liberation(s_etat_processus,
1263: s_objet_argument_1);
1264: liberation(s_etat_processus,
1265: s_objet_argument_2);
1266: liberation(s_etat_processus,
1267: s_objet_argument_3);
1268: liberation(s_etat_processus,
1269: s_objet_resultat);
1270:
1271: return;
1272: }
1273:
1274: (*((real8 *) (*s_objet_resultat).objet)) =
1275: exp(fabs((double) (*((real8 *)
1276: (*s_objet_argument_1).objet)))) *
1277: gsl_sf_bessel_kl_scaled(
1278: (int) ((*((integer8 *)
1279: (*s_objet_argument_2).objet))),
1280: (double) ((*((real8 *)
1281: (*s_objet_argument_1).objet))));
1282: break;
1283: }
1284: }
1285: }
1286: else if (((*s_objet_argument_1).type == NOM) ||
1287: ((*s_objet_argument_1).type == RPN) ||
1288: ((*s_objet_argument_1).type == ALG))
1289: {
1290: creation_expression = d_vrai;
1291: }
1292: else
1293: {
1294: liberation(s_etat_processus, s_objet_argument_1);
1295: liberation(s_etat_processus, s_objet_argument_2);
1296: liberation(s_etat_processus, s_objet_argument_3);
1297:
1298: (*s_etat_processus).erreur_execution =
1299: d_ex_erreur_type_argument;
1300: return;
1301: }
1302: }
1303: else if ((*s_objet_argument_2).type == REL)
1304: {
1305: if ((*s_objet_argument_1).type == INT)
1306: {
1307: if ((s_objet_resultat = allocation(s_etat_processus, REL))
1308: == NULL)
1309: {
1310: (*s_etat_processus).erreur_systeme =
1311: d_es_allocation_memoire;
1312: return;
1313: }
1314:
1315: switch((*((unsigned char *) (*s_objet_argument_3).objet)))
1316: {
1317: case 'J' :
1318: {
1319: if (((*((integer8 *) (*s_objet_argument_1).objet))
1320: < 0) || ((*((real8 *)
1321: (*s_objet_argument_2).objet)) < 0))
1322: {
1323: (*s_etat_processus).exception =
1324: d_ep_resultat_indefini;
1325:
1326: liberation(s_etat_processus,
1327: s_objet_argument_1);
1328: liberation(s_etat_processus,
1329: s_objet_argument_2);
1330: liberation(s_etat_processus,
1331: s_objet_argument_3);
1332: liberation(s_etat_processus,
1333: s_objet_resultat);
1334:
1335: return;
1336: }
1337:
1338: (*((real8 *) (*s_objet_resultat).objet)) =
1339: gsl_sf_bessel_Jnu((double) ((*((real8 *)
1340: (*s_objet_argument_2).objet))),
1341: (double) ((*((integer8 *)
1342: (*s_objet_argument_1).objet))));
1343:
1344: break;
1345: }
1346:
1347: case 'Y' :
1348: {
1349: if (((*((integer8 *) (*s_objet_argument_1).objet))
1350: <= 0) || ((*((real8 *)
1351: (*s_objet_argument_2).objet)) < 0))
1352: {
1353: (*s_etat_processus).exception =
1354: d_ep_resultat_indefini;
1355:
1356: liberation(s_etat_processus,
1357: s_objet_argument_1);
1358: liberation(s_etat_processus,
1359: s_objet_argument_2);
1360: liberation(s_etat_processus,
1361: s_objet_argument_3);
1362: liberation(s_etat_processus,
1363: s_objet_resultat);
1364:
1365: return;
1366: }
1367:
1368: (*((real8 *) (*s_objet_resultat).objet)) =
1369: gsl_sf_bessel_Ynu((double) ((*((real8 *)
1370: (*s_objet_argument_2).objet))),
1371: (double) ((*((integer8 *)
1372: (*s_objet_argument_1).objet))));
1373: break;
1374: }
1375:
1376: case 'I' :
1377: {
1378: if (((*((integer8 *) (*s_objet_argument_1).objet))
1379: < 0) || ((*((real8 *)
1380: (*s_objet_argument_2).objet)) < 0))
1381: {
1382: (*s_etat_processus).exception =
1383: d_ep_resultat_indefini;
1384:
1385: liberation(s_etat_processus,
1386: s_objet_argument_1);
1387: liberation(s_etat_processus,
1388: s_objet_argument_2);
1389: liberation(s_etat_processus,
1390: s_objet_argument_3);
1391: liberation(s_etat_processus,
1392: s_objet_resultat);
1393:
1394: return;
1395: }
1396:
1397: (*((real8 *) (*s_objet_resultat).objet)) =
1398: gsl_sf_bessel_Inu((double) ((*((real8 *)
1399: (*s_objet_argument_2).objet))),
1400: (double) ((*((integer8 *)
1401: (*s_objet_argument_1).objet))));
1402: break;
1403: }
1404:
1405: case 'K' :
1406: {
1407: if (((*((integer8 *) (*s_objet_argument_1).objet))
1408: <= 0) || ((*((real8 *)
1409: (*s_objet_argument_2).objet)) < 0))
1410: {
1411: (*s_etat_processus).exception =
1412: d_ep_resultat_indefini;
1413:
1414: liberation(s_etat_processus,
1415: s_objet_argument_1);
1416: liberation(s_etat_processus,
1417: s_objet_argument_2);
1418: liberation(s_etat_processus,
1419: s_objet_argument_3);
1420: liberation(s_etat_processus,
1421: s_objet_resultat);
1422:
1423: return;
1424: }
1425:
1426: (*((real8 *) (*s_objet_resultat).objet)) =
1427: gsl_sf_bessel_Knu((double) ((*((real8 *)
1428: (*s_objet_argument_2).objet))),
1429: (double) ((*((integer8 *)
1430: (*s_objet_argument_1).objet))));
1431: break;
1432: }
1433:
1434: default :
1435: {
1436: (*s_etat_processus).exception =
1437: d_ep_resultat_indefini;
1438:
1439: liberation(s_etat_processus, s_objet_argument_1);
1440: liberation(s_etat_processus, s_objet_argument_2);
1441: liberation(s_etat_processus, s_objet_argument_3);
1442: liberation(s_etat_processus, s_objet_resultat);
1443:
1444: return;
1445: break;
1446: }
1447: }
1448: }
1449: else if ((*s_objet_argument_1).type == REL)
1450: {
1451: if ((s_objet_resultat = allocation(s_etat_processus, REL))
1452: == NULL)
1453: {
1454: (*s_etat_processus).erreur_systeme =
1455: d_es_allocation_memoire;
1456: return;
1457: }
1458:
1459: switch((*((unsigned char *) (*s_objet_argument_3).objet)))
1460: {
1461: case 'J' :
1462: {
1463: if (((*((real8 *) (*s_objet_argument_1).objet))
1464: < 0) || ((*((real8 *)
1465: (*s_objet_argument_2).objet)) < 0))
1466: {
1467: (*s_etat_processus).exception =
1468: d_ep_resultat_indefini;
1469:
1470: liberation(s_etat_processus,
1471: s_objet_argument_1);
1472: liberation(s_etat_processus,
1473: s_objet_argument_2);
1474: liberation(s_etat_processus,
1475: s_objet_argument_3);
1476: liberation(s_etat_processus,
1477: s_objet_resultat);
1478:
1479: return;
1480: }
1481:
1482: (*((real8 *) (*s_objet_resultat).objet)) =
1483: gsl_sf_bessel_Jnu((double) ((*((real8 *)
1484: (*s_objet_argument_2).objet))),
1485: (double) ((*((real8 *)
1486: (*s_objet_argument_1).objet))));
1487: break;
1488: }
1489:
1490: case 'Y' :
1491: {
1492: if (((*((real8 *) (*s_objet_argument_1).objet))
1493: <= 0) || ((*((real8 *)
1494: (*s_objet_argument_2).objet)) < 0))
1495: {
1496: (*s_etat_processus).exception =
1497: d_ep_resultat_indefini;
1498:
1499: liberation(s_etat_processus,
1500: s_objet_argument_1);
1501: liberation(s_etat_processus,
1502: s_objet_argument_2);
1503: liberation(s_etat_processus,
1504: s_objet_argument_3);
1505: liberation(s_etat_processus,
1506: s_objet_resultat);
1507:
1508: return;
1509: }
1510:
1511: (*((real8 *) (*s_objet_resultat).objet)) =
1.45 bertrand 1512: gsl_sf_bessel_Yn((int) ((*((real8 *)
1.1 bertrand 1513: (*s_objet_argument_2).objet))),
1514: (double) ((*((real8 *)
1515: (*s_objet_argument_1).objet))));
1516: break;
1517: }
1518:
1519: case 'I' :
1520: {
1521: if (((*((real8 *) (*s_objet_argument_1).objet))
1522: < 0) || ((*((real8 *)
1523: (*s_objet_argument_2).objet)) < 0))
1524: {
1525: (*s_etat_processus).exception =
1526: d_ep_resultat_indefini;
1527:
1528: liberation(s_etat_processus,
1529: s_objet_argument_1);
1530: liberation(s_etat_processus,
1531: s_objet_argument_2);
1532: liberation(s_etat_processus,
1533: s_objet_argument_3);
1534: liberation(s_etat_processus,
1535: s_objet_resultat);
1536:
1537: return;
1538: }
1539:
1540: (*((real8 *) (*s_objet_resultat).objet)) =
1.45 bertrand 1541: gsl_sf_bessel_In((int) ((*((real8 *)
1.1 bertrand 1542: (*s_objet_argument_2).objet))),
1543: (double) ((*((real8 *)
1544: (*s_objet_argument_1).objet))));
1545: break;
1546: }
1547:
1548: case 'K' :
1549: {
1550: if (((*((real8 *) (*s_objet_argument_1).objet))
1551: <= 0) || ((*((real8 *)
1552: (*s_objet_argument_2).objet)) < 0))
1553: {
1554: (*s_etat_processus).exception =
1555: d_ep_resultat_indefini;
1556:
1557: liberation(s_etat_processus,
1558: s_objet_argument_1);
1559: liberation(s_etat_processus,
1560: s_objet_argument_2);
1561: liberation(s_etat_processus,
1562: s_objet_argument_3);
1563: liberation(s_etat_processus,
1564: s_objet_resultat);
1565:
1566: return;
1567: }
1568:
1569: (*((real8 *) (*s_objet_resultat).objet)) =
1.45 bertrand 1570: gsl_sf_bessel_Kn((int) ((*((real8 *)
1.1 bertrand 1571: (*s_objet_argument_2).objet))),
1572: (double) ((*((real8 *)
1573: (*s_objet_argument_1).objet))));
1574: break;
1575: }
1576:
1577: default :
1578: {
1579: (*s_etat_processus).exception =
1580: d_ep_resultat_indefini;
1581:
1582: liberation(s_etat_processus, s_objet_argument_1);
1583: liberation(s_etat_processus, s_objet_argument_2);
1584: liberation(s_etat_processus, s_objet_argument_3);
1585: liberation(s_etat_processus, s_objet_resultat);
1586:
1587: return;
1588: break;
1589: }
1590: }
1591: }
1592: else
1593: {
1594: liberation(s_etat_processus, s_objet_argument_1);
1595: liberation(s_etat_processus, s_objet_argument_2);
1596: liberation(s_etat_processus, s_objet_argument_3);
1597:
1598: (*s_etat_processus).erreur_execution =
1599: d_ex_erreur_type_argument;
1600: return;
1601: }
1602: }
1603: else if (((*s_objet_argument_2).type == NOM) ||
1604: ((*s_objet_argument_2).type == RPN) ||
1605: ((*s_objet_argument_2).type == ALG))
1606: {
1607: creation_expression = d_vrai;
1608: }
1609: else
1610: {
1611: liberation(s_etat_processus, s_objet_argument_1);
1612: liberation(s_etat_processus, s_objet_argument_2);
1613: liberation(s_etat_processus, s_objet_argument_3);
1614:
1615: (*s_etat_processus).erreur_execution =
1616: d_ex_erreur_type_argument;
1617: return;
1618: }
1619: }
1620: else
1621: {
1622: liberation(s_etat_processus, s_objet_argument_1);
1623: liberation(s_etat_processus, s_objet_argument_2);
1624: liberation(s_etat_processus, s_objet_argument_3);
1625:
1626: (*s_etat_processus).erreur_execution = d_ex_argument_invalide;
1627: return;
1628: }
1629: }
1630: else if (((*s_objet_argument_3).type == NOM) ||
1631: ((*s_objet_argument_3).type == RPN) ||
1632: ((*s_objet_argument_3).type == ALG))
1633: {
1634: creation_expression = d_vrai;
1635: }
1636: else
1637: {
1638: liberation(s_etat_processus, s_objet_argument_1);
1639: liberation(s_etat_processus, s_objet_argument_2);
1640: liberation(s_etat_processus, s_objet_argument_3);
1641:
1642: (*s_etat_processus).erreur_execution = d_ex_erreur_type_argument;
1643: return;
1644: }
1645:
1646: if (creation_expression == d_vrai)
1647: {
1648: if ((s_copie_argument_1 = copie_objet(s_etat_processus,
1649: s_objet_argument_1, 'N')) == NULL)
1650: {
1651: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
1652: return;
1653: }
1654:
1655: if ((s_copie_argument_2 = copie_objet(s_etat_processus,
1656: s_objet_argument_2, 'N')) == NULL)
1657: {
1658: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
1659: return;
1660: }
1661:
1662: if ((s_copie_argument_3 = copie_objet(s_etat_processus,
1663: s_objet_argument_3, 'N')) == NULL)
1664: {
1665: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
1666: return;
1667: }
1668:
1669: if (((*s_copie_argument_1).type == RPN) ||
1670: ((*s_copie_argument_2).type == RPN) ||
1671: ((*s_copie_argument_3).type == RPN))
1672: {
1673: if ((s_objet_resultat = allocation(s_etat_processus, RPN))
1674: == NULL)
1675: {
1676: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
1677: return;
1678: }
1679: }
1680: else
1681: {
1682: if ((s_objet_resultat = allocation(s_etat_processus, ALG))
1683: == NULL)
1684: {
1685: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
1686: return;
1687: }
1688: }
1689:
1690: if (((*s_objet_resultat).objet =
1691: allocation_maillon(s_etat_processus)) == NULL)
1692: {
1693: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
1694: return;
1695: }
1696:
1697: l_element_courant = (*s_objet_resultat).objet;
1698:
1699: if (((*l_element_courant).donnee = allocation(s_etat_processus, FCT))
1700: == NULL)
1701: {
1702: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
1703: return;
1704: }
1705:
1706: (*((struct_fonction *) (*(*l_element_courant).donnee).objet))
1707: .nombre_arguments = 0;
1708: (*((struct_fonction *) (*(*l_element_courant).donnee).objet))
1709: .fonction = instruction_vers_niveau_superieur;
1710:
1711: if (((*((struct_fonction *) (*(*l_element_courant).donnee).objet))
1712: .nom_fonction = malloc(3 * sizeof(unsigned char))) == NULL)
1713: {
1714: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
1715: return;
1716: }
1717:
1718: strcpy((*((struct_fonction *) (*(*l_element_courant).donnee).objet))
1719: .nom_fonction, "<<");
1720:
1721: if (((*s_copie_argument_3).type == ALG) ||
1722: ((*s_copie_argument_3).type == RPN))
1723: {
1724:
1725: l_element_atome = (struct_liste_chainee *)
1726: (*s_copie_argument_3).objet;
1727:
1728: i = 0;
1729:
1730: while(l_element_atome != NULL)
1731: {
1732: i++;
1733: l_element_atome = (*l_element_atome).suivant;
1734: }
1735:
1736: if (i < 3)
1737: {
1738: if (((*l_element_courant).suivant =
1739: allocation_maillon(s_etat_processus)) == NULL)
1740: {
1741: (*s_etat_processus).erreur_systeme =
1742: d_es_allocation_memoire;
1743: return;
1744: }
1745:
1746: l_element_courant = (*l_element_courant).suivant;
1747: (*l_element_courant).donnee = s_copie_argument_3;
1748: }
1749: else
1750: {
1751: (*l_element_courant).suivant = (*((struct_liste_chainee *)
1752: (*s_copie_argument_3).objet)).suivant;
1753:
1754: l_element_precedent = NULL;
1755: l_element_courant = (*l_element_courant).suivant;
1756:
1757: liberation(s_etat_processus,
1758: (*((struct_liste_chainee *) (*s_copie_argument_3)
1759: .objet)).donnee);
1760: free((*s_copie_argument_3).objet);
1761: free(s_copie_argument_3);
1762:
1763: while((*l_element_courant).suivant != NULL)
1764: {
1765: l_element_precedent = l_element_courant;
1766: l_element_courant = (*l_element_courant).suivant;
1767: }
1768:
1769: liberation(s_etat_processus, (*l_element_courant).donnee);
1770: free(l_element_courant);
1771:
1772: l_element_courant = l_element_precedent;
1773: }
1774: }
1775: else
1776: {
1777: if (((*l_element_courant).suivant =
1778: allocation_maillon(s_etat_processus)) == NULL)
1779: {
1780: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
1781: return;
1782: }
1783:
1784: l_element_courant = (*l_element_courant).suivant;
1785: (*l_element_courant).donnee = s_copie_argument_3;
1786: }
1787:
1788: if (((*s_copie_argument_2).type == ALG) ||
1789: ((*s_copie_argument_2).type == RPN))
1790: {
1791: l_element_atome = (struct_liste_chainee *)
1792: (*s_copie_argument_2).objet;
1793:
1794: i = 0;
1795:
1796: while(l_element_atome != NULL)
1797: {
1798: i++;
1799: l_element_atome = (*l_element_atome).suivant;
1800: }
1801:
1802: if (i < 3)
1803: {
1804: if (((*l_element_courant).suivant =
1805: allocation_maillon(s_etat_processus)) == NULL)
1806: {
1807: (*s_etat_processus).erreur_systeme =
1808: d_es_allocation_memoire;
1809: return;
1810: }
1811:
1812: l_element_courant = (*l_element_courant).suivant;
1813: (*l_element_courant).donnee = s_copie_argument_2;
1814: }
1815: else
1816: {
1817: (*l_element_courant).suivant = (*((struct_liste_chainee *)
1818: (*s_copie_argument_2).objet)).suivant;
1819:
1820: l_element_courant = (*l_element_courant).suivant;
1821: l_element_precedent = NULL;
1822:
1823: liberation(s_etat_processus,
1824: (*((struct_liste_chainee *) (*s_copie_argument_2)
1825: .objet)).donnee);
1826: free((*s_copie_argument_2).objet);
1827: free(s_copie_argument_2);
1828:
1829: while((*l_element_courant).suivant != NULL)
1830: {
1831: l_element_precedent = l_element_courant;
1832: l_element_courant = (*l_element_courant).suivant;
1833: }
1834:
1835: liberation(s_etat_processus, (*l_element_courant).donnee);
1836: free(l_element_courant);
1837:
1838: l_element_courant = l_element_precedent;
1839: }
1840: }
1841: else
1842: {
1843: if (((*l_element_courant).suivant =
1844: allocation_maillon(s_etat_processus)) == NULL)
1845: {
1846: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
1847: return;
1848: }
1849:
1850: l_element_courant = (*l_element_courant).suivant;
1851: (*l_element_courant).donnee = s_copie_argument_2;
1852: }
1853:
1854: if (((*s_copie_argument_1).type == ALG) ||
1855: ((*s_copie_argument_1).type == RPN))
1856: {
1857: l_element_atome = (struct_liste_chainee *)
1858: (*s_copie_argument_1).objet;
1859:
1860: i = 0;
1861:
1862: while(l_element_atome != NULL)
1863: {
1864: i++;
1865: l_element_atome = (*l_element_atome).suivant;
1866: }
1867:
1868: if (i < 3)
1869: {
1870: if (((*l_element_courant).suivant =
1871: allocation_maillon(s_etat_processus)) == NULL)
1872: {
1873: (*s_etat_processus).erreur_systeme =
1874: d_es_allocation_memoire;
1875: return;
1876: }
1877:
1878: l_element_courant = (*l_element_courant).suivant;
1879: (*l_element_courant).donnee = s_copie_argument_1;
1880: }
1881: else
1882: {
1883: (*l_element_courant).suivant = (*((struct_liste_chainee *)
1884: (*s_copie_argument_1).objet)).suivant;
1885:
1886: l_element_courant = (*l_element_courant).suivant;
1887: l_element_precedent = NULL;
1888:
1889: liberation(s_etat_processus,
1890: (*((struct_liste_chainee *) (*s_copie_argument_1)
1891: .objet)).donnee);
1892: free((*s_copie_argument_1).objet);
1893: free(s_copie_argument_1);
1894:
1895: while((*l_element_courant).suivant != NULL)
1896: {
1897: l_element_precedent = l_element_courant;
1898: l_element_courant = (*l_element_courant).suivant;
1899: }
1900:
1901: liberation(s_etat_processus, (*l_element_courant).donnee);
1902: free(l_element_courant);
1903:
1904: l_element_courant = l_element_precedent;
1905: }
1906: }
1907: else
1908: {
1909: if (((*l_element_courant).suivant =
1910: allocation_maillon(s_etat_processus)) == NULL)
1911: {
1912: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
1913: return;
1914: }
1915:
1916: l_element_courant = (*l_element_courant).suivant;
1917: (*l_element_courant).donnee = s_copie_argument_1;
1918: }
1919:
1920: if (((*l_element_courant).suivant =
1921: allocation_maillon(s_etat_processus)) == NULL)
1922: {
1923: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
1924: return;
1925: }
1926:
1927: l_element_courant = (*l_element_courant).suivant;
1928:
1929: if (((*l_element_courant).donnee =
1930: allocation(s_etat_processus, FCT)) == NULL)
1931: {
1932: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
1933: return;
1934: }
1935:
1936: (*((struct_fonction *) (*(*l_element_courant).donnee).objet))
1937: .nombre_arguments = 3;
1938: (*((struct_fonction *) (*(*l_element_courant).donnee).objet))
1939: .fonction = instruction_bessel;
1940:
1941: if (((*((struct_fonction *) (*(*l_element_courant).donnee).objet))
1942: .nom_fonction = malloc(7 * sizeof(unsigned char))) == NULL)
1943: {
1944: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
1945: return;
1946: }
1947:
1948: strcpy((*((struct_fonction *) (*(*l_element_courant).donnee).objet))
1949: .nom_fonction, "BESSEL");
1950:
1951: if (((*l_element_courant).suivant =
1952: allocation_maillon(s_etat_processus)) == NULL)
1953: {
1954: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
1955: return;
1956: }
1957:
1958: l_element_courant = (*l_element_courant).suivant;
1959:
1960: if (((*l_element_courant).donnee = (struct_objet *)
1961: allocation(s_etat_processus, FCT)) == NULL)
1962: {
1963: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
1964: return;
1965: }
1966:
1967: (*((struct_fonction *) (*(*l_element_courant).donnee).objet))
1968: .nombre_arguments = 0;
1969: (*((struct_fonction *) (*(*l_element_courant).donnee).objet))
1970: .fonction = instruction_vers_niveau_inferieur;
1971:
1972: if (((*((struct_fonction *) (*(*l_element_courant).donnee).objet))
1973: .nom_fonction = malloc(3 * sizeof(unsigned char))) == NULL)
1974: {
1975: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
1976: return;
1977: }
1978:
1979: strcpy((*((struct_fonction *) (*(*l_element_courant).donnee).objet))
1980: .nom_fonction, ">>");
1981:
1982: (*l_element_courant).suivant = NULL;
1983: }
1984:
1985: if (empilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
1986: s_objet_resultat) == d_erreur)
1987: {
1988: return;
1989: }
1990:
1991: liberation(s_etat_processus, s_objet_argument_1);
1992: liberation(s_etat_processus, s_objet_argument_2);
1993: liberation(s_etat_processus, s_objet_argument_3);
1994:
1995: return;
1996: }
1997:
1.11 bertrand 1998:
1999: /*
2000: ================================================================================
2001: Fonction 'backtrace'
2002: ================================================================================
2003: Entrées :
2004: --------------------------------------------------------------------------------
2005: Sorties :
2006: --------------------------------------------------------------------------------
2007: Effets de bord : néant
2008: ================================================================================
2009: */
2010:
2011: void
2012: instruction_backtrace(struct_processus *s_etat_processus)
2013: {
2014: (*s_etat_processus).erreur_execution = d_ex;
2015:
2016: if ((*s_etat_processus).affichage_arguments == 'Y')
2017: {
2018: printf("\n BACKTRACE ");
2019:
2020: if ((*s_etat_processus).langue == 'F')
2021: {
2022: printf("(affichage de la pile système)\n\n");
2023: printf(" Aucun argument\n");
2024: }
2025: else
2026: {
2027: printf("(print system stack)\n\n");
2028: printf(" No argument\n");
2029: }
2030:
2031: return;
2032: }
2033: else if ((*s_etat_processus).test_instruction == 'Y')
2034: {
2035: (*s_etat_processus).nombre_arguments = -1;
2036: return;
2037: }
2038:
2039: if (test_cfsf(s_etat_processus, 31) == d_vrai)
2040: {
2041: if (empilement_pile_last(s_etat_processus, 0) == d_erreur)
2042: {
2043: return;
2044: }
2045: }
2046:
2047: trace(s_etat_processus, stdout);
2048:
2049: return;
2050: }
2051:
1.1 bertrand 2052: // vim: ts=4