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