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