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