Annotation of rpl/src/interface_cas.cpp, revision 1.16
1.1 bertrand 1: /*
2: ================================================================================
1.15 bertrand 3: RPL/2 (R) version 4.1.3
1.1 bertrand 4: Copyright (C) 1989-2011 Dr. BERTRAND Joël
5:
6: This file is part of RPL/2.
7:
8: RPL/2 is free software; you can redistribute it and/or modify it
9: under the terms of the CeCILL V2 License as published by the french
10: CEA, CNRS and INRIA.
11:
12: RPL/2 is distributed in the hope that it will be useful, but WITHOUT
13: ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
14: FITNESS FOR A PARTICULAR PURPOSE. See the CeCILL V2 License
15: for more details.
16:
17: You should have received a copy of the CeCILL License
18: along with RPL/2. If not, write to info@cecill.info.
19: ================================================================================
20: */
21:
1.2 bertrand 22:
1.9 bertrand 23: #ifdef RPLCAS
24: # include "giac.h"
1.2 bertrand 25:
1.9 bertrand 26: # undef PACKAGE
27: # undef PACKAGE_NAME
28: # undef PACKAGE_STRING
29: # undef PACKAGE_TARNAME
30: # undef PACKAGE_VERSION
31: # undef VERSION
32: #endif
1.3 bertrand 33:
1.1 bertrand 34: extern "C"
35: {
1.3 bertrand 36: # define __RPLCAS
1.1 bertrand 37: # include "rpl-conv.h"
38: }
39:
40: #include <iostream>
41:
42: using namespace std;
1.9 bertrand 43:
44: #ifdef RPLCAS
45: using namespace giac;
46: #endif
1.2 bertrand 47:
1.14 bertrand 48: void
49: initialisation_contexte_cas(struct_processus *s_etat_processus)
50: {
51: s_etat_processus->contexte_cas = NULL;
52: return;
53: }
54:
55: void
56: liberation_contexte_cas(struct_processus *s_etat_processus)
57: {
1.15 bertrand 58: if (s_etat_processus->contexte_cas != NULL)
59: {
1.16 ! bertrand 60: # ifdef RPLCAS
1.15 bertrand 61: delete reinterpret_cast<giac::context *>(
62: s_etat_processus->contexte_cas);
1.16 ! bertrand 63: # endif
1.15 bertrand 64: s_etat_processus->contexte_cas = NULL;
65: }
1.14 bertrand 66:
67: return;
68: }
1.1 bertrand 69:
1.4 bertrand 70: static unsigned char *
71: conversion_rpl_vers_cas(struct_processus *s_etat_processus,
72: struct_objet **s_objet)
73: {
1.12 bertrand 74: logical1 drapeau;
75:
1.4 bertrand 76: struct_liste_chainee *l_element_courant;
1.12 bertrand 77: struct_liste_chainee *l_element_precedent;
1.4 bertrand 78:
79: struct_objet *s_objet_temporaire;
80:
81: t_8_bits registre[8];
82:
83: unsigned char *resultat;
1.12 bertrand 84: unsigned char *index;
1.4 bertrand 85:
86: for(int i = 0; i < 8; i++)
87: {
88: registre[i] = s_etat_processus->drapeaux_etat[i];
89: }
90:
1.12 bertrand 91: sf(s_etat_processus, 35);
1.4 bertrand 92: cf(s_etat_processus, 48);
93: cf(s_etat_processus, 49);
94: cf(s_etat_processus, 50);
95: cf(s_etat_processus, 53);
96: cf(s_etat_processus, 54);
97: cf(s_etat_processus, 55);
98: cf(s_etat_processus, 56);
99:
100: // GIAC considère que les fonctions sont écrites en minuscules. Le RPL/2
101: // part de l'hypothèse inverse. Il faut donc convertir en minuscules tous
102: // les noms de fonction. Les fonctions ne peuvent apparaître que dans le
103: // cas d'un objet de type ALG.
104:
1.12 bertrand 105: if ((*s_objet)->type == NOM)
106: {
107: if (strcmp((const char *) reinterpret_cast<unsigned char *>(
108: reinterpret_cast<struct_nom *>((*s_objet)->objet)->nom),
109: "infinity") == 0)
110: {
111: if (evaluation(s_etat_processus, *s_objet, 'N') == d_erreur)
112: {
113: return(NULL);
114: }
115:
116: liberation(s_etat_processus, *s_objet);
117:
118: if (depilement(s_etat_processus, &(s_etat_processus
119: ->l_base_pile), s_objet) == d_erreur)
120: {
121: return(NULL);
122: }
123: }
124: }
125: else if ((*s_objet)->type == ALG)
1.4 bertrand 126: {
1.12 bertrand 127: if ((s_objet_temporaire = copie_objet(s_etat_processus,
128: (*s_objet), 'O')) == NULL)
129: {
130: s_etat_processus->erreur_systeme = d_es_allocation_memoire;
131: return(NULL);
132: }
133:
134: liberation(s_etat_processus, (*s_objet));
135: (*s_objet) = s_objet_temporaire;
136:
137: // Si l'expression contient la fonction infinity, on commence par
138: // forcer une évaluation numérique.
139:
140: l_element_courant = reinterpret_cast<struct_liste_chainee *>(
141: (*s_objet)->objet);
142: drapeau = d_faux;
143:
144: while(l_element_courant != NULL)
145: {
146: if (l_element_courant->donnee->type == NOM)
147: {
148: if (strcmp((const char *) reinterpret_cast<unsigned char *>(
149: reinterpret_cast<struct_nom *>(
150: l_element_courant->donnee->objet)->nom),
151: "infinity") == 0)
152: {
153: drapeau = d_vrai;
154: break;
155: }
156: }
157:
158: l_element_courant = l_element_courant->suivant;
159: }
160:
161: if (drapeau == d_vrai)
1.4 bertrand 162: {
1.12 bertrand 163: if (evaluation(s_etat_processus, *s_objet, 'N') == d_erreur)
1.4 bertrand 164: {
165: return(NULL);
166: }
167:
1.12 bertrand 168: liberation(s_etat_processus, *s_objet);
169:
170: if (depilement(s_etat_processus, &(s_etat_processus
171: ->l_base_pile), s_objet) == d_erreur)
172: {
173: return(NULL);
174: }
1.4 bertrand 175: }
1.12 bertrand 176: }
177:
178: if ((*s_objet)->type == ALG)
179: {
1.4 bertrand 180:
181: l_element_courant = reinterpret_cast<struct_liste_chainee *>(
182: (*s_objet)->objet);
183:
184: while(l_element_courant != NULL)
185: {
186: if (l_element_courant->donnee->type == FCT)
187: {
188: unsigned char *ptr;
189:
1.6 bertrand 190: ptr = reinterpret_cast<unsigned char *>(
191: reinterpret_cast<struct_fonction *>(
1.4 bertrand 192: l_element_courant->donnee->objet)->nom_fonction);
193:
194: while((*ptr) != d_code_fin_chaine)
195: {
196: int c = (*ptr);
197:
198: if (isalpha(c))
199: {
200: c = tolower(c);
201: (*ptr) = (unsigned char) c;
202: }
203:
204: ptr++;
205: }
206: }
207:
1.12 bertrand 208: l_element_precedent = l_element_courant;
1.4 bertrand 209: l_element_courant = l_element_courant->suivant;
210: }
211: }
212:
213: resultat = formateur(s_etat_processus, 0, (*s_objet));
1.12 bertrand 214:
215: // Il faut remplacer les occurrences de 'relax' par ' +'.
216:
217: index = resultat;
218: while((index = reinterpret_cast<unsigned char *>(
219: strstr(reinterpret_cast<char *>(index),
220: (const char *) "relax"))) != NULL)
221: {
222: strncpy(reinterpret_cast<char *>(index), " +", 5);
223: }
224:
225: // Si le résultat vaut infinity, on rajoute le signe +.
226:
227: if (strcmp(reinterpret_cast<char *>(resultat), "infinity") == 0)
228: {
229: if ((resultat = reinterpret_cast<unsigned char *>(
230: realloc(resultat, (strlen(reinterpret_cast<char *>(
231: resultat)) + 2) * sizeof(unsigned char)))) == NULL)
232: {
233: s_etat_processus->erreur_systeme = d_es_allocation_memoire;
234: return(NULL);
235: }
236:
237: strcpy(reinterpret_cast<char *>(resultat), "+infinity");
238: }
239:
240: if (resultat[0] == '\'')
241: {
242: resultat[0] = ' ';
243: resultat[strlen((const char *) resultat) - 1] = ' ';
244: }
1.4 bertrand 245:
246: for(int i = 0; i < 8; i++)
247: {
248: s_etat_processus->drapeaux_etat[i] = registre[i];
249: }
250:
251: return(resultat);
252: }
253:
254:
255: static void
256: conversion_cas_vers_rpl(struct_processus *s_etat_processus,
1.13 bertrand 257: unsigned char *expression)
1.4 bertrand 258: {
1.13 bertrand 259: logical1 drapeau;
260:
1.4 bertrand 261: struct_liste_chainee *l_element_courant;
262: struct_liste_chainee *l_element_precedent;
263:
1.13 bertrand 264: struct_objet *s_objet;
265:
266: unsigned char *registre;
267:
268: registre = s_etat_processus->instruction_courante;
269: s_etat_processus->instruction_courante = expression;
270: recherche_type(s_etat_processus);
271: s_etat_processus->instruction_courante = registre;
272:
273: if ((s_etat_processus->l_base_pile == NULL) ||
274: (s_etat_processus->erreur_execution != d_ex) ||
275: (s_etat_processus->erreur_systeme != d_es))
276: {
277: return;
278: }
279:
280: // Le niveau 1 de la pile opérationnelle contient l'expression
281: // à convertir.
282:
283: if (depilement(s_etat_processus, &(s_etat_processus
284: ->l_base_pile), &s_objet) == d_erreur)
285: {
286: return;
287: }
288:
1.4 bertrand 289: if ((s_objet->type == ALG) || (s_objet->type == RPN))
290: {
291: // On transcrit les fonctions de GIAC vers le RPL/2.
292:
1.13 bertrand 293: l_element_courant = reinterpret_cast<struct_liste_chainee *>(
294: s_objet->objet);
295: drapeau = d_faux;
296:
297: // S'il y a une valeur infini, on force l'évaluation de l'expression.
298:
299: while(l_element_courant != NULL)
300: {
301: if (l_element_courant->donnee->type == NOM)
302: {
303: if (strcmp((const char *) reinterpret_cast<unsigned char *>(
304: reinterpret_cast<struct_nom *>(
305: l_element_courant->donnee->objet)->nom),
306: "infinity") == 0)
307: {
308: drapeau = d_vrai;
309: break;
310: }
311: }
312:
313: l_element_courant = l_element_courant->suivant;
314: }
315:
316: if (drapeau == d_vrai)
317: {
318: if (evaluation(s_etat_processus, s_objet, 'N') == d_erreur)
319: {
320: return;
321: }
322:
323: liberation(s_etat_processus, s_objet);
324:
325: if (depilement(s_etat_processus, &(s_etat_processus
326: ->l_base_pile), &s_objet) == d_erreur)
327: {
328: return;
329: }
330: }
331: }
332:
333: if ((s_objet->type == ALG) || (s_objet->type == RPN))
334: {
1.4 bertrand 335: l_element_precedent = NULL;
336: l_element_courant = reinterpret_cast<struct_liste_chainee *>(
337: s_objet->objet);
338:
339: while(l_element_courant != NULL)
340: {
341: if (l_element_courant->donnee->type == FCT)
342: {
343: // Nous sommes en présence d'un nom, donc de quelque chose
344: // qui n'est pas reconnu comme un mot-clef du RPL/2. S'il
345: // s'agit d'un mot-clef de GIAC, on le convertit.
346:
1.12 bertrand 347: if ((strcmp((const char *)
348: reinterpret_cast<struct_fonction *>(l_element_courant
349: ->donnee->objet)->nom_fonction, "quote") == 0) ||
350: (strcmp((const char *)
1.6 bertrand 351: reinterpret_cast<struct_fonction *>(l_element_courant
1.12 bertrand 352: ->donnee->objet)->nom_fonction, "nop") == 0))
1.4 bertrand 353: {
354: liberation(s_etat_processus, l_element_courant->donnee);
355:
356: if ((l_element_courant->donnee =
357: allocation(s_etat_processus, FCT)) == NULL)
358: {
359: s_etat_processus->erreur_systeme =
360: d_es_allocation_memoire;
361: return;
362: }
363:
364: if ((((struct_fonction *) l_element_courant->donnee->objet)
365: ->nom_fonction = reinterpret_cast<unsigned char *>(
366: malloc(6 * sizeof(unsigned char))))
367: == NULL)
368: {
369: s_etat_processus->erreur_systeme =
370: d_es_allocation_memoire;
371: return;
372: }
373:
1.6 bertrand 374: strcpy(reinterpret_cast<char *>(
375: reinterpret_cast<struct_fonction *>(
1.4 bertrand 376: l_element_courant->donnee->objet)->nom_fonction),
377: "RELAX");
378: }
379: }
380:
381: l_element_precedent = l_element_courant;
382: l_element_courant = l_element_courant->suivant;
383: }
384: }
385:
1.13 bertrand 386: if (empilement(s_etat_processus, &(s_etat_processus->l_base_pile),
387: s_objet) == d_erreur)
388: {
389: return;
390: }
391:
1.4 bertrand 392: return;
393: }
394:
395:
1.1 bertrand 396: /*
397: ================================================================================
398: Fonction 'interface_cas'
399: ================================================================================
1.4 bertrand 400: Entrées : commande à effectuer.
401: Le contrôle des types est effectué dans la fonction appelant interface_cas().
1.1 bertrand 402: --------------------------------------------------------------------------------
1.4 bertrand 403: Sorties : retour par la pile.
1.1 bertrand 404: --------------------------------------------------------------------------------
405: Effets de bord : néant
406: ================================================================================
407: */
408:
1.3 bertrand 409: void
1.1 bertrand 410: interface_cas(struct_processus *s_etat_processus,
1.3 bertrand 411: enum t_rplcas_commandes commande)
1.1 bertrand 412: {
1.9 bertrand 413: # ifdef RPLCAS
1.4 bertrand 414: struct_objet *s_objet_argument_1;
415: struct_objet *s_objet_argument_2;
1.12 bertrand 416: struct_objet *s_objet_temporaire;
417:
418: struct_liste_chainee *l_element_courant;
1.4 bertrand 419:
1.3 bertrand 420: unsigned char *argument_1;
1.4 bertrand 421: unsigned char *argument_2;
1.12 bertrand 422: unsigned char *argument_3;
423: unsigned char *argument_4;
1.3 bertrand 424:
1.12 bertrand 425: unsigned int position;
426:
1.14 bertrand 427: giac::context *contexte;
428:
429: if (s_etat_processus->contexte_cas == NULL)
430: {
431: try
432: {
433: s_etat_processus->contexte_cas = new giac::context;
434: }
435: catch(bad_alloc exception)
436: {
437: s_etat_processus->erreur_systeme = d_es_allocation_memoire;
438: return;
439: }
440: catch(...)
441: {
442: s_etat_processus->erreur_execution = d_ex_erreur_interne_rplcas;
443: return;
444: }
445: }
446:
447: contexte = reinterpret_cast<giac::context *>(
448: s_etat_processus->contexte_cas);
449:
450: if ((s_etat_processus->erreur_execution != d_ex) ||
451: (s_etat_processus->erreur_systeme != d_es))
452: {
453: return;
454: }
455:
1.3 bertrand 456: switch(commande)
457: {
1.4 bertrand 458: case RPLCAS_INTEGRATION:
459: {
460: if (depilement(s_etat_processus, &(s_etat_processus->l_base_pile),
461: &s_objet_argument_1) == d_erreur)
462: {
1.12 bertrand 463: s_etat_processus->erreur_execution = d_ex_manque_argument;
1.4 bertrand 464: return;
465: }
466:
467: if (depilement(s_etat_processus, &(s_etat_processus->l_base_pile),
468: &s_objet_argument_2) == d_erreur)
469: {
470: liberation(s_etat_processus, s_objet_argument_1);
1.12 bertrand 471: s_etat_processus->erreur_execution = d_ex_manque_argument;
1.4 bertrand 472: return;
473: }
474:
475: if ((argument_1 = conversion_rpl_vers_cas(s_etat_processus,
476: &s_objet_argument_1)) == NULL)
477: {
478: s_etat_processus->erreur_systeme = d_es_allocation_memoire;
479: return;
480: }
481:
482: if ((argument_2 = conversion_rpl_vers_cas(s_etat_processus,
483: &s_objet_argument_2)) == NULL)
484: {
485: s_etat_processus->erreur_systeme = d_es_allocation_memoire;
486: return;
487: }
488:
489: liberation(s_etat_processus, s_objet_argument_1);
490: liberation(s_etat_processus, s_objet_argument_2);
491:
1.7 bertrand 492: try
493: {
494: gen variable(
495: string(reinterpret_cast<const char *>(argument_1)),
1.14 bertrand 496: contexte);
1.7 bertrand 497: gen expression(
498: string(reinterpret_cast<const char *>(argument_2)),
1.14 bertrand 499: contexte);
1.7 bertrand 500:
1.14 bertrand 501: gen resultat = integrate_gen(expression, variable,
502: contexte);
1.7 bertrand 503: string chaine = "'" + resultat.print() + "'";
504:
1.13 bertrand 505: conversion_cas_vers_rpl(s_etat_processus,
506: reinterpret_cast<unsigned char *>(const_cast<char *>(
507: chaine.c_str())));
1.7 bertrand 508: }
509: catch(bad_alloc exception)
510: {
511: s_etat_processus->erreur_systeme = d_es_allocation_memoire;
512: }
513: catch(...)
1.4 bertrand 514: {
1.7 bertrand 515: s_etat_processus->erreur_execution = d_ex_erreur_interne_rplcas;
1.4 bertrand 516: }
517:
1.7 bertrand 518: free(argument_1);
519: free(argument_2);
1.4 bertrand 520:
521: break;
522: }
523:
1.3 bertrand 524: case RPLCAS_LIMITE:
525: {
1.12 bertrand 526: if (depilement(s_etat_processus, &(s_etat_processus->l_base_pile),
527: &s_objet_argument_1) == d_erreur)
528: {
529: s_etat_processus->erreur_execution = d_ex_manque_argument;
530: return;
531: }
532:
533: if (depilement(s_etat_processus, &(s_etat_processus->l_base_pile),
534: &s_objet_argument_2) == d_erreur)
535: {
536: liberation(s_etat_processus, s_objet_argument_1);
537: s_etat_processus->erreur_execution = d_ex_manque_argument;
538: return;
539: }
540:
541: // Fonction
542:
543: if ((argument_2 = conversion_rpl_vers_cas(s_etat_processus,
544: &s_objet_argument_2)) == NULL)
545: {
546: s_etat_processus->erreur_systeme = d_es_allocation_memoire;
547: return;
548: }
549:
550: // On parcourt la liste. Cette liste est tout d'abord copiée
551: // car on est susceptible de modifier le second élément.
552:
553: if ((s_objet_temporaire = copie_objet(s_etat_processus,
554: s_objet_argument_1, 'O')) == NULL)
555: {
556: s_etat_processus->erreur_systeme = d_es_allocation_memoire;
557: return;
558: }
559:
560: liberation(s_etat_processus, s_objet_argument_1);
561: s_objet_argument_1 = s_objet_temporaire;
562:
563: l_element_courant = reinterpret_cast<struct_liste_chainee *>
564: (s_objet_argument_1->objet);
565: position = 1;
566: argument_4 = NULL;
567:
568: while(l_element_courant != NULL)
569: {
570: switch(position)
571: {
572: case 1:
573: {
574: // Variable
575:
576: if ((argument_1 = reinterpret_cast<unsigned char *>
577: (malloc((strlen((const char *)
578: ((struct_variable *) (l_element_courant
579: ->donnee->objet))->nom)
580: + 1) * sizeof(unsigned char)))) == NULL)
581: {
582: s_etat_processus->erreur_systeme =
583: d_es_allocation_memoire;
584: return;
585: }
586:
587: strcpy(reinterpret_cast<char *>(argument_1),
588: (const char *) ((struct_variable *)
589: (l_element_courant->donnee->objet))->nom);
590: break;
591: }
592:
593: case 2:
594: {
595: // Valeur
596: if ((argument_3 = conversion_rpl_vers_cas(
597: s_etat_processus,
598: &(l_element_courant->donnee))) == NULL)
599: {
600: s_etat_processus->erreur_systeme =
601: d_es_allocation_memoire;
602: return;
603: }
604:
605: break;
606: }
607:
608: case 3:
609: {
610: // Direction
611:
612: if ((argument_4 = reinterpret_cast<unsigned char *>
613: (malloc((strlen((const char *)
614: ((struct_fonction *) (l_element_courant
615: ->donnee->objet))->nom_fonction)
616: + 1) * sizeof(unsigned char)))) == NULL)
617: {
618: s_etat_processus->erreur_systeme =
619: d_es_allocation_memoire;
620: return;
621: }
622:
623: strcpy(reinterpret_cast<char *>(argument_4),
624: (const char *) ((struct_fonction *)
625: (l_element_courant->donnee->objet))
626: ->nom_fonction);
627: break;
628: }
629: }
630:
631: l_element_courant = (*l_element_courant).suivant;
632: position++;
633: }
634:
635: liberation(s_etat_processus, s_objet_argument_1);
636: liberation(s_etat_processus, s_objet_argument_2);
637:
638: try
639: {
640: int direction;
641:
642: if (argument_4 == NULL)
643: {
644: direction = 0;
645: }
646: else
647: {
648: direction = (strcmp((const char *) argument_4, "+") == 0)
649: ? 1 : -1;
650: }
651:
652: gen expression(
653: string(reinterpret_cast<const char *>(argument_2)),
1.14 bertrand 654: contexte);
1.12 bertrand 655: identificateur variable(
656: string(reinterpret_cast<const char *>(argument_1)));
657: gen valeur(string(reinterpret_cast<const char *>
1.14 bertrand 658: (argument_3)), contexte);
1.12 bertrand 659:
660: gen resultat = limit(expression, variable, valeur, direction,
1.14 bertrand 661: contexte);
1.12 bertrand 662: string chaine = "'" + resultat.print() + "'";
663:
1.13 bertrand 664: conversion_cas_vers_rpl(s_etat_processus,
665: reinterpret_cast<unsigned char *>(const_cast<char *>(
666: chaine.c_str())));
1.12 bertrand 667: }
668: catch(bad_alloc exception)
669: {
670: s_etat_processus->erreur_systeme = d_es_allocation_memoire;
671: }
672: catch(...)
673: {
674: s_etat_processus->erreur_execution = d_ex_erreur_interne_rplcas;
675: }
676:
677: free(argument_1);
678: free(argument_2);
679: free(argument_3);
680:
681: if (argument_4 != NULL)
682: {
683: free(argument_4);
684: }
685:
1.3 bertrand 686: break;
687: }
688: }
1.1 bertrand 689:
1.3 bertrand 690: return;
1.9 bertrand 691:
692: #else
693:
694: if (s_etat_processus->langue == 'F')
695: {
696: printf("+++Attention : RPL/CAS non compilé !\n");
697: }
698: else
699: {
700: printf("+++Warning : RPL/CAS not available !\n");
701: }
702:
703: fflush(stdout);
704:
705: return;
706:
707: #endif
1.1 bertrand 708: }
709:
710: // vim: ts=4
CVSweb interface <joel.bertrand@systella.fr>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to interface_cas.cpp CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [local] / rpl / src