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