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