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