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