Annotation of rpl/src/interface_cas.cpp, revision 1.10
1.1 bertrand 1: /*
2: ================================================================================
1.9 bertrand 3: RPL/2 (R) version 4.1.1
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: {
53: struct_liste_chainee *l_element_courant;
54:
55: struct_objet *s_objet_temporaire;
56:
57: t_8_bits registre[8];
58:
59: unsigned char *resultat;
60:
61: for(int i = 0; i < 8; i++)
62: {
63: registre[i] = s_etat_processus->drapeaux_etat[i];
64: }
65:
66: cf(s_etat_processus, 48);
67: cf(s_etat_processus, 49);
68: cf(s_etat_processus, 50);
69: cf(s_etat_processus, 53);
70: cf(s_etat_processus, 54);
71: cf(s_etat_processus, 55);
72: cf(s_etat_processus, 56);
73:
74: // GIAC considère que les fonctions sont écrites en minuscules. Le RPL/2
75: // part de l'hypothèse inverse. Il faut donc convertir en minuscules tous
76: // les noms de fonction. Les fonctions ne peuvent apparaître que dans le
77: // cas d'un objet de type ALG.
78:
79: if ((*s_objet)->type == ALG)
80: {
81: if ((*s_objet)->nombre_occurrences > 1)
82: {
83: if ((s_objet_temporaire = copie_objet(s_etat_processus,
84: (*s_objet), 'O')) == NULL)
85: {
86: s_etat_processus->erreur_systeme = d_es_allocation_memoire;
87: return(NULL);
88: }
89:
90: liberation(s_etat_processus, (*s_objet));
91: (*s_objet) = s_objet_temporaire;
92: }
93:
94: l_element_courant = reinterpret_cast<struct_liste_chainee *>(
95: (*s_objet)->objet);
96:
97: while(l_element_courant != NULL)
98: {
99: if (l_element_courant->donnee->type == FCT)
100: {
101: unsigned char *ptr;
102:
1.6 bertrand 103: ptr = reinterpret_cast<unsigned char *>(
104: reinterpret_cast<struct_fonction *>(
1.4 bertrand 105: l_element_courant->donnee->objet)->nom_fonction);
106:
107: while((*ptr) != d_code_fin_chaine)
108: {
109: int c = (*ptr);
110:
111: if (isalpha(c))
112: {
113: c = tolower(c);
114: (*ptr) = (unsigned char) c;
115: }
116:
117: ptr++;
118: }
119: }
120:
121: l_element_courant = l_element_courant->suivant;
122: }
123: }
124:
125: resultat = formateur(s_etat_processus, 0, (*s_objet));
126: resultat[0] = ' ';
127: resultat[strlen((const char *) resultat) - 1] = ' ';
128:
129: for(int i = 0; i < 8; i++)
130: {
131: s_etat_processus->drapeaux_etat[i] = registre[i];
132: }
133:
134: return(resultat);
135: }
136:
137:
138: static void
139: conversion_cas_vers_rpl(struct_processus *s_etat_processus,
140: struct_objet *s_objet)
141: {
142: struct_liste_chainee *l_element_courant;
143: struct_liste_chainee *l_element_precedent;
144:
145: if ((s_objet->type == ALG) || (s_objet->type == RPN))
146: {
147: // On transcrit les fonctions de GIAC vers le RPL/2.
148:
149: l_element_precedent = NULL;
150: l_element_courant = reinterpret_cast<struct_liste_chainee *>(
151: s_objet->objet);
152:
153: while(l_element_courant != NULL)
154: {
155: if (l_element_courant->donnee->type == FCT)
156: {
157: // Nous sommes en présence d'un nom, donc de quelque chose
158: // qui n'est pas reconnu comme un mot-clef du RPL/2. S'il
159: // s'agit d'un mot-clef de GIAC, on le convertit.
160:
1.6 bertrand 161: if (strcmp((const char *)
162: reinterpret_cast<struct_fonction *>(l_element_courant
163: ->donnee->objet)->nom_fonction, "quote") == 0)
1.4 bertrand 164: {
165: liberation(s_etat_processus, l_element_courant->donnee);
166:
167: if ((l_element_courant->donnee =
168: allocation(s_etat_processus, FCT)) == NULL)
169: {
170: s_etat_processus->erreur_systeme =
171: d_es_allocation_memoire;
172: return;
173: }
174:
175: if ((((struct_fonction *) l_element_courant->donnee->objet)
176: ->nom_fonction = reinterpret_cast<unsigned char *>(
177: malloc(6 * sizeof(unsigned char))))
178: == NULL)
179: {
180: s_etat_processus->erreur_systeme =
181: d_es_allocation_memoire;
182: return;
183: }
184:
1.6 bertrand 185: strcpy(reinterpret_cast<char *>(
186: reinterpret_cast<struct_fonction *>(
1.4 bertrand 187: l_element_courant->donnee->objet)->nom_fonction),
188: "RELAX");
189: }
190: }
191:
192: l_element_precedent = l_element_courant;
193: l_element_courant = l_element_courant->suivant;
194: }
195: }
196:
197: return;
198: }
199:
200:
1.1 bertrand 201: /*
202: ================================================================================
203: Fonction 'interface_cas'
204: ================================================================================
1.4 bertrand 205: Entrées : commande à effectuer.
206: Le contrôle des types est effectué dans la fonction appelant interface_cas().
1.1 bertrand 207: --------------------------------------------------------------------------------
1.4 bertrand 208: Sorties : retour par la pile.
1.1 bertrand 209: --------------------------------------------------------------------------------
210: Effets de bord : néant
211: ================================================================================
212: */
213:
1.3 bertrand 214: void
1.1 bertrand 215: interface_cas(struct_processus *s_etat_processus,
1.3 bertrand 216: enum t_rplcas_commandes commande)
1.1 bertrand 217: {
1.9 bertrand 218: # ifdef RPLCAS
1.4 bertrand 219: struct_objet *s_objet_argument_1;
220: struct_objet *s_objet_argument_2;
221:
1.3 bertrand 222: unsigned char *argument_1;
1.4 bertrand 223: unsigned char *argument_2;
224: unsigned char *registre;
1.3 bertrand 225:
226: switch(commande)
227: {
1.4 bertrand 228: case RPLCAS_INTEGRATION:
229: {
230: if (depilement(s_etat_processus, &(s_etat_processus->l_base_pile),
231: &s_objet_argument_1) == d_erreur)
232: {
233: (*s_etat_processus).erreur_execution = d_ex_manque_argument;
234: return;
235: }
236:
237: if (depilement(s_etat_processus, &(s_etat_processus->l_base_pile),
238: &s_objet_argument_2) == d_erreur)
239: {
240: liberation(s_etat_processus, s_objet_argument_1);
241: (*s_etat_processus).erreur_execution = d_ex_manque_argument;
242: return;
243: }
244:
245: if ((argument_1 = conversion_rpl_vers_cas(s_etat_processus,
246: &s_objet_argument_1)) == NULL)
247: {
248: s_etat_processus->erreur_systeme = d_es_allocation_memoire;
249: return;
250: }
251:
252: if ((argument_2 = conversion_rpl_vers_cas(s_etat_processus,
253: &s_objet_argument_2)) == NULL)
254: {
255: s_etat_processus->erreur_systeme = d_es_allocation_memoire;
256: return;
257: }
258:
259: liberation(s_etat_processus, s_objet_argument_1);
260: liberation(s_etat_processus, s_objet_argument_2);
261:
1.7 bertrand 262: try
263: {
264: giac::context contexte;
1.4 bertrand 265:
1.7 bertrand 266: gen variable(
267: string(reinterpret_cast<const char *>(argument_1)),
268: &contexte);
269: gen expression(
270: string(reinterpret_cast<const char *>(argument_2)),
271: &contexte);
272:
1.10 ! bertrand 273: gen resultat = integrate_gen(expression, variable, &contexte);
1.7 bertrand 274: string chaine = "'" + resultat.print() + "'";
275:
276: registre = s_etat_processus->instruction_courante;
277: s_etat_processus->instruction_courante =
278: reinterpret_cast<unsigned char *>(const_cast<char *>
279: (chaine.c_str()));
280:
281: recherche_type(s_etat_processus);
282:
283: if (s_etat_processus->l_base_pile != NULL)
284: {
285: conversion_cas_vers_rpl(s_etat_processus,
286: s_etat_processus->l_base_pile->donnee);
287: }
1.4 bertrand 288:
1.7 bertrand 289: s_etat_processus->instruction_courante = registre;
290: }
291: catch(bad_alloc exception)
292: {
293: s_etat_processus->erreur_systeme = d_es_allocation_memoire;
294: }
295: catch(...)
1.4 bertrand 296: {
1.7 bertrand 297: s_etat_processus->erreur_execution = d_ex_erreur_interne_rplcas;
1.4 bertrand 298: }
299:
1.7 bertrand 300: free(argument_1);
301: free(argument_2);
1.4 bertrand 302:
303: break;
304: }
305:
1.3 bertrand 306: case RPLCAS_LIMITE:
307: {
308: break;
309: }
310: }
1.1 bertrand 311:
1.3 bertrand 312: return;
1.9 bertrand 313:
314: #else
315:
316: if (s_etat_processus->langue == 'F')
317: {
318: printf("+++Attention : RPL/CAS non compilé !\n");
319: }
320: else
321: {
322: printf("+++Warning : RPL/CAS not available !\n");
323: }
324:
325: fflush(stdout);
326:
327: return;
328:
329: #endif
1.1 bertrand 330: }
331:
332: // 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