Annotation of rpl/src/interface_cas.cpp, revision 1.12
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,
236: struct_objet *s_objet)
237: {
238: struct_liste_chainee *l_element_courant;
239: struct_liste_chainee *l_element_precedent;
240:
241: if ((s_objet->type == ALG) || (s_objet->type == RPN))
242: {
243: // On transcrit les fonctions de GIAC vers le RPL/2.
244:
245: l_element_precedent = NULL;
246: l_element_courant = reinterpret_cast<struct_liste_chainee *>(
247: s_objet->objet);
248:
249: while(l_element_courant != NULL)
250: {
251: if (l_element_courant->donnee->type == FCT)
252: {
253: // Nous sommes en présence d'un nom, donc de quelque chose
254: // qui n'est pas reconnu comme un mot-clef du RPL/2. S'il
255: // s'agit d'un mot-clef de GIAC, on le convertit.
256:
1.12 ! bertrand 257: if ((strcmp((const char *)
! 258: reinterpret_cast<struct_fonction *>(l_element_courant
! 259: ->donnee->objet)->nom_fonction, "quote") == 0) ||
! 260: (strcmp((const char *)
1.6 bertrand 261: reinterpret_cast<struct_fonction *>(l_element_courant
1.12 ! bertrand 262: ->donnee->objet)->nom_fonction, "nop") == 0))
1.4 bertrand 263: {
264: liberation(s_etat_processus, l_element_courant->donnee);
265:
266: if ((l_element_courant->donnee =
267: allocation(s_etat_processus, FCT)) == NULL)
268: {
269: s_etat_processus->erreur_systeme =
270: d_es_allocation_memoire;
271: return;
272: }
273:
274: if ((((struct_fonction *) l_element_courant->donnee->objet)
275: ->nom_fonction = reinterpret_cast<unsigned char *>(
276: malloc(6 * sizeof(unsigned char))))
277: == NULL)
278: {
279: s_etat_processus->erreur_systeme =
280: d_es_allocation_memoire;
281: return;
282: }
283:
1.6 bertrand 284: strcpy(reinterpret_cast<char *>(
285: reinterpret_cast<struct_fonction *>(
1.4 bertrand 286: l_element_courant->donnee->objet)->nom_fonction),
287: "RELAX");
288: }
289: }
290:
291: l_element_precedent = l_element_courant;
292: l_element_courant = l_element_courant->suivant;
293: }
294: }
295:
296: return;
297: }
298:
299:
1.1 bertrand 300: /*
301: ================================================================================
302: Fonction 'interface_cas'
303: ================================================================================
1.4 bertrand 304: Entrées : commande à effectuer.
305: Le contrôle des types est effectué dans la fonction appelant interface_cas().
1.1 bertrand 306: --------------------------------------------------------------------------------
1.4 bertrand 307: Sorties : retour par la pile.
1.1 bertrand 308: --------------------------------------------------------------------------------
309: Effets de bord : néant
310: ================================================================================
311: */
312:
1.3 bertrand 313: void
1.1 bertrand 314: interface_cas(struct_processus *s_etat_processus,
1.3 bertrand 315: enum t_rplcas_commandes commande)
1.1 bertrand 316: {
1.9 bertrand 317: # ifdef RPLCAS
1.4 bertrand 318: struct_objet *s_objet_argument_1;
319: struct_objet *s_objet_argument_2;
1.12 ! bertrand 320: struct_objet *s_objet_temporaire;
! 321:
! 322: struct_liste_chainee *l_element_courant;
1.4 bertrand 323:
1.3 bertrand 324: unsigned char *argument_1;
1.4 bertrand 325: unsigned char *argument_2;
1.12 ! bertrand 326: unsigned char *argument_3;
! 327: unsigned char *argument_4;
1.4 bertrand 328: unsigned char *registre;
1.3 bertrand 329:
1.12 ! bertrand 330: unsigned int position;
! 331:
1.3 bertrand 332: switch(commande)
333: {
1.4 bertrand 334: case RPLCAS_INTEGRATION:
335: {
336: if (depilement(s_etat_processus, &(s_etat_processus->l_base_pile),
337: &s_objet_argument_1) == d_erreur)
338: {
1.12 ! bertrand 339: s_etat_processus->erreur_execution = d_ex_manque_argument;
1.4 bertrand 340: return;
341: }
342:
343: if (depilement(s_etat_processus, &(s_etat_processus->l_base_pile),
344: &s_objet_argument_2) == d_erreur)
345: {
346: liberation(s_etat_processus, s_objet_argument_1);
1.12 ! bertrand 347: s_etat_processus->erreur_execution = d_ex_manque_argument;
1.4 bertrand 348: return;
349: }
350:
351: if ((argument_1 = conversion_rpl_vers_cas(s_etat_processus,
352: &s_objet_argument_1)) == NULL)
353: {
354: s_etat_processus->erreur_systeme = d_es_allocation_memoire;
355: return;
356: }
357:
358: if ((argument_2 = conversion_rpl_vers_cas(s_etat_processus,
359: &s_objet_argument_2)) == NULL)
360: {
361: s_etat_processus->erreur_systeme = d_es_allocation_memoire;
362: return;
363: }
364:
365: liberation(s_etat_processus, s_objet_argument_1);
366: liberation(s_etat_processus, s_objet_argument_2);
367:
1.7 bertrand 368: try
369: {
370: giac::context contexte;
1.4 bertrand 371:
1.7 bertrand 372: gen variable(
373: string(reinterpret_cast<const char *>(argument_1)),
374: &contexte);
375: gen expression(
376: string(reinterpret_cast<const char *>(argument_2)),
377: &contexte);
378:
1.10 bertrand 379: gen resultat = integrate_gen(expression, variable, &contexte);
1.7 bertrand 380: string chaine = "'" + resultat.print() + "'";
381:
382: registre = s_etat_processus->instruction_courante;
383: s_etat_processus->instruction_courante =
384: reinterpret_cast<unsigned char *>(const_cast<char *>
385: (chaine.c_str()));
386:
387: recherche_type(s_etat_processus);
388:
389: if (s_etat_processus->l_base_pile != NULL)
390: {
391: conversion_cas_vers_rpl(s_etat_processus,
392: s_etat_processus->l_base_pile->donnee);
393: }
1.4 bertrand 394:
1.7 bertrand 395: s_etat_processus->instruction_courante = registre;
396: }
397: catch(bad_alloc exception)
398: {
399: s_etat_processus->erreur_systeme = d_es_allocation_memoire;
400: }
401: catch(...)
1.4 bertrand 402: {
1.7 bertrand 403: s_etat_processus->erreur_execution = d_ex_erreur_interne_rplcas;
1.4 bertrand 404: }
405:
1.7 bertrand 406: free(argument_1);
407: free(argument_2);
1.4 bertrand 408:
409: break;
410: }
411:
1.3 bertrand 412: case RPLCAS_LIMITE:
413: {
1.12 ! bertrand 414: if (depilement(s_etat_processus, &(s_etat_processus->l_base_pile),
! 415: &s_objet_argument_1) == d_erreur)
! 416: {
! 417: s_etat_processus->erreur_execution = d_ex_manque_argument;
! 418: return;
! 419: }
! 420:
! 421: if (depilement(s_etat_processus, &(s_etat_processus->l_base_pile),
! 422: &s_objet_argument_2) == d_erreur)
! 423: {
! 424: liberation(s_etat_processus, s_objet_argument_1);
! 425: s_etat_processus->erreur_execution = d_ex_manque_argument;
! 426: return;
! 427: }
! 428:
! 429: // Fonction
! 430:
! 431: if ((argument_2 = conversion_rpl_vers_cas(s_etat_processus,
! 432: &s_objet_argument_2)) == NULL)
! 433: {
! 434: s_etat_processus->erreur_systeme = d_es_allocation_memoire;
! 435: return;
! 436: }
! 437:
! 438: // On parcourt la liste. Cette liste est tout d'abord copiée
! 439: // car on est susceptible de modifier le second élément.
! 440:
! 441: if ((s_objet_temporaire = copie_objet(s_etat_processus,
! 442: s_objet_argument_1, 'O')) == NULL)
! 443: {
! 444: s_etat_processus->erreur_systeme = d_es_allocation_memoire;
! 445: return;
! 446: }
! 447:
! 448: liberation(s_etat_processus, s_objet_argument_1);
! 449: s_objet_argument_1 = s_objet_temporaire;
! 450:
! 451: l_element_courant = reinterpret_cast<struct_liste_chainee *>
! 452: (s_objet_argument_1->objet);
! 453: position = 1;
! 454: argument_4 = NULL;
! 455:
! 456: while(l_element_courant != NULL)
! 457: {
! 458: switch(position)
! 459: {
! 460: case 1:
! 461: {
! 462: // Variable
! 463:
! 464: if ((argument_1 = reinterpret_cast<unsigned char *>
! 465: (malloc((strlen((const char *)
! 466: ((struct_variable *) (l_element_courant
! 467: ->donnee->objet))->nom)
! 468: + 1) * sizeof(unsigned char)))) == NULL)
! 469: {
! 470: s_etat_processus->erreur_systeme =
! 471: d_es_allocation_memoire;
! 472: return;
! 473: }
! 474:
! 475: strcpy(reinterpret_cast<char *>(argument_1),
! 476: (const char *) ((struct_variable *)
! 477: (l_element_courant->donnee->objet))->nom);
! 478: break;
! 479: }
! 480:
! 481: case 2:
! 482: {
! 483: // Valeur
! 484: if ((argument_3 = conversion_rpl_vers_cas(
! 485: s_etat_processus,
! 486: &(l_element_courant->donnee))) == NULL)
! 487: {
! 488: s_etat_processus->erreur_systeme =
! 489: d_es_allocation_memoire;
! 490: return;
! 491: }
! 492:
! 493: break;
! 494: }
! 495:
! 496: case 3:
! 497: {
! 498: // Direction
! 499:
! 500: if ((argument_4 = reinterpret_cast<unsigned char *>
! 501: (malloc((strlen((const char *)
! 502: ((struct_fonction *) (l_element_courant
! 503: ->donnee->objet))->nom_fonction)
! 504: + 1) * sizeof(unsigned char)))) == NULL)
! 505: {
! 506: s_etat_processus->erreur_systeme =
! 507: d_es_allocation_memoire;
! 508: return;
! 509: }
! 510:
! 511: strcpy(reinterpret_cast<char *>(argument_4),
! 512: (const char *) ((struct_fonction *)
! 513: (l_element_courant->donnee->objet))
! 514: ->nom_fonction);
! 515: break;
! 516: }
! 517: }
! 518:
! 519: l_element_courant = (*l_element_courant).suivant;
! 520: position++;
! 521: }
! 522:
! 523: liberation(s_etat_processus, s_objet_argument_1);
! 524: liberation(s_etat_processus, s_objet_argument_2);
! 525:
! 526: try
! 527: {
! 528: giac::context contexte;
! 529:
! 530: int direction;
! 531:
! 532: if (argument_4 == NULL)
! 533: {
! 534: direction = 0;
! 535: }
! 536: else
! 537: {
! 538: direction = (strcmp((const char *) argument_4, "+") == 0)
! 539: ? 1 : -1;
! 540: }
! 541:
! 542: gen expression(
! 543: string(reinterpret_cast<const char *>(argument_2)),
! 544: &contexte);
! 545: identificateur variable(
! 546: string(reinterpret_cast<const char *>(argument_1)));
! 547: gen valeur(string(reinterpret_cast<const char *>
! 548: (argument_3)), &contexte);
! 549:
! 550: gen resultat = limit(expression, variable, valeur, direction,
! 551: &contexte);
! 552: string chaine = "'" + resultat.print() + "'";
! 553:
! 554: registre = s_etat_processus->instruction_courante;
! 555: s_etat_processus->instruction_courante =
! 556: reinterpret_cast<unsigned char *>(const_cast<char *>
! 557: (chaine.c_str()));
! 558:
! 559: recherche_type(s_etat_processus);
! 560:
! 561: if (s_etat_processus->l_base_pile != NULL)
! 562: {
! 563: conversion_cas_vers_rpl(s_etat_processus,
! 564: s_etat_processus->l_base_pile->donnee);
! 565: }
! 566:
! 567: s_etat_processus->instruction_courante = registre;
! 568: }
! 569: catch(bad_alloc exception)
! 570: {
! 571: s_etat_processus->erreur_systeme = d_es_allocation_memoire;
! 572: }
! 573: catch(...)
! 574: {
! 575: s_etat_processus->erreur_execution = d_ex_erreur_interne_rplcas;
! 576: }
! 577:
! 578: free(argument_1);
! 579: free(argument_2);
! 580: free(argument_3);
! 581:
! 582: if (argument_4 != NULL)
! 583: {
! 584: free(argument_4);
! 585: }
! 586:
1.3 bertrand 587: break;
588: }
589: }
1.1 bertrand 590:
1.3 bertrand 591: return;
1.9 bertrand 592:
593: #else
594:
595: if (s_etat_processus->langue == 'F')
596: {
597: printf("+++Attention : RPL/CAS non compilé !\n");
598: }
599: else
600: {
601: printf("+++Warning : RPL/CAS not available !\n");
602: }
603:
604: fflush(stdout);
605:
606: return;
607:
608: #endif
1.1 bertrand 609: }
610:
611: // 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