![[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.42 bertrand 3: RPL/2 (R) version 4.1.13
1.41 bertrand 4: Copyright (C) 1989-2013 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.5 bertrand 390: if (fseek((*descripteur).descripteur_c, position_initiale,
391: 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.5 bertrand 473: if (fseek((*descripteur).descripteur_c, position_initiale,
474: 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.5 bertrand 552: if (fseek((*descripteur).descripteur_c, position_finale,
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:
613: if (fseek((*descripteur).descripteur_c, position_finale - 1,
614: SEEK_SET) != 0)
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:
649: if (fseek((*descripteur).descripteur_c, position_finale
650: - nombre_octets, SEEK_SET) != 0)
651: {
652: liberation(s_etat_processus, s_objet_argument);
653:
654: (*s_etat_processus).erreur_systeme =
655: d_es_erreur_fichier;
656: return;
657: }
658:
659: if (fread(tampon, (size_t) sizeof(unsigned char),
1.45 ! bertrand 660: (size_t) nombre_octets,
! 661: (*descripteur).descripteur_c)
1.43 bertrand 662: != (size_t) nombre_octets)
663: {
664: liberation(s_etat_processus, s_objet_argument);
665:
666: (*s_etat_processus).erreur_systeme =
667: d_es_erreur_fichier;
668: return;
669: }
670:
671: // Récupération du LSB
672:
673: saut = (tampon[0] & 0xF0)
674: | ((tampon[nombre_octets - 1] & 0x0F) >> 4);
675:
676: // Autres octets
677:
678: for(i = 1; i < (nombre_octets - 1); i++)
679: {
1.44 bertrand 680: saut |= ((integer8) tampon[i]) <<
681: (((nombre_octets - 1) - i) * 8);
1.43 bertrand 682: }
683: }
684:
685: if (position_finale - saut >= 0)
686: {
687: if (fseek((*descripteur).descripteur_c,
688: position_finale - saut, SEEK_SET) != 0)
689: {
690: liberation(s_etat_processus, s_objet_argument);
691:
692: (*s_etat_processus).erreur_systeme =
693: d_es_erreur_fichier;
694: return;
695: }
696: }
697: else
698: {
699: liberation(s_etat_processus, s_objet_argument);
700:
701: (*s_etat_processus).erreur_execution =
702: d_ex_debut_de_fichier_atteint;
703: return;
704: }
1.1 bertrand 705: }
706: }
707: else
708: {
709: liberation(s_etat_processus, s_objet_argument);
710:
711: (*s_etat_processus).erreur_execution = d_ex_erreur_type_fichier;
712: return;
713: }
714: }
715: else
716: {
717: liberation(s_etat_processus, s_objet_argument);
718:
719: (*s_etat_processus).erreur_execution = d_ex_erreur_type_argument;
720: return;
721: }
722:
723: liberation(s_etat_processus, s_objet_argument);
724:
725: return;
726: }
727:
728:
729: /*
730: ================================================================================
731: Fonction 'bessel'
732: ================================================================================
733: Entrées :
734: --------------------------------------------------------------------------------
735: Sorties :
736: --------------------------------------------------------------------------------
737: Effets de bord : néant
738: ================================================================================
739: */
740:
741: void
742: instruction_bessel(struct_processus *s_etat_processus)
743: {
744: logical1 creation_expression;
745:
746: struct_liste_chainee *l_element_atome;
747: struct_liste_chainee *l_element_courant;
748: struct_liste_chainee *l_element_precedent;
749:
750: struct_objet *s_copie_argument_1;
751: struct_objet *s_copie_argument_2;
752: struct_objet *s_copie_argument_3;
753: struct_objet *s_objet_argument_1;
754: struct_objet *s_objet_argument_2;
755: struct_objet *s_objet_argument_3;
756: struct_objet *s_objet_resultat;
757:
758: unsigned long i;
759:
760: (*s_etat_processus).erreur_execution = d_ex;
761:
762: if ((*s_etat_processus).affichage_arguments == 'Y')
763: {
764: printf("\n BESSEL ");
765:
766: if ((*s_etat_processus).langue == 'F')
767: {
768: printf("(fonctions de Bessel)\n\n");
769: }
770: else
771: {
772: printf("(Bessel functions)\n\n");
773: }
774:
775: printf(" 3: \"J\", \"Y\", \"I\", \"K\", \"j\", \"y\", "
776: "\"i\", \"k\"\n");
777: printf(" 2: %s, %s\n", d_INT, d_REL);
778: printf(" 1: %s, %s\n", d_INT, d_REL);
779: printf("-> 1: %s\n\n", d_REL);
780:
781: printf(" 3: \"J\", \"Y\", \"I\", \"K\", \"j\", \"y\", "
782: "\"i\", \"k\"\n");
783: printf(" 2: %s, %s\n", d_INT, d_REL);
784: printf(" 1: %s, %s\n", d_NOM, d_ALG);
785: printf("-> 1: %s\n\n", d_ALG);
786:
787: printf(" 3: \"J\", \"Y\", \"I\", \"K\", \"j\", \"y\", "
788: "\"i\", \"k\"\n");
789: printf(" 2: %s, %s\n", d_INT, d_REL);
790: printf(" 1: %s\n", d_RPN);
791: printf("-> 1: %s\n", d_RPN);
792: return;
793: }
794: else if ((*s_etat_processus).test_instruction == 'Y')
795: {
796: (*s_etat_processus).nombre_arguments = 3;
797: return;
798: }
799:
800: if (test_cfsf(s_etat_processus, 31) == d_vrai)
801: {
802: if (empilement_pile_last(s_etat_processus, 3) == d_erreur)
803: {
804: return;
805: }
806: }
807:
808: /*
809: * Jn fonction cylindrique régulière
810: * Yn fonction cylindrique irrégulière
811: * In fonction cylindrique régulière modifiée
812: * Kn fonction cylindrique irrégulière modifiée
813: * jn fonction sphérique régulière
814: * yn fonction sphérique irrégulière
815: * in fonction sphérique régulière modifiée
816: * kn fonction sphérique irrégulière modifiée
817: *
818: * Attention : Ordre fractionnaire uniquement pour les
819: * fonctions cylindriques
820: */
821:
822: creation_expression = d_faux;
823:
824: if (depilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
825: &s_objet_argument_1) == d_erreur)
826: {
827: (*s_etat_processus).erreur_execution = d_ex_manque_argument;
828: return;
829: }
830:
831: if (depilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
832: &s_objet_argument_2) == d_erreur)
833: {
834: liberation(s_etat_processus, s_objet_argument_1);
835:
836: (*s_etat_processus).erreur_execution = d_ex_manque_argument;
837: return;
838: }
839:
840: if (depilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
841: &s_objet_argument_3) == d_erreur)
842: {
843: liberation(s_etat_processus, s_objet_argument_1);
844: liberation(s_etat_processus, s_objet_argument_2);
845:
846: (*s_etat_processus).erreur_execution = d_ex_manque_argument;
847: return;
848: }
849:
850: if ((*s_objet_argument_3).type == CHN)
851: {
852: if ((strcmp((unsigned char *) (*s_objet_argument_3).objet, "J") == 0) ||
853: (strcmp((unsigned char *) (*s_objet_argument_3).objet, "Y")
854: == 0) || (strcmp((unsigned char *) (*s_objet_argument_3).objet,
855: "I") == 0) || (strcmp((unsigned char *) (*s_objet_argument_3)
856: .objet, "K") == 0) || (strcmp((unsigned char *)
857: (*s_objet_argument_3).objet, "j") == 0) || (strcmp(
858: (unsigned char *) (*s_objet_argument_3).objet, "y") == 0) ||
859: (strcmp((unsigned char *) (*s_objet_argument_3).objet, "i") ==
860: 0) || (strcmp((unsigned char *) (*s_objet_argument_3).objet,
861: "k") == 0))
862: {
863: if ((*s_objet_argument_2).type == INT)
864: {
865: if ((*s_objet_argument_1).type == INT)
866: {
867: if ((s_objet_resultat = allocation(s_etat_processus, REL))
868: == NULL)
869: {
870: (*s_etat_processus).erreur_systeme =
871: d_es_allocation_memoire;
872: return;
873: }
874:
875: switch((*((unsigned char *) (*s_objet_argument_3).objet)))
876: {
877: case 'J' :
878: {
879: (*((real8 *) (*s_objet_resultat).objet)) =
880: gsl_sf_bessel_Jn((int) ((*((integer8 *)
881: (*s_objet_argument_2).objet))),
882: (double) ((*((integer8 *)
883: (*s_objet_argument_1).objet))));
884: break;
885: }
886:
887: case 'Y' :
888: {
889: if ((*((integer8 *) (*s_objet_argument_1).objet))
890: <= 0)
891: {
892: (*s_etat_processus).exception =
893: d_ep_resultat_indefini;
894:
895: liberation(s_etat_processus,
896: s_objet_argument_1);
897: liberation(s_etat_processus,
898: s_objet_argument_2);
899: liberation(s_etat_processus,
900: s_objet_argument_3);
901: liberation(s_etat_processus,
902: s_objet_resultat);
903:
904: return;
905: }
906:
907: (*((real8 *) (*s_objet_resultat).objet)) =
908: gsl_sf_bessel_Yn((int) ((*((integer8 *)
909: (*s_objet_argument_2).objet))),
910: (double) ((*((integer8 *)
911: (*s_objet_argument_1).objet))));
912: break;
913: }
914:
915: case 'I' :
916: {
917: (*((real8 *) (*s_objet_resultat).objet)) =
918: gsl_sf_bessel_In((int) ((*((integer8 *)
919: (*s_objet_argument_2).objet))),
920: (double) ((*((integer8 *)
921: (*s_objet_argument_1).objet))));
922: break;
923: }
924:
925: case 'K' :
926: {
927: if ((*((integer8 *) (*s_objet_argument_1).objet))
928: <= 0)
929: {
930: (*s_etat_processus).exception =
931: d_ep_resultat_indefini;
932:
933: liberation(s_etat_processus,
934: s_objet_argument_1);
935: liberation(s_etat_processus,
936: s_objet_argument_2);
937: liberation(s_etat_processus,
938: s_objet_argument_3);
939: liberation(s_etat_processus,
940: s_objet_resultat);
941:
942: return;
943: }
944:
945: (*((real8 *) (*s_objet_resultat).objet)) =
946: gsl_sf_bessel_Kn((int) ((*((integer8 *)
947: (*s_objet_argument_2).objet))),
948: (double) ((*((integer8 *)
949: (*s_objet_argument_1).objet))));
950: break;
951: }
952:
953: case 'j' :
954: {
955: if (((*((integer8 *) (*s_objet_argument_1).objet))
956: < 0) || ((*((integer8 *)
957: (*s_objet_argument_2).objet)) < 0))
958: {
959: (*s_etat_processus).exception =
960: d_ep_resultat_indefini;
961:
962: liberation(s_etat_processus,
963: s_objet_argument_1);
964: liberation(s_etat_processus,
965: s_objet_argument_2);
966: liberation(s_etat_processus,
967: s_objet_argument_3);
968: liberation(s_etat_processus,
969: s_objet_resultat);
970:
971: return;
972: }
973:
974: (*((real8 *) (*s_objet_resultat).objet)) =
975: gsl_sf_bessel_jl((int) ((*((integer8 *)
976: (*s_objet_argument_2).objet))),
977: (double) ((*((integer8 *)
978: (*s_objet_argument_1).objet))));
979: break;
980: }
981:
982: case 'y' :
983: {
984: if (((*((integer8 *) (*s_objet_argument_1).objet))
985: <= 0) || ((*((integer8 *)
986: (*s_objet_argument_2).objet)) < 0))
987: {
988: (*s_etat_processus).exception =
989: d_ep_resultat_indefini;
990:
991: liberation(s_etat_processus,
992: s_objet_argument_1);
993: liberation(s_etat_processus,
994: s_objet_argument_2);
995: liberation(s_etat_processus,
996: s_objet_argument_3);
997: liberation(s_etat_processus,
998: s_objet_resultat);
999:
1000: return;
1001: }
1002:
1003: (*((real8 *) (*s_objet_resultat).objet)) =
1004: gsl_sf_bessel_yl((int) ((*((integer8 *)
1005: (*s_objet_argument_2).objet))),
1006: (double) ((*((integer8 *)
1007: (*s_objet_argument_1).objet))));
1008: break;
1009: }
1010:
1011: case 'i' :
1012: {
1013: if ((*((integer8 *) (*s_objet_argument_2).objet))
1014: < 0)
1015: {
1016: (*s_etat_processus).exception =
1017: d_ep_resultat_indefini;
1018:
1019: liberation(s_etat_processus,
1020: s_objet_argument_1);
1021: liberation(s_etat_processus,
1022: s_objet_argument_2);
1023: liberation(s_etat_processus,
1024: s_objet_argument_3);
1025: liberation(s_etat_processus,
1026: s_objet_resultat);
1027:
1028: return;
1029: }
1030:
1031: (*((real8 *) (*s_objet_resultat).objet)) =
1032: exp(fabs((double) (*((integer8 *)
1033: (*s_objet_argument_1).objet)))) *
1034: gsl_sf_bessel_il_scaled(
1035: (int) ((*((integer8 *)
1036: (*s_objet_argument_2).objet))),
1037: (double) ((*((integer8 *)
1038: (*s_objet_argument_1).objet))));
1039: break;
1040: }
1041:
1042: case 'k' :
1043: {
1044: if (((*((integer8 *) (*s_objet_argument_1).objet))
1045: <= 0) || ((*((integer8 *)
1046: (*s_objet_argument_2).objet)) < 0))
1047: {
1048: (*s_etat_processus).exception =
1049: d_ep_resultat_indefini;
1050:
1051: liberation(s_etat_processus,
1052: s_objet_argument_1);
1053: liberation(s_etat_processus,
1054: s_objet_argument_2);
1055: liberation(s_etat_processus,
1056: s_objet_argument_3);
1057: liberation(s_etat_processus,
1058: s_objet_resultat);
1059:
1060: return;
1061: }
1062:
1063: (*((real8 *) (*s_objet_resultat).objet)) =
1064: exp(fabs((double) (*((integer8 *)
1065: (*s_objet_argument_1).objet)))) *
1066: gsl_sf_bessel_kl_scaled(
1067: (int) ((*((integer8 *)
1068: (*s_objet_argument_2).objet))),
1069: (double) ((*((integer8 *)
1070: (*s_objet_argument_1).objet))));
1071: break;
1072: }
1073: }
1074: }
1075: else if ((*s_objet_argument_1).type == REL)
1076: {
1077: if ((s_objet_resultat = allocation(s_etat_processus, REL))
1078: == NULL)
1079: {
1080: (*s_etat_processus).erreur_systeme =
1081: d_es_allocation_memoire;
1082: return;
1083: }
1084:
1085: switch((*((unsigned char *) (*s_objet_argument_3).objet)))
1086: {
1087: case 'J' :
1088: {
1089: (*((real8 *) (*s_objet_resultat).objet)) =
1090: gsl_sf_bessel_Jn((int) ((*((integer8 *)
1091: (*s_objet_argument_2).objet))),
1092: (double) ((*((real8 *)
1093: (*s_objet_argument_1).objet))));
1094: break;
1095: }
1096:
1097: case 'Y' :
1098: {
1099: if ((*((real8 *) (*s_objet_argument_1).objet))
1100: <= 0)
1101: {
1102: (*s_etat_processus).exception =
1103: d_ep_resultat_indefini;
1104:
1105: liberation(s_etat_processus,
1106: s_objet_argument_1);
1107: liberation(s_etat_processus,
1108: s_objet_argument_2);
1109: liberation(s_etat_processus,
1110: s_objet_argument_3);
1111: liberation(s_etat_processus,
1112: s_objet_resultat);
1113:
1114: return;
1115: }
1116:
1117: (*((real8 *) (*s_objet_resultat).objet)) =
1118: gsl_sf_bessel_Yn((int) ((*((integer8 *)
1119: (*s_objet_argument_2).objet))),
1120: (double) ((*((real8 *)
1121: (*s_objet_argument_1).objet))));
1122: break;
1123: }
1124:
1125: case 'I' :
1126: {
1127: (*((real8 *) (*s_objet_resultat).objet)) =
1128: gsl_sf_bessel_In((int) ((*((integer8 *)
1129: (*s_objet_argument_2).objet))),
1130: (double) ((*((real8 *)
1131: (*s_objet_argument_1).objet))));
1132: break;
1133: }
1134:
1135: case 'K' :
1136: {
1137: if ((*((real8 *) (*s_objet_argument_1).objet))
1138: <= 0)
1139: {
1140: (*s_etat_processus).exception =
1141: d_ep_resultat_indefini;
1142:
1143: liberation(s_etat_processus,
1144: s_objet_argument_1);
1145: liberation(s_etat_processus,
1146: s_objet_argument_2);
1147: liberation(s_etat_processus,
1148: s_objet_argument_3);
1149: liberation(s_etat_processus,
1150: s_objet_resultat);
1151:
1152: return;
1153: }
1154:
1155: (*((real8 *) (*s_objet_resultat).objet)) =
1156: gsl_sf_bessel_Kn((int) ((*((integer8 *)
1157: (*s_objet_argument_2).objet))),
1158: (double) ((*((real8 *)
1159: (*s_objet_argument_1).objet))));
1160: break;
1161: }
1162:
1163: case 'j' :
1164: {
1165: if (((*((integer8 *) (*s_objet_argument_1).objet))
1166: < 0) || ((*((integer8 *)
1167: (*s_objet_argument_2).objet)) < 0))
1168: {
1169: (*s_etat_processus).exception =
1170: d_ep_resultat_indefini;
1171:
1172: liberation(s_etat_processus,
1173: s_objet_argument_1);
1174: liberation(s_etat_processus,
1175: s_objet_argument_2);
1176: liberation(s_etat_processus,
1177: s_objet_argument_3);
1178: liberation(s_etat_processus,
1179: s_objet_resultat);
1180:
1181: return;
1182: }
1183:
1184: (*((real8 *) (*s_objet_resultat).objet)) =
1185: gsl_sf_bessel_jl((int) ((*((integer8 *)
1186: (*s_objet_argument_2).objet))),
1187: (double) ((*((real8 *)
1188: (*s_objet_argument_1).objet))));
1189: break;
1190: }
1191:
1192: case 'y' :
1193: {
1194: if (((*((integer8 *) (*s_objet_argument_1).objet))
1195: <= 0) || ((*((integer8 *)
1196: (*s_objet_argument_2).objet)) < 0))
1197: {
1198: (*s_etat_processus).exception =
1199: d_ep_resultat_indefini;
1200:
1201: liberation(s_etat_processus,
1202: s_objet_argument_1);
1203: liberation(s_etat_processus,
1204: s_objet_argument_2);
1205: liberation(s_etat_processus,
1206: s_objet_argument_3);
1207: liberation(s_etat_processus,
1208: s_objet_resultat);
1209:
1210: return;
1211: }
1212:
1213: (*((real8 *) (*s_objet_resultat).objet)) =
1214: gsl_sf_bessel_yl((int) ((*((integer8 *)
1215: (*s_objet_argument_2).objet))),
1216: (double) ((*((real8 *)
1217: (*s_objet_argument_1).objet))));
1218: break;
1219: }
1220:
1221: case 'i' :
1222: {
1223: if ((*((integer8 *) (*s_objet_argument_2).objet))
1224: < 0)
1225: {
1226: (*s_etat_processus).exception =
1227: d_ep_resultat_indefini;
1228:
1229: liberation(s_etat_processus,
1230: s_objet_argument_1);
1231: liberation(s_etat_processus,
1232: s_objet_argument_2);
1233: liberation(s_etat_processus,
1234: s_objet_argument_3);
1235: liberation(s_etat_processus,
1236: s_objet_resultat);
1237:
1238: return;
1239: }
1240:
1241: (*((real8 *) (*s_objet_resultat).objet)) =
1242: exp(fabs((double) (*((real8 *)
1243: (*s_objet_argument_1).objet)))) *
1244: gsl_sf_bessel_il_scaled(
1245: (int) ((*((integer8 *)
1246: (*s_objet_argument_2).objet))),
1247: (double) ((*((real8 *)
1248: (*s_objet_argument_1).objet))));
1249: break;
1250: }
1251:
1252: case 'k' :
1253: {
1254: if (((*((integer8 *) (*s_objet_argument_1).objet))
1255: <= 0) || ((*((integer8 *)
1256: (*s_objet_argument_2).objet)) < 0))
1257: {
1258: (*s_etat_processus).exception =
1259: d_ep_resultat_indefini;
1260:
1261: liberation(s_etat_processus,
1262: s_objet_argument_1);
1263: liberation(s_etat_processus,
1264: s_objet_argument_2);
1265: liberation(s_etat_processus,
1266: s_objet_argument_3);
1267: liberation(s_etat_processus,
1268: s_objet_resultat);
1269:
1270: return;
1271: }
1272:
1273: (*((real8 *) (*s_objet_resultat).objet)) =
1274: exp(fabs((double) (*((real8 *)
1275: (*s_objet_argument_1).objet)))) *
1276: gsl_sf_bessel_kl_scaled(
1277: (int) ((*((integer8 *)
1278: (*s_objet_argument_2).objet))),
1279: (double) ((*((real8 *)
1280: (*s_objet_argument_1).objet))));
1281: break;
1282: }
1283: }
1284: }
1285: else if (((*s_objet_argument_1).type == NOM) ||
1286: ((*s_objet_argument_1).type == RPN) ||
1287: ((*s_objet_argument_1).type == ALG))
1288: {
1289: creation_expression = d_vrai;
1290: }
1291: else
1292: {
1293: liberation(s_etat_processus, s_objet_argument_1);
1294: liberation(s_etat_processus, s_objet_argument_2);
1295: liberation(s_etat_processus, s_objet_argument_3);
1296:
1297: (*s_etat_processus).erreur_execution =
1298: d_ex_erreur_type_argument;
1299: return;
1300: }
1301: }
1302: else if ((*s_objet_argument_2).type == REL)
1303: {
1304: if ((*s_objet_argument_1).type == INT)
1305: {
1306: if ((s_objet_resultat = allocation(s_etat_processus, REL))
1307: == NULL)
1308: {
1309: (*s_etat_processus).erreur_systeme =
1310: d_es_allocation_memoire;
1311: return;
1312: }
1313:
1314: switch((*((unsigned char *) (*s_objet_argument_3).objet)))
1315: {
1316: case 'J' :
1317: {
1318: if (((*((integer8 *) (*s_objet_argument_1).objet))
1319: < 0) || ((*((real8 *)
1320: (*s_objet_argument_2).objet)) < 0))
1321: {
1322: (*s_etat_processus).exception =
1323: d_ep_resultat_indefini;
1324:
1325: liberation(s_etat_processus,
1326: s_objet_argument_1);
1327: liberation(s_etat_processus,
1328: s_objet_argument_2);
1329: liberation(s_etat_processus,
1330: s_objet_argument_3);
1331: liberation(s_etat_processus,
1332: s_objet_resultat);
1333:
1334: return;
1335: }
1336:
1337: (*((real8 *) (*s_objet_resultat).objet)) =
1338: gsl_sf_bessel_Jnu((double) ((*((real8 *)
1339: (*s_objet_argument_2).objet))),
1340: (double) ((*((integer8 *)
1341: (*s_objet_argument_1).objet))));
1342:
1343: break;
1344: }
1345:
1346: case 'Y' :
1347: {
1348: if (((*((integer8 *) (*s_objet_argument_1).objet))
1349: <= 0) || ((*((real8 *)
1350: (*s_objet_argument_2).objet)) < 0))
1351: {
1352: (*s_etat_processus).exception =
1353: d_ep_resultat_indefini;
1354:
1355: liberation(s_etat_processus,
1356: s_objet_argument_1);
1357: liberation(s_etat_processus,
1358: s_objet_argument_2);
1359: liberation(s_etat_processus,
1360: s_objet_argument_3);
1361: liberation(s_etat_processus,
1362: s_objet_resultat);
1363:
1364: return;
1365: }
1366:
1367: (*((real8 *) (*s_objet_resultat).objet)) =
1368: gsl_sf_bessel_Ynu((double) ((*((real8 *)
1369: (*s_objet_argument_2).objet))),
1370: (double) ((*((integer8 *)
1371: (*s_objet_argument_1).objet))));
1372: break;
1373: }
1374:
1375: case 'I' :
1376: {
1377: if (((*((integer8 *) (*s_objet_argument_1).objet))
1378: < 0) || ((*((real8 *)
1379: (*s_objet_argument_2).objet)) < 0))
1380: {
1381: (*s_etat_processus).exception =
1382: d_ep_resultat_indefini;
1383:
1384: liberation(s_etat_processus,
1385: s_objet_argument_1);
1386: liberation(s_etat_processus,
1387: s_objet_argument_2);
1388: liberation(s_etat_processus,
1389: s_objet_argument_3);
1390: liberation(s_etat_processus,
1391: s_objet_resultat);
1392:
1393: return;
1394: }
1395:
1396: (*((real8 *) (*s_objet_resultat).objet)) =
1397: gsl_sf_bessel_Inu((double) ((*((real8 *)
1398: (*s_objet_argument_2).objet))),
1399: (double) ((*((integer8 *)
1400: (*s_objet_argument_1).objet))));
1401: break;
1402: }
1403:
1404: case 'K' :
1405: {
1406: if (((*((integer8 *) (*s_objet_argument_1).objet))
1407: <= 0) || ((*((real8 *)
1408: (*s_objet_argument_2).objet)) < 0))
1409: {
1410: (*s_etat_processus).exception =
1411: d_ep_resultat_indefini;
1412:
1413: liberation(s_etat_processus,
1414: s_objet_argument_1);
1415: liberation(s_etat_processus,
1416: s_objet_argument_2);
1417: liberation(s_etat_processus,
1418: s_objet_argument_3);
1419: liberation(s_etat_processus,
1420: s_objet_resultat);
1421:
1422: return;
1423: }
1424:
1425: (*((real8 *) (*s_objet_resultat).objet)) =
1426: gsl_sf_bessel_Knu((double) ((*((real8 *)
1427: (*s_objet_argument_2).objet))),
1428: (double) ((*((integer8 *)
1429: (*s_objet_argument_1).objet))));
1430: break;
1431: }
1432:
1433: default :
1434: {
1435: (*s_etat_processus).exception =
1436: d_ep_resultat_indefini;
1437:
1438: liberation(s_etat_processus, s_objet_argument_1);
1439: liberation(s_etat_processus, s_objet_argument_2);
1440: liberation(s_etat_processus, s_objet_argument_3);
1441: liberation(s_etat_processus, s_objet_resultat);
1442:
1443: return;
1444: break;
1445: }
1446: }
1447: }
1448: else if ((*s_objet_argument_1).type == REL)
1449: {
1450: if ((s_objet_resultat = allocation(s_etat_processus, REL))
1451: == NULL)
1452: {
1453: (*s_etat_processus).erreur_systeme =
1454: d_es_allocation_memoire;
1455: return;
1456: }
1457:
1458: switch((*((unsigned char *) (*s_objet_argument_3).objet)))
1459: {
1460: case 'J' :
1461: {
1462: if (((*((real8 *) (*s_objet_argument_1).objet))
1463: < 0) || ((*((real8 *)
1464: (*s_objet_argument_2).objet)) < 0))
1465: {
1466: (*s_etat_processus).exception =
1467: d_ep_resultat_indefini;
1468:
1469: liberation(s_etat_processus,
1470: s_objet_argument_1);
1471: liberation(s_etat_processus,
1472: s_objet_argument_2);
1473: liberation(s_etat_processus,
1474: s_objet_argument_3);
1475: liberation(s_etat_processus,
1476: s_objet_resultat);
1477:
1478: return;
1479: }
1480:
1481: (*((real8 *) (*s_objet_resultat).objet)) =
1482: gsl_sf_bessel_Jnu((double) ((*((real8 *)
1483: (*s_objet_argument_2).objet))),
1484: (double) ((*((real8 *)
1485: (*s_objet_argument_1).objet))));
1486: break;
1487: }
1488:
1489: case 'Y' :
1490: {
1491: if (((*((real8 *) (*s_objet_argument_1).objet))
1492: <= 0) || ((*((real8 *)
1493: (*s_objet_argument_2).objet)) < 0))
1494: {
1495: (*s_etat_processus).exception =
1496: d_ep_resultat_indefini;
1497:
1498: liberation(s_etat_processus,
1499: s_objet_argument_1);
1500: liberation(s_etat_processus,
1501: s_objet_argument_2);
1502: liberation(s_etat_processus,
1503: s_objet_argument_3);
1504: liberation(s_etat_processus,
1505: s_objet_resultat);
1506:
1507: return;
1508: }
1509:
1510: (*((real8 *) (*s_objet_resultat).objet)) =
1.45 ! bertrand 1511: gsl_sf_bessel_Yn((int) ((*((real8 *)
1.1 bertrand 1512: (*s_objet_argument_2).objet))),
1513: (double) ((*((real8 *)
1514: (*s_objet_argument_1).objet))));
1515: break;
1516: }
1517:
1518: case 'I' :
1519: {
1520: if (((*((real8 *) (*s_objet_argument_1).objet))
1521: < 0) || ((*((real8 *)
1522: (*s_objet_argument_2).objet)) < 0))
1523: {
1524: (*s_etat_processus).exception =
1525: d_ep_resultat_indefini;
1526:
1527: liberation(s_etat_processus,
1528: s_objet_argument_1);
1529: liberation(s_etat_processus,
1530: s_objet_argument_2);
1531: liberation(s_etat_processus,
1532: s_objet_argument_3);
1533: liberation(s_etat_processus,
1534: s_objet_resultat);
1535:
1536: return;
1537: }
1538:
1539: (*((real8 *) (*s_objet_resultat).objet)) =
1.45 ! bertrand 1540: gsl_sf_bessel_In((int) ((*((real8 *)
1.1 bertrand 1541: (*s_objet_argument_2).objet))),
1542: (double) ((*((real8 *)
1543: (*s_objet_argument_1).objet))));
1544: break;
1545: }
1546:
1547: case 'K' :
1548: {
1549: if (((*((real8 *) (*s_objet_argument_1).objet))
1550: <= 0) || ((*((real8 *)
1551: (*s_objet_argument_2).objet)) < 0))
1552: {
1553: (*s_etat_processus).exception =
1554: d_ep_resultat_indefini;
1555:
1556: liberation(s_etat_processus,
1557: s_objet_argument_1);
1558: liberation(s_etat_processus,
1559: s_objet_argument_2);
1560: liberation(s_etat_processus,
1561: s_objet_argument_3);
1562: liberation(s_etat_processus,
1563: s_objet_resultat);
1564:
1565: return;
1566: }
1567:
1568: (*((real8 *) (*s_objet_resultat).objet)) =
1.45 ! bertrand 1569: gsl_sf_bessel_Kn((int) ((*((real8 *)
1.1 bertrand 1570: (*s_objet_argument_2).objet))),
1571: (double) ((*((real8 *)
1572: (*s_objet_argument_1).objet))));
1573: break;
1574: }
1575:
1576: default :
1577: {
1578: (*s_etat_processus).exception =
1579: d_ep_resultat_indefini;
1580:
1581: liberation(s_etat_processus, s_objet_argument_1);
1582: liberation(s_etat_processus, s_objet_argument_2);
1583: liberation(s_etat_processus, s_objet_argument_3);
1584: liberation(s_etat_processus, s_objet_resultat);
1585:
1586: return;
1587: break;
1588: }
1589: }
1590: }
1591: else
1592: {
1593: liberation(s_etat_processus, s_objet_argument_1);
1594: liberation(s_etat_processus, s_objet_argument_2);
1595: liberation(s_etat_processus, s_objet_argument_3);
1596:
1597: (*s_etat_processus).erreur_execution =
1598: d_ex_erreur_type_argument;
1599: return;
1600: }
1601: }
1602: else if (((*s_objet_argument_2).type == NOM) ||
1603: ((*s_objet_argument_2).type == RPN) ||
1604: ((*s_objet_argument_2).type == ALG))
1605: {
1606: creation_expression = d_vrai;
1607: }
1608: else
1609: {
1610: liberation(s_etat_processus, s_objet_argument_1);
1611: liberation(s_etat_processus, s_objet_argument_2);
1612: liberation(s_etat_processus, s_objet_argument_3);
1613:
1614: (*s_etat_processus).erreur_execution =
1615: d_ex_erreur_type_argument;
1616: return;
1617: }
1618: }
1619: else
1620: {
1621: liberation(s_etat_processus, s_objet_argument_1);
1622: liberation(s_etat_processus, s_objet_argument_2);
1623: liberation(s_etat_processus, s_objet_argument_3);
1624:
1625: (*s_etat_processus).erreur_execution = d_ex_argument_invalide;
1626: return;
1627: }
1628: }
1629: else if (((*s_objet_argument_3).type == NOM) ||
1630: ((*s_objet_argument_3).type == RPN) ||
1631: ((*s_objet_argument_3).type == ALG))
1632: {
1633: creation_expression = d_vrai;
1634: }
1635: else
1636: {
1637: liberation(s_etat_processus, s_objet_argument_1);
1638: liberation(s_etat_processus, s_objet_argument_2);
1639: liberation(s_etat_processus, s_objet_argument_3);
1640:
1641: (*s_etat_processus).erreur_execution = d_ex_erreur_type_argument;
1642: return;
1643: }
1644:
1645: if (creation_expression == d_vrai)
1646: {
1647: if ((s_copie_argument_1 = copie_objet(s_etat_processus,
1648: s_objet_argument_1, 'N')) == NULL)
1649: {
1650: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
1651: return;
1652: }
1653:
1654: if ((s_copie_argument_2 = copie_objet(s_etat_processus,
1655: s_objet_argument_2, 'N')) == NULL)
1656: {
1657: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
1658: return;
1659: }
1660:
1661: if ((s_copie_argument_3 = copie_objet(s_etat_processus,
1662: s_objet_argument_3, 'N')) == NULL)
1663: {
1664: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
1665: return;
1666: }
1667:
1668: if (((*s_copie_argument_1).type == RPN) ||
1669: ((*s_copie_argument_2).type == RPN) ||
1670: ((*s_copie_argument_3).type == RPN))
1671: {
1672: if ((s_objet_resultat = allocation(s_etat_processus, RPN))
1673: == NULL)
1674: {
1675: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
1676: return;
1677: }
1678: }
1679: else
1680: {
1681: if ((s_objet_resultat = allocation(s_etat_processus, ALG))
1682: == NULL)
1683: {
1684: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
1685: return;
1686: }
1687: }
1688:
1689: if (((*s_objet_resultat).objet =
1690: allocation_maillon(s_etat_processus)) == NULL)
1691: {
1692: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
1693: return;
1694: }
1695:
1696: l_element_courant = (*s_objet_resultat).objet;
1697:
1698: if (((*l_element_courant).donnee = allocation(s_etat_processus, FCT))
1699: == NULL)
1700: {
1701: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
1702: return;
1703: }
1704:
1705: (*((struct_fonction *) (*(*l_element_courant).donnee).objet))
1706: .nombre_arguments = 0;
1707: (*((struct_fonction *) (*(*l_element_courant).donnee).objet))
1708: .fonction = instruction_vers_niveau_superieur;
1709:
1710: if (((*((struct_fonction *) (*(*l_element_courant).donnee).objet))
1711: .nom_fonction = malloc(3 * sizeof(unsigned char))) == NULL)
1712: {
1713: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
1714: return;
1715: }
1716:
1717: strcpy((*((struct_fonction *) (*(*l_element_courant).donnee).objet))
1718: .nom_fonction, "<<");
1719:
1720: if (((*s_copie_argument_3).type == ALG) ||
1721: ((*s_copie_argument_3).type == RPN))
1722: {
1723:
1724: l_element_atome = (struct_liste_chainee *)
1725: (*s_copie_argument_3).objet;
1726:
1727: i = 0;
1728:
1729: while(l_element_atome != NULL)
1730: {
1731: i++;
1732: l_element_atome = (*l_element_atome).suivant;
1733: }
1734:
1735: if (i < 3)
1736: {
1737: if (((*l_element_courant).suivant =
1738: allocation_maillon(s_etat_processus)) == NULL)
1739: {
1740: (*s_etat_processus).erreur_systeme =
1741: d_es_allocation_memoire;
1742: return;
1743: }
1744:
1745: l_element_courant = (*l_element_courant).suivant;
1746: (*l_element_courant).donnee = s_copie_argument_3;
1747: }
1748: else
1749: {
1750: (*l_element_courant).suivant = (*((struct_liste_chainee *)
1751: (*s_copie_argument_3).objet)).suivant;
1752:
1753: l_element_precedent = NULL;
1754: l_element_courant = (*l_element_courant).suivant;
1755:
1756: liberation(s_etat_processus,
1757: (*((struct_liste_chainee *) (*s_copie_argument_3)
1758: .objet)).donnee);
1759: free((*s_copie_argument_3).objet);
1760: free(s_copie_argument_3);
1761:
1762: while((*l_element_courant).suivant != NULL)
1763: {
1764: l_element_precedent = l_element_courant;
1765: l_element_courant = (*l_element_courant).suivant;
1766: }
1767:
1768: liberation(s_etat_processus, (*l_element_courant).donnee);
1769: free(l_element_courant);
1770:
1771: l_element_courant = l_element_precedent;
1772: }
1773: }
1774: else
1775: {
1776: if (((*l_element_courant).suivant =
1777: allocation_maillon(s_etat_processus)) == NULL)
1778: {
1779: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
1780: return;
1781: }
1782:
1783: l_element_courant = (*l_element_courant).suivant;
1784: (*l_element_courant).donnee = s_copie_argument_3;
1785: }
1786:
1787: if (((*s_copie_argument_2).type == ALG) ||
1788: ((*s_copie_argument_2).type == RPN))
1789: {
1790: l_element_atome = (struct_liste_chainee *)
1791: (*s_copie_argument_2).objet;
1792:
1793: i = 0;
1794:
1795: while(l_element_atome != NULL)
1796: {
1797: i++;
1798: l_element_atome = (*l_element_atome).suivant;
1799: }
1800:
1801: if (i < 3)
1802: {
1803: if (((*l_element_courant).suivant =
1804: allocation_maillon(s_etat_processus)) == NULL)
1805: {
1806: (*s_etat_processus).erreur_systeme =
1807: d_es_allocation_memoire;
1808: return;
1809: }
1810:
1811: l_element_courant = (*l_element_courant).suivant;
1812: (*l_element_courant).donnee = s_copie_argument_2;
1813: }
1814: else
1815: {
1816: (*l_element_courant).suivant = (*((struct_liste_chainee *)
1817: (*s_copie_argument_2).objet)).suivant;
1818:
1819: l_element_courant = (*l_element_courant).suivant;
1820: l_element_precedent = NULL;
1821:
1822: liberation(s_etat_processus,
1823: (*((struct_liste_chainee *) (*s_copie_argument_2)
1824: .objet)).donnee);
1825: free((*s_copie_argument_2).objet);
1826: free(s_copie_argument_2);
1827:
1828: while((*l_element_courant).suivant != NULL)
1829: {
1830: l_element_precedent = l_element_courant;
1831: l_element_courant = (*l_element_courant).suivant;
1832: }
1833:
1834: liberation(s_etat_processus, (*l_element_courant).donnee);
1835: free(l_element_courant);
1836:
1837: l_element_courant = l_element_precedent;
1838: }
1839: }
1840: else
1841: {
1842: if (((*l_element_courant).suivant =
1843: allocation_maillon(s_etat_processus)) == NULL)
1844: {
1845: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
1846: return;
1847: }
1848:
1849: l_element_courant = (*l_element_courant).suivant;
1850: (*l_element_courant).donnee = s_copie_argument_2;
1851: }
1852:
1853: if (((*s_copie_argument_1).type == ALG) ||
1854: ((*s_copie_argument_1).type == RPN))
1855: {
1856: l_element_atome = (struct_liste_chainee *)
1857: (*s_copie_argument_1).objet;
1858:
1859: i = 0;
1860:
1861: while(l_element_atome != NULL)
1862: {
1863: i++;
1864: l_element_atome = (*l_element_atome).suivant;
1865: }
1866:
1867: if (i < 3)
1868: {
1869: if (((*l_element_courant).suivant =
1870: allocation_maillon(s_etat_processus)) == NULL)
1871: {
1872: (*s_etat_processus).erreur_systeme =
1873: d_es_allocation_memoire;
1874: return;
1875: }
1876:
1877: l_element_courant = (*l_element_courant).suivant;
1878: (*l_element_courant).donnee = s_copie_argument_1;
1879: }
1880: else
1881: {
1882: (*l_element_courant).suivant = (*((struct_liste_chainee *)
1883: (*s_copie_argument_1).objet)).suivant;
1884:
1885: l_element_courant = (*l_element_courant).suivant;
1886: l_element_precedent = NULL;
1887:
1888: liberation(s_etat_processus,
1889: (*((struct_liste_chainee *) (*s_copie_argument_1)
1890: .objet)).donnee);
1891: free((*s_copie_argument_1).objet);
1892: free(s_copie_argument_1);
1893:
1894: while((*l_element_courant).suivant != NULL)
1895: {
1896: l_element_precedent = l_element_courant;
1897: l_element_courant = (*l_element_courant).suivant;
1898: }
1899:
1900: liberation(s_etat_processus, (*l_element_courant).donnee);
1901: free(l_element_courant);
1902:
1903: l_element_courant = l_element_precedent;
1904: }
1905: }
1906: else
1907: {
1908: if (((*l_element_courant).suivant =
1909: allocation_maillon(s_etat_processus)) == NULL)
1910: {
1911: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
1912: return;
1913: }
1914:
1915: l_element_courant = (*l_element_courant).suivant;
1916: (*l_element_courant).donnee = s_copie_argument_1;
1917: }
1918:
1919: if (((*l_element_courant).suivant =
1920: allocation_maillon(s_etat_processus)) == NULL)
1921: {
1922: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
1923: return;
1924: }
1925:
1926: l_element_courant = (*l_element_courant).suivant;
1927:
1928: if (((*l_element_courant).donnee =
1929: allocation(s_etat_processus, FCT)) == NULL)
1930: {
1931: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
1932: return;
1933: }
1934:
1935: (*((struct_fonction *) (*(*l_element_courant).donnee).objet))
1936: .nombre_arguments = 3;
1937: (*((struct_fonction *) (*(*l_element_courant).donnee).objet))
1938: .fonction = instruction_bessel;
1939:
1940: if (((*((struct_fonction *) (*(*l_element_courant).donnee).objet))
1941: .nom_fonction = malloc(7 * sizeof(unsigned char))) == NULL)
1942: {
1943: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
1944: return;
1945: }
1946:
1947: strcpy((*((struct_fonction *) (*(*l_element_courant).donnee).objet))
1948: .nom_fonction, "BESSEL");
1949:
1950: if (((*l_element_courant).suivant =
1951: allocation_maillon(s_etat_processus)) == NULL)
1952: {
1953: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
1954: return;
1955: }
1956:
1957: l_element_courant = (*l_element_courant).suivant;
1958:
1959: if (((*l_element_courant).donnee = (struct_objet *)
1960: allocation(s_etat_processus, FCT)) == NULL)
1961: {
1962: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
1963: return;
1964: }
1965:
1966: (*((struct_fonction *) (*(*l_element_courant).donnee).objet))
1967: .nombre_arguments = 0;
1968: (*((struct_fonction *) (*(*l_element_courant).donnee).objet))
1969: .fonction = instruction_vers_niveau_inferieur;
1970:
1971: if (((*((struct_fonction *) (*(*l_element_courant).donnee).objet))
1972: .nom_fonction = malloc(3 * sizeof(unsigned char))) == NULL)
1973: {
1974: (*s_etat_processus).erreur_systeme = d_es_allocation_memoire;
1975: return;
1976: }
1977:
1978: strcpy((*((struct_fonction *) (*(*l_element_courant).donnee).objet))
1979: .nom_fonction, ">>");
1980:
1981: (*l_element_courant).suivant = NULL;
1982: }
1983:
1984: if (empilement(s_etat_processus, &((*s_etat_processus).l_base_pile),
1985: s_objet_resultat) == d_erreur)
1986: {
1987: return;
1988: }
1989:
1990: liberation(s_etat_processus, s_objet_argument_1);
1991: liberation(s_etat_processus, s_objet_argument_2);
1992: liberation(s_etat_processus, s_objet_argument_3);
1993:
1994: return;
1995: }
1996:
1.11 bertrand 1997:
1998: /*
1999: ================================================================================
2000: Fonction 'backtrace'
2001: ================================================================================
2002: Entrées :
2003: --------------------------------------------------------------------------------
2004: Sorties :
2005: --------------------------------------------------------------------------------
2006: Effets de bord : néant
2007: ================================================================================
2008: */
2009:
2010: void
2011: instruction_backtrace(struct_processus *s_etat_processus)
2012: {
2013: (*s_etat_processus).erreur_execution = d_ex;
2014:
2015: if ((*s_etat_processus).affichage_arguments == 'Y')
2016: {
2017: printf("\n BACKTRACE ");
2018:
2019: if ((*s_etat_processus).langue == 'F')
2020: {
2021: printf("(affichage de la pile système)\n\n");
2022: printf(" Aucun argument\n");
2023: }
2024: else
2025: {
2026: printf("(print system stack)\n\n");
2027: printf(" No argument\n");
2028: }
2029:
2030: return;
2031: }
2032: else if ((*s_etat_processus).test_instruction == 'Y')
2033: {
2034: (*s_etat_processus).nombre_arguments = -1;
2035: return;
2036: }
2037:
2038: if (test_cfsf(s_etat_processus, 31) == d_vrai)
2039: {
2040: if (empilement_pile_last(s_etat_processus, 0) == d_erreur)
2041: {
2042: return;
2043: }
2044: }
2045:
2046: trace(s_etat_processus, stdout);
2047:
2048: return;
2049: }
2050:
1.1 bertrand 2051: // vim: ts=4