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