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