Fix a typo. fisrt => first
[scilab.git] / scilab / modules / core / src / c / stack2.c
1 /*
2  * Scilab ( http://www.scilab.org/ ) - This file is part of Scilab
3  * Copyright (C) 1998-2000 - ENPC - Jean-Philippe CHANCELIER
4  * Copyright (C) 1998-2008 - INRIA - Allan CORNET
5  * Copyright (C) 1998-2008 - INRIA - Serge STEER
6  * Copyright (C) 1998-2008 - INRIA - Sylvestre LEDRU
7  * Copyright (C) 1998-2008 - INRIA - Bruno JOFRET
8  * Copyright (C) 2011 - DIGITEO - Allan CORNET
9  *
10  * This file must be used under the terms of the CeCILL.
11  * This source file is licensed as described in the file COPYING, which
12  * you should have received as part of this distribution.  The terms
13  * are also available at
14  * http://www.cecill.info/licences/Licence_CeCILL_V2-en.txt
15  *
16  * Please note that piece of code will be rewrited for the Scilab 6 family
17  */
18 /*------------------------------------------------------------------------
19 *    Scilab Memory Management library (Stack API)
20 --------------------------------------------------------------------------*/
21
22 /*---------------------------------------------------------------------
23 * Interface Library:   ilib
24 *---------------------------------------------------------------------*/
25
26 #include <string.h>
27 #include <stdio.h>
28
29 #ifdef _MSC_VER
30 #include "strdup_windows.h"
31 #endif
32
33 #include "MALLOC.h"
34 #include "stack-c.h"
35 #include "sciprint.h"
36 #include "stack2.h"
37 #include "cvstr.h"
38 #include "parse.h"
39 #include "men_Sutils.h"
40 #include "int2db.h"
41 #include "rea2b.h"
42 #include "Scierror.h"
43 #include "localization.h"
44 #include "callinterf.h"
45 #include "call_scilab.h"
46 #include "recursionFunction.h"
47 #include "doublecomplex.h"
48 #include "libinter.h"
49
50 #ifdef _MSC_VER
51 #define abs(x) ((x) >= 0 ? (x) : -(x))  /* pour abs  C2F(mvfromto) line 2689 */
52 #endif
53
54 /* Table of constant values */
55 static int cx1 = 1;
56 static int cx0 = 0;
57
58 static char *Get_Iname(void);
59 static int C2F(mvfromto) (int *itopl, int *);
60
61 static int rhs_opt_find(char *name, rhs_opts opts[]);
62 static void rhs_opt_print_names(rhs_opts opts[]);
63 extern int C2F(isbyref) (int *fun);
64
65 /*------------------------------------------------*/
66 void strcpy_tws(char *str1, char *str2, int len);
67 int C2F(copyvarfromsciptr) (int lw, int n, int l);
68 static int intersci_push(void);
69 static void intersci_pop(void);
70 static int C2F(getopcode) (char *string, unsigned long string_len);
71
72 static void ConvertData(unsigned char *type, int size, int l);
73
74 /*------------------------------------------------
75 * checkrhs: checks right hand side arguments
76 *-----------------------------------------------*/
77
78 int C2F(checkrhs) (char *fname, int *iMin, int *iMax, unsigned long fname_len)
79 {
80     /*
81      * store the name in recu array, fname can be a non null terminated char array
82      * Get_Iname() can be used in other function to get the interface name
83      */
84
85     C2F(cvname) (&C2F(recu).ids[(C2F(recu).pt + 1) * nsiz - nsiz], fname, &cx0, fname_len);
86
87     if (Rhs < *iMin || Rhs > *iMax)
88     {
89         if (*iMin == *iMax)
90         {
91             /* No optional argument */
92             Scierror(77, _("%s: Wrong number of input argument(s): %d expected.\n"), get_fname(fname, fname_len), *iMax);
93         }
94         else
95         {
96             Scierror(77, _("%s: Wrong number of input argument(s): %d to %d expected.\n"), get_fname(fname, fname_len), *iMin, *iMax);
97         }
98         return FALSE;
99     }
100     return TRUE;
101 }
102
103 /*------------------------------------------------
104 * checkrhs: checks left hand side arguments
105 *-----------------------------------------------*/
106
107 int C2F(checklhs) (char *fname, int *iMin, int *iMax, unsigned long fname_len)
108 {
109     if (Lhs < *iMin || Lhs > *iMax)
110     {
111         if (*iMin == *iMax)
112         {
113             /* No optional argument */
114             Scierror(78, _("%s: Wrong number of output argument(s): %d expected.\n"), get_fname(fname, fname_len), *iMax);
115         }
116         else
117         {
118             Scierror(78, _("%s: Wrong number of output argument(s): %d to %d expected.\n"), get_fname(fname, fname_len), *iMin, *iMax);
119         }
120         return FALSE;
121     }
122     return TRUE;
123 }
124
125 /*---------------------------------------------------------------------
126 * isopt:
127 * returns the status of the variable number k
128 * if its an optional variable f(x=...)
129 * returns .true. and variable name in namex
130 * namex must have a size of nlgh + 1
131 *---------------------------------------------------------------------*/
132
133 int C2F(isopt) (int *k, char *namex, unsigned long name_len)
134 {
135     int i1 = *k + Top - Rhs;
136
137     if (C2F(isoptlw) (&Top, &i1, namex, name_len) == FALSE)
138         return FALSE;
139     /* add a '\0' at the end of the string removing trailing blanks */
140     for (i1 = nlgh - 1; i1 >= 0; i1--)
141     {
142         if (namex[i1] != ' ')
143             break;
144     }
145     namex[i1 + 1] = '\0';
146     return TRUE;
147 }
148
149 /*--------------------------------------------------------------
150 * freeptr : free ip pointer
151 *--------------------------------------------------------------*/
152
153 void C2F(freeptr) (double *ip[])
154 {
155     if (ip)
156         FREE((char *)(*ip));
157 }
158
159 /*---------------------------------------
160 * isoptlw :
161 * returns the status of the variable at position lw in the stack
162 * if its an optional variable f(x=...)
163 * returns .true. and variable name in namex
164 *--------------------------------------- */
165
166 int C2F(isoptlw) (int *topk, int *lw, char *namex, unsigned long name_len)
167 {
168     if (*Infstk(*lw) != 1)
169         return FALSE;
170     C2F(cvname) (&C2F(vstk).idstk[(*lw) * nsiz - nsiz], namex, &cx1, name_len);
171     return TRUE;
172 }
173
174 /*---------------------------------------
175 * firstopt :
176 * return the position of the first optionnal argument
177 * given as xx=val in the calling sequence.
178 * If no such argument it returns Rhs+1.
179 *--------------------------------------- */
180 int C2F(firstopt) (void)
181 {
182     int k;
183
184     for (k = 1; k <= Rhs; ++k)
185         if (*Infstk(k + Top - Rhs) == 1)
186             return k;
187     return (Rhs + 1);
188 }
189
190 /*---------------------------------------
191 * findopt :
192 * checks if option str has been passed.
193 * If yes returns the position of the variable
194 * If no  returns 0
195 *--------------------------------------- */
196
197 int C2F(findopt) (char *str, rhs_opts opts[])
198 {
199     int i;
200
201     i = rhs_opt_find(str, opts);
202     if (i >= 0)
203         if (opts[i].position > 0)
204             return opts[i].position;
205
206     return 0;
207 }
208
209 /*---------------------------------------
210 * numopt :
211 *  returns the number of optional variables
212 *  given as xx=val in the caling sequence
213 *  top must have a correct value when using this function
214 *--------------------------------------- */
215
216 int C2F(numopt) (void)
217 {
218     int k, ret = 0;
219
220     for (k = 1; k <= Rhs; ++k)
221         if (*Infstk(k + Top - Rhs) == 1)
222             ret++;
223     return ret;
224 }
225
226 /*---------------------------------------------------------------------
227 * vartype:
228 *   type of variable number number in the stack
229 *---------------------------------------------------------------------*/
230
231 int C2F(vartype) (int *number)
232 {
233     int ix1 = *number + Top - Rhs;
234
235     return C2F(gettype) (&ix1);
236 }
237
238 /*------------------------------------------------
239 * gettype:
240 *    returns the type of object at position lw in the stack
241 *------------------------------------------------*/
242
243 int C2F(gettype) (int *lw)
244 {
245     int il;
246
247     il = iadr(*Lstk(*lw));
248     if (*istk(il) < 0)
249         il = iadr(*istk(il + 1));
250     return *istk(il);
251 }
252
253 /*------------------------------------------------
254 * overloadtype:
255 *    set mechanism to overloaded function fname if object type
256 *    does not fit given type
257 *------------------------------------------------*/
258
259 static int overloadtype(int *lw, char *fname, unsigned char *typ)
260 {
261     int il = 0;
262     int ityp = 0;
263
264     il = iadr(*Lstk(*lw));
265     if (*istk(il) < 0)
266         il = iadr(*istk(il + 1));
267     switch (*typ)
268     {
269         case 'c':                  /* string */
270         case 'S':                  /* string Matrix */
271             ityp = sci_strings;
272             break;
273         case 'd':
274         case 'i':
275         case 'r':
276         case 'z':                  /* numeric */
277             ityp = sci_matrix;
278             break;
279         case 'b':                  /* boolean */
280             ityp = sci_boolean;
281             break;
282         case 'h':                  /* handle */
283             ityp = sci_handles;
284             break;
285         case 'l':                  /* list */
286             ityp = sci_list;
287             break;
288         case 't':                  /* tlist */
289             ityp = sci_tlist;
290             break;
291         case 'm':                  /* mlist */
292             ityp = sci_mlist;
293             break;
294         case 'f':                  /* external */
295             ityp = sci_c_function;
296             break;
297         case 'p':                  /* pointer */
298             ityp = sci_pointer;     /* used to be sci_lufact_pointer before Scilab 5.2 */
299             break;
300         case 's':                  /* sparse */
301             ityp = sci_sparse;
302             break;
303         case 'I':                  /* int matrix */
304             ityp = sci_ints;
305             break;
306         case 'x':                  /* polynomial matrix */
307             ityp = sci_poly;
308             break;
309
310     }
311     if (*istk(il) != ityp)
312     {
313         return C2F(overload) (lw, fname, (unsigned long)strlen(fname));
314     }
315     return 1;
316 }
317
318 /*------------------------------------------------
319 * overload
320 *    set mechanism to overloaded function fname for object lw
321 *------------------------------------------------*/
322
323 int C2F(overload) (int *lw, char *fname, unsigned long l)
324 {
325     C2F(putfunnam) (fname, lw, l);
326     C2F(com).fun = -1;
327     return 0;
328 }
329
330 /*------------------------------------------------
331 * ogettype : unused
332 *------------------------------------------------*/
333 int C2F(ogettype) (int *lw)
334 {
335     return *istk(iadr(*Lstk(*lw)));
336 }
337
338 /*----------------------------------------------------
339 * Optional arguments f(....., arg =val,...)
340 *          in interfaces
341 * function get_optionals : example is provided in
342 *    examples/addinter-examples/intex2c.c
343 *----------------------------------------------------*/
344
345 int get_optionals(char *fname, rhs_opts opts[])
346 {
347     int k, i = 0;
348     char name[nlgh + 1];
349     int nopt = NumOpt();        /* optional arguments on the stack */
350
351     /* reset first field since opts is declared static in calling function */
352     /* this could be avoided with ansi compilers by removing static in the
353      * opts declaration */
354
355     while (opts[i].name != NULL)
356     {
357         opts[i].position = -1;
358         i++;
359     }
360
361     /* Walking through last arguments */
362
363     for (k = Rhs - nopt + 1; k <= Rhs; k++)
364     {
365         if (IsOpt(k, name) == 0)
366         {
367             Scierror(999, _("%s: Optional arguments name=val must be at the end.\n"), fname);
368             return 0;
369         }
370         else
371         {
372             int isopt = rhs_opt_find(name, opts);
373
374             if (isopt >= 0)
375             {
376                 rhs_opts *ro = &opts[isopt];
377
378                 ro->position = k;
379                 if (ro->type[0] != '?')
380                     GetRhsVar(ro->position, ro->type, &ro->m, &ro->n, &ro->l);
381             }
382             else
383             {
384                 sciprint(_("%s: Unrecognized optional arguments %s.\n"), fname, name);
385                 rhs_opt_print_names(opts);
386                 SciError(999);
387                 return (0);
388             }
389         }
390     }
391     return 1;
392 }
393
394 /* Is name in opts */
395
396 int rhs_opt_find(char *name, rhs_opts opts[])
397 {
398     int rep = -1, i = 0;
399
400     while (opts[i].name != NULL)
401     {
402         int cmp;
403
404         /* name is terminated by white space and we want to ignore them */
405         if ((cmp = strcmp(name, opts[i].name)) == 0)
406         {
407             rep = i;
408             break;
409         }
410         else if (cmp < 0)
411         {
412             break;
413         }
414         else
415         {
416             i++;
417         }
418     }
419     return rep;
420 }
421
422 void rhs_opt_print_names(rhs_opts opts[])
423 /* array of optinal names (in alphabetical order)
424 * the array is null terminated */
425 {
426     int i = 0;
427
428     if (opts[i].name == NULL)
429     {
430         sciprint(_("Optional argument list is empty.\n"));
431         return;
432     }
433     sciprint(_("Optional arguments list: \n"));
434     while (opts[i + 1].name != NULL)
435     {
436         sciprint("%s, ", opts[i].name);
437         i++;
438     }
439     sciprint(_("and %s.\n"), opts[i].name);
440 }
441
442 /*---------------------------------------------------------------------
443 * isref :
444 *   checks if variable number lw is on the stack
445 *   or is just a reference to a variable on the stack
446 *---------------------------------------------------------------------*/
447
448 int IsRef(int number)
449 {
450     return C2F(isref) (&number);
451 }
452
453 int C2F(isref) (int *number)
454 {
455     int il, lw;
456
457     lw = *number + Top - Rhs;
458     if (*number > Rhs)
459     {
460         Scierror(999, _("%s: bad call to %s! (1rst argument).\n"), "isref", "isref");
461         return FALSE;
462     }
463     il = iadr(*Lstk(lw));
464     if (*istk(il) < 0)
465         return TRUE;
466     else
467         return FALSE;
468 }
469
470 /*---------------------------------------------------------------------
471 *     create a variable number lw in the stack of type
472 *     type and size m,n
473 *     the argument must be of type type ('c','d','r','i','l','b')
474 *     return values m,n,lr
475 *     c : string  (m-> number of characters and n->1)
476 *     d,r,i : matrix of double,float or integer
477 *     b : boolean matrix
478 *     l : a list  (m-> number of elements and n->1)
479 *         for each element of the list an other function
480 *         must be used to <<get>> them
481 *     side effects : arguments in the common intersci are modified
482 *     see examples in addinter-examples
483 *---------------------------------------------------------------------*/
484
485 int C2F(createvar) (int *lw, char *typex, int *m, int *n, int *lr, unsigned long type_len)
486 {
487     int ix1, ix, it = 0, lw1, lcs, IT;
488     unsigned char Type = *typex;
489     char *fname = Get_Iname();
490
491     if (*lw > intersiz)
492     {
493         Scierror(999, _("%s: (%s) too many arguments in the stack edit stack.h and enlarge intersiz.\n"), fname, "createvar");
494         return FALSE;
495     }
496     Nbvars = Max(*lw, Nbvars);
497     lw1 = *lw + Top - Rhs;
498     if (*lw < 0)
499     {
500         Scierror(999, _("%s: bad call to %s! (1rst argument).\n"), fname, "createvar");
501         return FALSE;
502     }
503     switch (Type)
504     {
505         case 'c':
506             ix1 = *m * *n;
507             if (!C2F(cresmat2) (fname, &lw1, &ix1, lr, nlgh))
508                 return FALSE;
509             *lr = cadr(*lr);
510             // Fill the string with spaces
511             for (ix = 0; ix < (*m) * (*n); ++ix)
512                 *cstk(*lr + ix) = ' ';
513             *cstk(*lr + (*m) * (*n)) = '\0';
514             C2F(intersci).ntypes[*lw - 1] = Type;
515             C2F(intersci).iwhere[*lw - 1] = *Lstk(lw1);
516             C2F(intersci).lad[*lw - 1] = *lr;
517             break;
518         case 'd':
519             if (!C2F(cremat) (fname, &lw1, &it, m, n, lr, &lcs, nlgh))
520                 return FALSE;
521             C2F(intersci).ntypes[*lw - 1] = Type;
522             C2F(intersci).iwhere[*lw - 1] = *Lstk(lw1);
523             C2F(intersci).lad[*lw - 1] = *lr;
524             break;
525         case 'z':
526             IT = 1;
527             if (!(*Lstk(lw1) % 2))
528                 *Lstk(lw1) = *Lstk(lw1) + 1;
529             if (!C2F(cremat) (fname, &lw1, &IT, m, n, lr, &lcs, nlgh))
530                 return FALSE;
531             C2F(intersci).ntypes[*lw - 1] = Type;
532             C2F(intersci).iwhere[*lw - 1] = *Lstk(lw1);
533             C2F(intersci).lad[*lw - 1] = *lr;
534             *lr = sadr(*lr);
535             break;
536         case 'l':
537             C2F(crelist) (&lw1, m, lr);
538             C2F(intersci).ntypes[*lw - 1] = '$';
539             C2F(intersci).iwhere[*lw - 1] = *Lstk(lw1);
540             C2F(intersci).lad[*lw - 1] = *lr;
541             break;
542         case 't':
543             C2F(cretlist) (&lw1, m, lr);
544             C2F(intersci).ntypes[*lw - 1] = '$';
545             C2F(intersci).iwhere[*lw - 1] = *Lstk(lw1);
546             C2F(intersci).lad[*lw - 1] = *lr;
547             break;
548         case 'm':
549             C2F(cremlist) (&lw1, m, lr);
550             C2F(intersci).ntypes[*lw - 1] = '$';
551             C2F(intersci).iwhere[*lw - 1] = *Lstk(lw1);
552             C2F(intersci).lad[*lw - 1] = *lr;
553             break;
554         case 'r':
555             if (!C2F(cremat) (fname, &lw1, &it, m, n, lr, &lcs, nlgh))
556                 return FALSE;
557             *lr = iadr(*lr);
558             C2F(intersci).ntypes[*lw - 1] = Type;
559             C2F(intersci).iwhere[*lw - 1] = *Lstk(lw1);
560             C2F(intersci).lad[*lw - 1] = *lr;
561             break;
562         case 'i':
563             if (!C2F(cremat) (fname, &lw1, &it, m, n, lr, &lcs, nlgh))
564                 return FALSE;
565             *lr = iadr(*lr);
566             C2F(intersci).ntypes[*lw - 1] = Type;
567             C2F(intersci).iwhere[*lw - 1] = *Lstk(lw1);
568             C2F(intersci).lad[*lw - 1] = *lr;
569             break;
570         case 'b':
571             if (!C2F(crebmat) (fname, &lw1, m, n, lr, nlgh))
572                 return FALSE;
573             C2F(intersci).ntypes[*lw - 1] = Type;
574             C2F(intersci).iwhere[*lw - 1] = *Lstk(lw1);
575             C2F(intersci).lad[*lw - 1] = *lr;
576             break;
577         case 'p':
578             if (!C2F(crepointer) (fname, &lw1, lr, nlgh))
579                 return FALSE;
580             C2F(intersci).ntypes[*lw - 1] = '$';
581             C2F(intersci).iwhere[*lw - 1] = *Lstk(lw1);
582             C2F(intersci).lad[*lw - 1] = *lr;
583             break;
584         case 'I':
585             it = *lr;               /* on entry lr gives the int type */
586             if (!C2F(creimat) (fname, &lw1, &it, m, n, lr, nlgh))
587                 return FALSE;
588             C2F(intersci).ntypes[*lw - 1] = '$';
589             C2F(intersci).iwhere[*lw - 1] = *Lstk(lw1);
590             C2F(intersci).lad[*lw - 1] = *lr;
591             break;
592         case 'h':
593             if (!C2F(crehmat) (fname, &lw1, m, n, lr, nlgh))
594                 return FALSE;
595             C2F(intersci).ntypes[*lw - 1] = Type;
596             C2F(intersci).iwhere[*lw - 1] = *Lstk(lw1);
597             C2F(intersci).lad[*lw - 1] = *lr;
598             break;
599             // TODO : add a default case
600     }
601     return TRUE;
602 }
603
604 /*---------------------------------------------------------------------
605 *     create a variable number lw in the stack of type
606 *     type and size m,n
607 *     the argument must be of type type ('d','r','i')
608 *     return values m,n,lr
609 *     d,r,i : matrix of double,float or integer
610 *     side effects : arguments in the common intersci are modified
611 *     see examples in addinter-examples
612 *     Like createvar but for complex matrices
613 *---------------------------------------------------------------------*/
614
615 int C2F(createcvar) (int *lw, char *typex, int *it, int *m, int *n, int *lr, int *lc, unsigned long type_len)
616 {
617     unsigned char Type = *typex;
618     int lw1;
619     char *fname = Get_Iname();
620
621     if (*lw > intersiz)
622     {
623         Scierror(999, _("%s: (%s) too many arguments in the stack edit stack.h and enlarge intersiz.\n"), fname, "createcvar");
624         return FALSE;
625     }
626     Nbvars = Max(*lw, Nbvars);
627     lw1 = *lw + Top - Rhs;
628     if (*lw < 0)
629     {
630         Scierror(999, _("%s: bad call to %s! (1rst argument).\n"), fname, "createcvar");
631         return FALSE;
632     }
633     switch (Type)
634     {
635         case 'd':
636             if (!C2F(cremat) (fname, &lw1, it, m, n, lr, lc, nlgh))
637                 return FALSE;
638             C2F(intersci).ntypes[*lw - 1] = Type;
639             C2F(intersci).iwhere[*lw - 1] = *Lstk(lw1);
640             C2F(intersci).lad[*lw - 1] = *lr;
641             break;
642         case 'r':
643             if (!C2F(cremat) (fname, &lw1, it, m, n, lr, lc, nlgh))
644                 return FALSE;
645             *lr = iadr(*lr);
646             *lc = *lr + *m * *n;
647             C2F(intersci).ntypes[*lw - 1] = Type;
648             C2F(intersci).iwhere[*lw - 1] = *Lstk(lw1);
649             C2F(intersci).lad[*lw - 1] = *lr;
650             break;
651         case 'i':
652             if (!C2F(cremat) (fname, &lw1, it, m, n, lr, lc, nlgh))
653                 return FALSE;
654             *lr = iadr(*lr);
655             *lc = *lr + *m * *n;
656             C2F(intersci).ntypes[*lw - 1] = Type;
657             C2F(intersci).iwhere[*lw - 1] = *Lstk(lw1);
658             C2F(intersci).lad[*lw - 1] = *lr;
659             break;
660     }
661     return TRUE;
662 }
663
664 /*---------------------------------------------------------------------
665 *     create a variable number lw on the stack of type
666 *     list with nel elements
667 *---------------------------------------------------------------------*/
668
669 int C2F(createlist) (int *lw, int *nel)
670 {
671     char *fname = Get_Iname();
672     int lr, lw1;
673
674     if (*lw > intersiz)
675     {
676         Scierror(999, _("%s: (%s) too many arguments in the stack edit stack.h and enlarge intersiz.\n"), fname, "createlist");
677         return FALSE;
678     }
679     Nbvars = Max(*lw, Nbvars);
680     lw1 = *lw + Top - Rhs;
681     if (*lw < 0)
682     {
683         Scierror(999, _("%s: bad call to %s! (1rst argument).\n"), fname, "createlist");
684         return FALSE;
685     }
686     C2F(crelist) (&lw1, nel, &lr);
687     C2F(intersci).ntypes[*lw - 1] = '$';
688     C2F(intersci).iwhere[*lw - 1] = *Lstk(lw1);
689     C2F(intersci).lad[*lw - 1] = lr;
690     return TRUE;
691 }
692
693 /*---------------------------------------------------------------------
694 *     create a variable number lw on the stack of type
695 *     type and size m,n
696 *     the argument must be of type type ('c','d','r','i','b')
697 *     return values m,n,lr,lar
698 *     lar is also an input value
699 *     if lar != -1 var is filled with data stored at lar
700 *---------------------------------------------------------------------*/
701
702 int C2F(createvarfrom) (int *lw, char *typex, int *m, int *n, int *lr, int *lar, unsigned long type_len)
703 {
704     int M = *m, N = *n, MN = M * N;
705     unsigned char Type = *typex;
706     int inc = 1;
707     int it = 0, lw1, lcs;
708     char *fname = Get_Iname();
709
710     if (*lw > intersiz)
711     {
712         Scierror(999, _("%s: (%s) too many arguments in the stack edit stack.h and enlarge intersiz.\n"), fname, "createvarfrom");
713         return FALSE;
714     }
715     Nbvars = Max(*lw, Nbvars);
716     lw1 = *lw + Top - Rhs;
717     if (*lw < 0)
718     {
719         Scierror(999, _("%s: bad call to %s! (1rst argument).\n"), fname, "createvarfrom");
720         return FALSE;
721     }
722     switch (Type)
723     {
724         case 'c':
725             if (!C2F(cresmat2) (fname, &lw1, &MN, lr, nlgh))
726                 return FALSE;
727             if (*lar != -1)
728                 C2F(cvstr1) (&MN, istk(*lr), cstk(*lar), &cx0, MN + 1);
729             *lar = *lr;
730             *lr = cadr(*lr);
731             break;
732         case 'd':
733             if (!C2F(cremat) (fname, &lw1, &it, m, n, lr, &lcs, nlgh))
734                 return FALSE;
735             if (*lar != -1)
736                 C2F(dcopy) (&MN, stk(*lar), &cx1, stk(*lr), &cx1);
737             *lar = *lr;
738             break;
739         case 'r':
740             if (!C2F(cremat) (fname, &lw1, &it, m, n, lr, &lcs, nlgh))
741                 return FALSE;
742             if (*lar != -1)
743                 C2F(rea2db) (&MN, sstk(*lar), &cx1, stk(*lr), &cx1);
744             *lar = *lr;
745             *lr = iadr(*lr);
746             break;
747         case 'i':
748             if (!C2F(cremat) (fname, &lw1, &it, m, n, lr, &lcs, nlgh))
749                 return FALSE;
750             if (*lar != -1)
751                 C2F(int2db) (&MN, istk(*lar), &cx1, stk(*lr), &cx1);
752             *lar = *lr;
753             *lr = iadr(*lr);
754             break;
755         case 'b':
756             if (!C2F(crebmat) (fname, &lw1, m, n, lr, nlgh))
757                 return FALSE;
758             if (*lar != -1)
759                 C2F(icopy) (&MN, istk(*lar), &cx1, istk(*lr), &cx1);
760             *lar = *lr;
761             break;
762         case 'I':
763             it = *lr;
764             if (!C2F(creimat) (fname, &lw1, &it, m, n, lr, nlgh))
765                 return FALSE;
766             if (*lar != -1)
767                 C2F(tpconv) (&it, &it, &MN, istk(*lar), &inc, istk(*lr), &inc);
768             *lar = *lr;
769             break;
770         case 'p':
771             MN = 1;
772             if (!C2F(crepointer) (fname, &lw1, lr, nlgh))
773                 return FALSE;
774             if (*lar != -1)
775                 C2F(dcopy) (&MN, stk(*lar), &cx1, stk(*lr), &cx1);
776             *lar = *lr;
777             break;
778         case 'h':
779             if (!C2F(crehmat) (fname, &lw1, m, n, lr, nlgh))
780                 return FALSE;
781             if (*lar != -1)
782                 C2F(dcopy) (&MN, stk(*lar), &cx1, stk(*lr), &cx1);
783             *lar = *lr;
784             break;
785     }
786     C2F(intersci).ntypes[*lw - 1] = '$';
787     C2F(intersci).iwhere[*lw - 1] = *Lstk(lw1);
788     C2F(intersci).lad[*lw - 1] = *lr;
789     return TRUE;
790 }
791
792 /*---------------------------------------------------------------------
793 *     create a variable number lw on the stack of type
794 *     type and size m,n
795 *     the argument must be of type type ('d','r','i')
796 *     return values it,m,n,lr,lc,lar,lac
797 *     lar is also an input value
798 *     if lar != -1 var is filled with data stored at lar
799 *     idem for lac
800 *     ==> like createvarfrom for complex matrices
801 *---------------------------------------------------------------------*/
802
803 int C2F(createcvarfrom) (int *lw, char *typex, int *it, int *m, int *n, int *lr, int *lc, int *lar, int *lac, unsigned long type_len)
804 {
805     unsigned char Type = *typex;
806     int MN;
807     int lw1, lcs;
808     char *fname = Get_Iname();
809
810     if (*lw > intersiz)
811     {
812         Scierror(999, _("%s: (%s) too many arguments in the stack edit stack.h and enlarge intersiz.\n"), fname, "createcvarfrom");
813         return FALSE;
814     }
815     Nbvars = Max(*lw, Nbvars);
816     lw1 = *lw + Top - Rhs;
817     MN = (*m) * (*n);
818     if (*lw < 0)
819     {
820         Scierror(999, _("%s: bad call to %s! (1rst argument).\n"), fname, "createcvarfrom");
821         return FALSE;
822     }
823     switch (Type)
824     {
825         case 'd':
826             if (!C2F(cremat) (fname, &lw1, it, m, n, lr, lc, nlgh))
827                 return FALSE;
828             if (*lar != -1)
829                 C2F(dcopy) (&MN, stk(*lar), &cx1, stk(*lr), &cx1);
830             if (*lac != -1 && *it == 1)
831                 C2F(dcopy) (&MN, stk(*lac), &cx1, stk(*lc), &cx1);
832             *lar = *lr;
833             *lac = *lc;
834             break;
835         case 'r':
836             if (!C2F(cremat) (fname, &lw1, it, m, n, lr, lc, nlgh))
837                 return FALSE;
838             if (*lar != -1)
839                 C2F(rea2db) (&MN, sstk(*lar), &cx1, stk(*lr), &cx1);
840             if (*lac != -1 && *it == 1)
841                 C2F(rea2db) (&MN, sstk(*lac), &cx1, stk(*lc), &cx1);
842             *lar = *lr;
843             *lac = *lc;
844             *lr = iadr(*lr);
845             *lc = *lr + *m * *n;
846             break;
847         case 'i':
848             if (!C2F(cremat) (fname, &lw1, it, m, n, lr, &lcs, nlgh))
849                 return FALSE;
850             if (*lar != -1)
851                 C2F(int2db) (&MN, istk(*lar), &cx1, stk(*lr), &cx1);
852             if (*lac != -1 && (*it == 1))
853                 C2F(int2db) (&MN, istk(*lac), &cx1, stk(*lc), &cx1);
854             *lar = *lr;
855             *lac = *lc;
856             *lr = iadr(*lr);
857             *lc = *lr + *m * *n;
858             break;
859     }
860     C2F(intersci).ntypes[*lw - 1] = '$';
861     C2F(intersci).iwhere[*lw - 1] = *Lstk(lw1);
862     C2F(intersci).lad[*lw - 1] = *lr;
863     return TRUE;
864 }
865
866 /*---------------------------------------------------------------------
867 *     This function must be called after createvar(lnumber,'l',...)
868 *     Argument lnumber is a list
869 *     we want here to get its argument number number
870 *     the argument must be of type type ('c','d','r','i','b')
871 *     input values lnumber,number,type,lar
872 *     lar : input value ( -1 or the adress of an object which is used
873 *           to fill the new variable data slot.
874 *     lar must be a variable since it is used as input and output
875 *     return values m,n,lr,lar
876 *         (lar --> data is coded at stk(lar)
877 *          lr  --> data is coded at istk(lr) or stk(lr) or sstk(lr)
878 *                  or cstk(lr)
879 *     c : string  (m-> number of characters and n->1)
880 *     d,r,i : matrix of double,float or integer
881 *---------------------------------------------------------------------*/
882
883 int C2F(createlistvarfrom) (int *lnumber, int *number, char *typex, int *m, int *n, int *lr, int *lar, unsigned long type_len)
884 {
885     unsigned Type = *typex;
886     int lc, ix1, it = 0, mn = (*m) * (*n), inc = 1;
887     char *fname = Get_Iname();
888
889     if (*lnumber > intersiz)
890     {
891         Scierror(999, _("%s: (%s) too many arguments in the stack edit stack.h and enlarge intersiz.\n"), fname, "createlistvar");
892         return FALSE;
893     }
894     switch (Type)
895     {
896         case 'c':
897             *n = 1;
898             ix1 = *lnumber + Top - Rhs;
899             if (!C2F(listcrestring) (fname, &ix1, number, &C2F(intersci).lad[*lnumber - 1], m, lr, nlgh))
900             {
901                 return FALSE;
902             }
903             if (*lar != -1)
904                 C2F(cvstr1) (m, istk(*lr), cstk(*lar), &cx0, *m * *n + 1);
905             *lar = *lr;
906             *lr = cadr(*lr);
907             break;
908         case 'd':
909             ix1 = *lnumber + Top - Rhs;
910             if (!C2F(listcremat) (fname, &ix1, number, &C2F(intersci).lad[*lnumber - 1], &it, m, n, lr, &lc, nlgh))
911             {
912                 return FALSE;
913             }
914             if (*lar != -1)
915                 C2F(dcopy) (&mn, stk(*lar), &cx1, stk(*lr), &cx1);
916             *lar = *lr;
917             break;
918         case 'r':
919             ix1 = *lnumber + Top - Rhs;
920             if (!C2F(listcremat) (fname, &ix1, number, &C2F(intersci).lad[*lnumber - 1], &it, m, n, lr, &lc, nlgh))
921             {
922                 return FALSE;
923             }
924             if (*lar != -1)
925                 C2F(rea2db) (&mn, sstk(*lar), &cx1, stk(*lr), &cx1);
926             *lar = *lr;
927             *lr = iadr(*lr);
928             break;
929         case 'i':
930             ix1 = *lnumber + Top - Rhs;
931             if (!C2F(listcremat) (fname, &ix1, number, &C2F(intersci).lad[*lnumber - 1], &it, m, n, lr, &lc, nlgh))
932             {
933                 return FALSE;
934             }
935             if (*lar != -1)
936                 C2F(int2db) (&mn, istk(*lar), &cx1, stk(*lr), &cx1);
937             *lar = *lr;
938             *lr = iadr(*lr);
939             break;
940         case 'b':
941             ix1 = *lnumber + Top - Rhs;
942             if (!C2F(listcrebmat) (fname, &ix1, number, &C2F(intersci).lad[*lnumber - 1], m, n, lr, nlgh))
943             {
944                 return FALSE;
945             }
946             if (*lar != -1)
947                 C2F(icopy) (&mn, istk(*lar), &cx1, istk(*lr), &cx1);
948             *lar = *lr;
949             break;
950         case 'I':
951             it = *lr;               /* it gives the type on entry */
952             ix1 = *lnumber + Top - Rhs;
953             if (!C2F(listcreimat) (fname, &ix1, number, &C2F(intersci).lad[*lnumber - 1], &it, m, n, lr, nlgh))
954             {
955                 return FALSE;
956             }
957             if (*lar != -1)
958                 C2F(tpconv) (&it, &it, &mn, istk(*lar), &inc, istk(*lr), &inc);
959             *lar = *lr;
960             break;
961         case 'p':
962             ix1 = *lnumber + Top - Rhs;
963             if (!C2F(listcrepointer) (fname, &ix1, number, &C2F(intersci).lad[*lnumber - 1], lr, nlgh))
964             {
965                 return FALSE;
966             }
967             if (*lar != -1)
968                 *stk(*lr) = *stk(*lar);
969             *lar = *lr;
970             break;
971         case 'h':
972             ix1 = *lnumber + Top - Rhs;
973             if (!C2F(listcrehmat) (fname, &ix1, number, &C2F(intersci).lad[*lnumber - 1], m, n, lr, nlgh))
974             {
975                 return FALSE;
976             }
977             if (*lar != -1)
978                 C2F(dcopy) (&mn, stk(*lar), &cx1, stk(*lr), &cx1);
979             *lar = *lr;
980             break;
981         default:
982             Scierror(999, _("%s: (%s) bad third argument!\n"), fname, "createlistvar");
983             return FALSE;
984             break;
985     }
986     return TRUE;
987 }
988
989 /*---------------------------------------------------------------------
990 * create a complex list variable from data
991 *---------------------------------------------------------------------*/
992
993 int C2F(createlistcvarfrom) (int *lnumber, int *number, char *typex, int *it, int *m, int *n, int *lr, int *lc, int *lar, int *lac,
994                              unsigned long type_len)
995 {
996     int ix1;
997     int mn = (*m) * (*n);
998     unsigned char Type = *typex;
999     char *fname = Get_Iname();
1000
1001     if (*lnumber > intersiz)
1002     {
1003         Scierror(999, _("%s: (%s) too many arguments in the stack edit stack.h and enlarge intersiz.\n"), fname, "createlistcvar");
1004         return FALSE;
1005     }
1006
1007     switch (Type)
1008     {
1009         case 'd':
1010             ix1 = *lnumber + Top - Rhs;
1011             if (!C2F(listcremat) (fname, &ix1, number, &C2F(intersci).lad[*lnumber - 1], it, m, n, lr, lc, nlgh))
1012                 return FALSE;
1013             if (*lar != -1)
1014                 C2F(dcopy) (&mn, stk(*lar), &cx1, stk(*lr), &cx1);
1015             if (*lac != -1 && *it == 1)
1016                 C2F(dcopy) (&mn, stk(*lac), &cx1, stk(*lc), &cx1);
1017             *lar = *lr;
1018             *lac = *lc;
1019             break;
1020         case 'r':
1021             ix1 = *lnumber + Top - Rhs;
1022             if (!C2F(listcremat) (fname, &ix1, number, &C2F(intersci).lad[*lnumber - 1], it, m, n, lr, lc, nlgh))
1023                 return FALSE;
1024             if (*lar != -1)
1025                 C2F(rea2db) (&mn, sstk(*lar), &cx1, stk(*lr), &cx1);
1026             if (*lac != -1 && *it == 1)
1027                 C2F(rea2db) (&mn, sstk(*lac), &cx1, stk(*lc), &cx1);
1028             *lar = *lr;
1029             *lac = *lc;
1030             *lr = iadr(*lr);
1031             *lc = *lr + *m * *n;
1032             break;
1033         case 'i':
1034             ix1 = *lnumber + Top - Rhs;
1035             if (!C2F(listcremat) (fname, &ix1, number, &C2F(intersci).lad[*lnumber - 1], it, m, n, lr, lc, nlgh))
1036                 return FALSE;
1037             if (*lar != -1)
1038                 C2F(int2db) (&mn, istk(*lar), &cx1, stk(*lr), &cx1);
1039             if (*lac != -1 && *it == 1)
1040                 C2F(int2db) (&mn, istk(*lac), &cx1, stk(*lc), &cx1);
1041             *lar = *lr;
1042             *lac = *lc;
1043             *lr = iadr(*lr);
1044             *lc = *lr + *m * *n;
1045             break;
1046         default:
1047             Scierror(999, _("%s: (%s) bad third argument!\n"), fname, "createlistcvar");
1048             return FALSE;
1049     }
1050     return TRUE;
1051 }
1052
1053 /*---------------------------------------------------------------------
1054 *     This function must be called after createvar(lnumber,'l',...)
1055 *     Argument lnumber is a list
1056 *     we want here to get its argument number number
1057 *     the argument must be of type type ('c','d','r','i','b')
1058 *     input values lnumber,number,type,lar
1059 *     lar : input value ( -1 or the adress of an object which is used
1060 *           to fill the new variable data slot.
1061 *     lar must be a variable since it is used as input and output
1062 *     return values m,n,lr,lar
1063 *         (lar --> data is coded at stk(lar)
1064 *          lr  --> data is coded at istk(lr) or stk(lr) or sstk(lr)
1065 *                  or cstk(lr)
1066 *     c : string  (m-> number of characters and n->1)
1067 *     d,r,i : matrix of double,float or integer
1068 *---------------------------------------------------------------------*/
1069
1070 int C2F(createlistvarfromptr) (int *lnumber, int *number, char *typex, int *m, int *n, void *iptr, unsigned long type_len)
1071 {
1072     unsigned Type = *typex;
1073     int lc, ix1, it = 0, lr, inc = 1;
1074     char *fname = Get_Iname();
1075
1076     if (*lnumber > intersiz)
1077     {
1078         Scierror(999, _("%s: (%s) too many arguments in the stack edit stack.h and enlarge intersiz.\n"), fname, "createlistvarfromptr");
1079         return FALSE;
1080     }
1081
1082     ix1 = *lnumber + Top - Rhs; /* factorization of this term (Bruno 9 march 2005, bugfix ) */
1083     switch (Type)
1084     {
1085         case 'c':
1086             *n = 1;
1087             if (!C2F(listcrestring) (fname, &ix1, number, &C2F(intersci).lad[*lnumber - 1], m, &lr, nlgh))
1088             {
1089                 return FALSE;
1090             }
1091             C2F(cchar) (m, (char **)iptr, istk(lr));
1092             break;
1093         case 'd':
1094             if (!C2F(listcremat) (fname, &ix1, number, &C2F(intersci).lad[*lnumber - 1], &it, m, n, &lr, &lc, nlgh))
1095             {
1096                 return FALSE;
1097             }
1098             ix1 = (*m) * (*n);
1099             C2F(cdouble) (&ix1, (double **)iptr, stk(lr));
1100             break;
1101         case 'r':
1102             if (!C2F(listcremat) (fname, &ix1, number, &C2F(intersci).lad[*lnumber - 1], &it, m, n, &lr, &lc, nlgh))
1103             {
1104                 return FALSE;
1105             }
1106             ix1 = (*m) * (*n);
1107             C2F(cfloat) (&ix1, (float **)iptr, stk(lr));
1108             break;
1109         case 'i':
1110             if (!C2F(listcremat) (fname, &ix1, number, &C2F(intersci).lad[*lnumber - 1], &it, m, n, &lr, &lc, nlgh))
1111             {
1112                 return FALSE;
1113             }
1114             ix1 = *m * *n;
1115             C2F(cint) (&ix1, (int **)iptr, stk(lr));
1116             break;
1117         case 'b':
1118             if (!C2F(listcrebmat) (fname, &ix1, number, &C2F(intersci).lad[*lnumber - 1], m, n, &lr, nlgh))
1119             {
1120                 return FALSE;
1121             }
1122             ix1 = *m * *n;
1123             C2F(cbool) (&ix1, (int **)iptr, istk(lr));
1124             break;
1125         case 'S':
1126             if (!cre_listsmat_from_str(fname, &ix1, number, &C2F(intersci).lad[*lnumber - 1], m, n, (char **)iptr, nlgh))   /* XXX */
1127                 return FALSE;
1128             break;
1129         case 's':
1130             if (!cre_listsparse_from_ptr(fname, &ix1, number, &C2F(intersci).lad[*lnumber - 1], m, n, (SciSparse *) iptr, nlgh))
1131                 return FALSE;
1132             break;
1133         case 'I':
1134             it = ((SciIntMat *) iptr)->it;
1135             if (!C2F(listcreimat) (fname, &ix1, number, &C2F(intersci).lad[*lnumber - 1], &it, m, n, &lr, nlgh))
1136             {
1137                 return FALSE;
1138             }
1139             ix1 = (*m) * (*n);
1140             C2F(tpconv) (&it, &it, &ix1, ((SciIntMat *) iptr)->D, &inc, istk(lr), &inc);
1141             break;
1142         case 'p':
1143             if (!C2F(listcrepointer) (fname, &ix1, number, &C2F(intersci).lad[*lnumber - 1], &lr, nlgh))
1144             {
1145                 return FALSE;
1146             }
1147             *stk(lr) = (double)((unsigned long int)iptr);
1148             break;
1149         default:
1150             Scierror(999, _("%s: (%s) bad third argument!\n"), fname, "createlistcvar");
1151             return FALSE;
1152             break;
1153     }
1154     return TRUE;
1155 }
1156
1157 /*---------------------------------------------------------------------
1158 *     This function must be called after createvar(lnumber,'l',...)
1159 *     Argument lnumber is a list
1160 *     we want here to get its argument number number
1161 *     the argument must be of type type ('c','d','r','i','b')
1162 *     input values lnumber,number,type,lar
1163 *     lar : input value ( -1 or the adress of an object which is used
1164 *           to fill the new variable data slot.
1165 *     lar must be a variable since it is used as input and output
1166 *     return values m,n,lr,lar
1167 *         (lar --> data is coded at stk(lar)
1168 *          lr  --> data is coded at istk(lr) or stk(lr) or sstk(lr)
1169 *                  or cstk(lr)
1170 *     c : string  (m-> number of characters and n->1)
1171 *     d,r,i : matrix of double,float or integer
1172 *---------------------------------------------------------------------*/
1173
1174 int C2F(createlistcvarfromptr) (int *lnumber, int *number, char *typex, int *it, int *m, int *n, void *iptr, void *iptc, unsigned long type_len)
1175 {
1176     unsigned Type = *typex;
1177     int lr, lc, ix1;
1178     char *fname = Get_Iname();
1179
1180     if (*lnumber > intersiz)
1181     {
1182         Scierror(999, _("%s: (%s) too many arguments in the stack edit stack.h and enlarge intersiz.\n"), fname, "createlistvarfromptr");
1183         return FALSE;
1184     }
1185     switch (Type)
1186     {
1187         case 'd':
1188             ix1 = *lnumber + Top - Rhs;
1189             if (!C2F(listcremat) (fname, &ix1, number, &C2F(intersci).lad[*lnumber - 1], it, m, n, &lr, &lc, nlgh))
1190             {
1191                 return FALSE;
1192             }
1193             ix1 = (*m) * (*n);
1194             C2F(cdouble) (&ix1, (double **)iptr, stk(lr));
1195             if (*it == 1)
1196                 C2F(cdouble) (&ix1, (double **)iptc, stk(lc));
1197             break;
1198         case 'r':
1199             ix1 = *lnumber + Top - Rhs;
1200             if (!C2F(listcremat) (fname, &ix1, number, &C2F(intersci).lad[*lnumber - 1], it, m, n, &lr, &lc, nlgh))
1201             {
1202                 return FALSE;
1203             }
1204             ix1 = (*m) * (*n);
1205             C2F(cfloat) (&ix1, (float **)iptr, stk(lr));
1206             if (*it == 1)
1207                 C2F(cfloat) (&ix1, (float **)iptc, stk(lc));
1208             break;
1209         case 'i':
1210             ix1 = *lnumber + Top - Rhs;
1211             if (!C2F(listcremat) (fname, &ix1, number, &C2F(intersci).lad[*lnumber - 1], it, m, n, &lr, &lc, nlgh))
1212             {
1213                 return FALSE;
1214             }
1215             ix1 = *m * *n;
1216             C2F(cint) (&ix1, (int **)iptr, stk(lr));
1217             if (*it == 1)
1218                 C2F(cint) (&ix1, (int **)iptc, stk(lc));
1219             break;
1220         default:
1221             Scierror(999, _("%s: (%s) bad third argument!\n"), fname, "createlistcvarfromptr");
1222             return FALSE;
1223             break;
1224     }
1225     return TRUE;
1226 }
1227
1228 /*---------------------------------------------------------------------
1229 * use the rest of the stack as working area
1230 * the allowed size (in double) is returned in m
1231 *---------------------------------------------------------------------*/
1232
1233 int C2F(creatework) (int *number, int *m, int *lr)
1234 {
1235     int n, it = 0, lw1, lcs, il;
1236     char *fname = Get_Iname();
1237
1238     if (*number > intersiz)
1239     {
1240
1241         Scierror(999, _("%s: (%s) too many arguments in the stack edit stack.h and enlarge intersiz.\n"), fname, "creatework");
1242         return FALSE;
1243     }
1244     Nbvars = Max(*number, Nbvars);
1245     lw1 = *number + Top - Rhs;
1246     if (lw1 < 0)
1247     {
1248         Scierror(999, _("%s: bad call to %s! (1rst argument).\n"), fname, "creatework");
1249         return FALSE;
1250     }
1251     il = iadr(*Lstk(lw1));
1252     *m = *Lstk(Bot) - sadr(il + 4);
1253     n = 1;
1254     if (!C2F(cremat) (fname, &lw1, &it, m, &n, lr, &lcs, nlgh))
1255         return FALSE;
1256     return TRUE;
1257 }
1258
1259 /*---------------------------------------------------------------------
1260 * This can be used with creatework to
1261 * set the size of object which was intialy sized to the whole
1262 * remaining space with creatework
1263 * Moreover informations the objet is recorded
1264 *---------------------------------------------------------------------*/
1265
1266 int C2F(setworksize) (int *number, int *size)
1267 {
1268     int lw1;
1269     char *fname = Get_Iname();
1270
1271     if (*number > intersiz)
1272     {
1273         Scierror(999, _("%s: (%s) too many arguments in the stack edit stack.h and enlarge intersiz.\n"), fname, "creatework");
1274         return FALSE;
1275     }
1276     Nbvars = Max(*number, Nbvars);
1277     lw1 = *number + Top - Rhs;
1278     if (lw1 < 0)
1279     {
1280         Scierror(999, _("%s: bad call to %s! (1rst argument).\n"), fname, "setworksize");
1281         return FALSE;
1282     }
1283     *Lstk(lw1 + 1) = *Lstk(lw1) + *size;
1284     C2F(intersci).ntypes[*number - 1] = '$';
1285     C2F(intersci).iwhere[*number - 1] = *Lstk(lw1);
1286     C2F(intersci).lad[*number - 1] = 0; /* not to be used XXXX */
1287     return TRUE;
1288 }
1289
1290 /*---------------------------------------------------------------------
1291 * getmatdims :
1292 *     check if argument number <<number>> is a matrix and
1293 *     returns its dimensions
1294 *---------------------------------------------------------------------*/
1295
1296 int C2F(getmatdims) (int *number, int *m, int *n)
1297 {
1298     char *fname = Get_Iname();
1299     int il, lw, typ;
1300
1301     lw = *number + Top - Rhs;
1302     if (*number > Rhs)
1303     {
1304         Scierror(999, _("%s: bad call to %s! (1rst argument).\n"), fname, "getmatdims");
1305         return FALSE;
1306     }
1307
1308     il = iadr(*Lstk(lw));
1309     if (*istk(il) < 0)
1310         il = iadr(*istk(il + 1));
1311     typ = *istk(il);
1312     if (typ > sci_strings)
1313     {
1314         Scierror(199, _("%s: Wrong type for argument %d: Matrix expected.\n"), fname, *number);
1315         return FALSE;
1316     }
1317     *m = *istk(il + 1);
1318     *n = *istk(il + 2);
1319     return TRUE;
1320 }
1321
1322 /*---------------------------------------------------------------------
1323 * getrhsvar :
1324 *     get the argument number <<number>>
1325 *     the argument must be of type type ('c','d','r','i','f','l','b')
1326 *     return values m,n,lr
1327 *     c : string  (m-> number of characters and n->1)
1328 *     d,r,i : matrix of double,float or integer
1329 *     f : external (function)
1330 *     b : boolean matrix
1331 *     l : a list  (m-> number of elements and n->1)
1332 *         for each element of the list an other function
1333 *         must be used to <<get>> them
1334 *     side effects : arguments in the common intersci are modified
1335 *     see examples in addinter-examples
1336 *---------------------------------------------------------------------*/
1337
1338 int C2F(getrhsvar) (int *number, char *typex, int *m, int *n, int *lr, unsigned long type_len)
1339 {
1340     int ierr = 0, il1 = 0, ild1 = 0, nn = 0;
1341     int lrr = 0;
1342     char *fname = Get_Iname();
1343     char **items = NULL, namex[nlgh + 1];
1344     unsigned char Type = *(unsigned char *)typex;
1345     int topk = 0, ltype = 0, m1 = 0, n1 = 0, lc = 0, lr1 = 0, it = 0, lw = 0, ile = 0, ils = 0, ix1 = 0, ix2 = 0;
1346     int mnel = 0, icol = 0;
1347     SciSparse *Sp = NULL;
1348     SciIntMat *Im = NULL;
1349
1350     /* we accept a call to getrhsvar after a createvarfromptr call */
1351     if (*number > Rhs && *number > Nbvars)
1352     {
1353         Scierror(999, _("%s: bad call to %s! (1rst argument).\n"), fname, "getrhsvar");
1354         return FALSE;
1355     }
1356
1357     Nbvars = Max(Nbvars, *number);
1358     lw = *number + Top - Rhs;
1359
1360     if (*number > intersiz)
1361     {
1362         Scierror(999, _("%s: (%s) too many arguments in the stack edit stack.h and enlarge intersiz.\n"), fname, "getrhsvar");
1363         return FALSE;
1364     }
1365
1366     if (overloadtype(&lw, fname, &Type) == 0)
1367         return FALSE;
1368
1369     topk = Top;
1370     switch (Type)
1371     {
1372         case 'c':
1373             *n = 1;
1374             if (!C2F(getsmat) (fname, &topk, &lw, &m1, &n1, &cx1, &cx1, lr, m, nlgh))
1375             {
1376                 return FALSE;
1377             }
1378
1379             if ((m1 != 1) || (n1 != 1))
1380             {
1381                 /* bug 8768 check dimensions */
1382                 Scierror(999, _("%s: Wrong size for input argument #%d: A string expected.\n"), fname, *number);
1383                 return FALSE;
1384             }
1385
1386             ix2 = *m * *n;
1387             /* in case where ix2 is 0 in2str adds the \0 char after the end of
1388              * the storage of the variable, so it writes over the next variable
1389              * tp avoid this pb we shift up by one the location where the
1390              * data is written */
1391             lrr = *lr;
1392             if (ix2 == 0)
1393                 lrr--;
1394
1395             C2F(in2str) (&ix2, istk(*lr), cstk(cadr(*lr)), ix2 + 1);
1396             *lr = cadr(*lr);
1397             C2F(intersci).ntypes[*number - 1] = Type;
1398             C2F(intersci).iwhere[*number - 1] = *Lstk(lw);
1399             C2F(intersci).lad[*number - 1] = *lr;
1400             break;
1401
1402         case 'd':
1403             if (!C2F(getmat) (fname, &topk, &lw, &it, m, n, lr, &lc, nlgh))
1404                 return FALSE;
1405             C2F(intersci).ntypes[*number - 1] = Type;
1406             C2F(intersci).iwhere[*number - 1] = *Lstk(lw);
1407             C2F(intersci).lad[*number - 1] = *lr;
1408             break;
1409         case 'z':
1410             if (!C2F(getmat) (fname, &topk, &lw, &it, m, n, lr, &lc, nlgh))
1411                 return FALSE;
1412             ix2 = *m * *n;
1413             if ((it != 1) && (ix2 != 0))
1414             {
1415                 Scierror(999, _("%s: Wrong type for argument: Complex expected.\n"), fname);
1416                 return FALSE;
1417             };
1418             if (!(*lr % 2))
1419             {
1420                 /* bad adress (lr is even) shift up the stack */
1421                 double2z(stk(*lr), stk(*lr) - 1, ix2, ix2);
1422                 *istk(iadr(*lr) - 4) = 133;
1423                 *istk(iadr(*lr) - 3) = iadr(*lr + 2 * ix2 - 1);
1424                 *istk(iadr(*lr + 2 * ix2 - 1)) = *m;
1425                 *istk(iadr(*lr + 2 * ix2 - 1) + 1) = *n;
1426                 C2F(intersci).ntypes[*number - 1] = Type;
1427                 C2F(intersci).iwhere[*number - 1] = *Lstk(lw);
1428                 C2F(intersci).lad[*number - 1] = *lr - 1;
1429                 *lr = sadr(*lr - 1);
1430             }
1431             else
1432             {
1433                 SciToF77(stk(*lr), ix2, ix2);
1434                 C2F(intersci).ntypes[*number - 1] = Type;
1435                 C2F(intersci).iwhere[*number - 1] = *Lstk(lw);
1436                 C2F(intersci).lad[*number - 1] = *lr;
1437                 *lr = sadr(*lr);
1438             };
1439             break;
1440         case 'r':
1441             if (!C2F(getmat) (fname, &topk, &lw, &it, m, n, lr, &lc, nlgh))
1442                 return FALSE;
1443             ix1 = *m * *n;
1444             C2F(simple) (&ix1, stk(*lr), sstk(iadr(*lr)));
1445             *lr = iadr(*lr);
1446             C2F(intersci).ntypes[*number - 1] = Type;
1447             C2F(intersci).iwhere[*number - 1] = *Lstk(lw);
1448             C2F(intersci).lad[*number - 1] = *lr;
1449             break;
1450         case 'i':
1451             if (!C2F(getmat) (fname, &topk, &lw, &it, m, n, lr, &lc, nlgh))
1452                 return FALSE;
1453             ix1 = *m * *n;
1454             C2F(entier) (&ix1, stk(*lr), istk(iadr(*lr)));
1455             *lr = iadr(*lr);
1456             C2F(intersci).ntypes[*number - 1] = Type;
1457             C2F(intersci).iwhere[*number - 1] = *Lstk(lw);
1458             C2F(intersci).lad[*number - 1] = *lr;
1459             break;
1460         case 'b':
1461             if (!C2F(getbmat) (fname, &topk, &lw, m, n, lr, nlgh))
1462                 return FALSE;
1463             C2F(intersci).ntypes[*number - 1] = Type;
1464             C2F(intersci).iwhere[*number - 1] = *Lstk(lw);
1465             C2F(intersci).lad[*number - 1] = *lr;
1466             break;
1467         case 'l':
1468         case 't':
1469         case 'm':
1470             *n = 1;
1471             if (!C2F(getilist) (fname, &topk, &lw, m, n, lr, nlgh))
1472                 return FALSE;
1473             /* No data conversion for list members ichar(type)='$' */
1474             Type = '$';
1475             C2F(intersci).ntypes[*number - 1] = Type;
1476             C2F(intersci).iwhere[*number - 1] = *Lstk(lw);
1477             C2F(intersci).lad[*number - 1] = *lr;
1478             break;
1479         case 'S':
1480             /** getwsmat : must be back in stack1.c from xawelm.f */
1481             if (!C2F(getwsmat) (fname, &topk, &lw, m, n, &il1, &ild1, nlgh))
1482                 return FALSE;
1483             nn = (*m) * (*n);
1484             ScilabMStr2CM(istk(il1), &nn, istk(ild1), &items, &ierr);
1485             if (ierr == 1)
1486                 return FALSE;
1487             Type = '$';
1488             /*
1489              * Warning : lr must have the proper size when calling getrhsvar
1490              * char **Str1; .... GetRhsVar(...., &lr)
1491              */
1492             *((char ***)lr) = items;
1493             C2F(intersci).ntypes[*number - 1] = Type;
1494             C2F(intersci).iwhere[*number - 1] = *Lstk(lw);
1495             C2F(intersci).lad[*number - 1] = *lr;
1496             break;
1497         case 's':
1498             /* sparse matrices */
1499             Sp = (SciSparse *) lr;
1500             if (!C2F(getsparse) (fname, &topk, &lw, &it, m, n, &(Sp->nel), &mnel, &icol, &lr1, &lc, nlgh))
1501                 return FALSE;
1502             Sp->m = *m;
1503             Sp->n = *n;
1504             Sp->it = it;
1505             Sp->mnel = istk(mnel);
1506             Sp->icol = istk(icol);
1507             Sp->R = stk(lr1);
1508             Sp->I = (it == 1) ? stk(lc) : NULL;
1509             Type = '$';
1510             C2F(intersci).ntypes[*number - 1] = Type;
1511             C2F(intersci).iwhere[*number - 1] = *Lstk(lw);
1512             C2F(intersci).lad[*number - 1] = *lr;
1513             break;
1514         case 'I':
1515             /* int matrices */
1516             Im = (SciIntMat *) lr;
1517             if (!C2F(getimat) (fname, &topk, &lw, &it, m, n, &lr1, nlgh))
1518                 return FALSE;
1519             Im->m = *m;
1520             Im->n = *n;
1521             Im->it = it;
1522             Im->l = lr1;
1523             Im->D = istk(lr1);
1524             Type = '$';
1525             C2F(intersci).ntypes[*number - 1] = Type;
1526             C2F(intersci).iwhere[*number - 1] = *Lstk(lw);
1527             C2F(intersci).lad[*number - 1] = *lr;
1528             break;
1529         case 'f':
1530             /* XXXXXX : gros bug ici car getexternal a besoin de savoir
1531              * pour quelle fonction on recupere un external
1532              * or ici on presuppose que c'est setfeval
1533              * de plus on ne sait pas exactement de quel type d'external il s'agit
1534              */
1535
1536             /*      int function getrhsvar(number,type,m,n,lr) */
1537             *lr = *Lstk(lw);
1538             ils = iadr(*lr) + 1;
1539             *m = *istk(ils);
1540             ile = ils + *m * nsiz + 1;
1541             *n = *istk(ile);
1542             if (!C2F(getexternal) (fname, &topk, &lw, namex, &ltype, C2F(setfeval), nlgh, nlgh))
1543             {
1544                 return FALSE;
1545             }
1546             Type = '$';
1547             C2F(intersci).ntypes[*number - 1] = Type;
1548             C2F(intersci).iwhere[*number - 1] = *Lstk(lw);
1549             C2F(intersci).lad[*number - 1] = *lr;
1550             break;
1551         case 'p':
1552             if (!C2F(getpointer) (fname, &topk, &lw, lr, nlgh))
1553                 return FALSE;
1554             C2F(intersci).ntypes[*number - 1] = Type;
1555             C2F(intersci).iwhere[*number - 1] = *Lstk(lw);
1556             C2F(intersci).lad[*number - 1] = *lr;
1557             break;
1558         case 'h':
1559             if (!C2F(gethmat) (fname, &topk, &lw, m, n, lr, nlgh))
1560                 return FALSE;
1561             C2F(intersci).ntypes[*number - 1] = Type;
1562             C2F(intersci).iwhere[*number - 1] = *Lstk(lw);
1563             C2F(intersci).lad[*number - 1] = *lr;
1564             break;
1565     }
1566     return TRUE;
1567 }
1568
1569 /*---------------------------------------------------------------------
1570 * getrhsvcar :
1571 *     get the argument number <<number>>
1572 *     the argument must be of type type ('d','r','i')
1573 *     like getrhsvar but for complex matrices
1574 *---------------------------------------------------------------------*/
1575
1576 int C2F(getrhscvar) (int *number, char *typex, int *it, int *m, int *n, int *lr, int *lc, unsigned long type_len)
1577 {
1578     int ix1, lw, topk;
1579     unsigned char Type = *typex;
1580     char *fname = Get_Iname();
1581
1582     Nbvars = Max(Nbvars, *number);
1583     lw = *number + Top - Rhs;
1584     if (*number > Rhs)
1585     {
1586         Scierror(999, _("%s: bad call to %s! (1rst argument).\n"), fname, "getrhscvar");
1587         return FALSE;
1588     }
1589     if (*number > intersiz)
1590     {
1591         Scierror(999, _("%s: (%s) too many arguments in the stack edit stack.h and enlarge intersiz.\n"), fname, "getrhscvar");
1592         return FALSE;
1593     }
1594     topk = Top;
1595     switch (Type)
1596     {
1597         case 'd':
1598             if (!C2F(getmat) (fname, &topk, &lw, it, m, n, lr, lc, nlgh))
1599                 return FALSE;
1600             break;
1601         case 'r':
1602             if (!C2F(getmat) (fname, &topk, &lw, it, m, n, lr, lc, nlgh))
1603                 return FALSE;
1604             ix1 = *m * *n * (*it + 1);
1605             C2F(simple) (&ix1, stk(*lr), sstk(iadr(*lr)));
1606             *lr = iadr(*lr);
1607             *lc = *lr + *m * *n;
1608             break;
1609         case 'i':
1610             if (!C2F(getmat) (fname, &topk, &lw, it, m, n, lr, lc, nlgh))
1611                 return FALSE;
1612             ix1 = *m * *n * (*it + 1);
1613             C2F(entier) (&ix1, stk(*lr), istk(iadr(*lr)));
1614             *lr = iadr(*lr);
1615             *lc = *lr + *m * *n;
1616             break;
1617     }
1618     C2F(intersci).ntypes[*number - 1] = Type;
1619     C2F(intersci).iwhere[*number - 1] = *Lstk(lw);
1620     C2F(intersci).lad[*number - 1] = *lr;
1621     return TRUE;
1622 }
1623
1624 /*---------------------------------------------------------------------
1625 * elementtype:
1626 *   returns the type of the element indexed by *number in the list
1627 *   whose variable number is *lnumber. If the indexed element does not exist
1628 *   the function returns 0.
1629 *---------------------------------------------------------------------*/
1630
1631 int C2F(elementtype) (int *lnumber, int *number)
1632 {
1633     int il, lw, itype, n, ix, ili;
1634     char *fname = Get_Iname();
1635
1636     if (*lnumber > Rhs)
1637     {
1638         Scierror(999, _("%s: bad call to %s!\n"), fname, "elementtype");
1639         return FALSE;
1640     }
1641
1642     lw = *lnumber + Top - Rhs;  /*index of the variable numbered *lnumber in the stack */
1643     il = iadr(*Lstk(lw));
1644     if (*istk(il) < 0)
1645         il = iadr(*istk(il + 1));
1646     itype = *istk(il);          /* type of the variable numbered *lnumber */
1647     if (itype < sci_list || itype > sci_mlist)
1648     {
1649         /* check if it is really a list */
1650         Scierror(210, _("%s: Wrong type for argument %d: List expected.\n"), fname, *lnumber);
1651         return FALSE;
1652     }
1653     n = *istk(il + 1);          /* number of elements in the list */
1654     itype = 0;                  /*default answer if *number is not a valid element index */
1655     if (*number <= n && *number > 0)
1656     {
1657         ix = sadr(il + 3 + n);  /* adress of the first list element */
1658         if (*istk(il + 1 + *number) < *istk(il + *number + 2))
1659         {
1660             /* the required element is defined */
1661             ili = iadr(ix + *istk(il + 1 + *number) - 1);   /* adress of the required element */
1662             itype = *istk(ili);
1663         }
1664     }
1665     return itype;
1666 }
1667
1668 /*---------------------------------------------------------------------
1669 *     This function must be called after getrhsvar(lnumber,'l',...)
1670 *     Argument lnumber is a list
1671 *     we want here to get its argument number number
1672 *     the argument must be of type type ('c','d','r','i','b')
1673 *     return values m,n,lr,lar
1674 *         (lar --> data is coded at stk(lar)
1675 *          lr  --> data is coded at istk(lr) or stk(lr) or sstk(lr)
1676 *                  or cstk(lr)
1677 *     c : string  (m-> number of characters and n->1)
1678 *     d,r,i : matrix of double,float or integer
1679 *---------------------------------------------------------------------*/
1680
1681 int C2F(getlistrhsvar) (int *lnumber, int *number, char *typex, int *m, int *n, int *lr, unsigned long type_len)
1682 {
1683     int lr1;
1684     char **items;
1685     int il1, ild1, nn, ierr = 0;
1686     char *fname = Get_Iname();
1687     int m1, n1, lc, it, lw, topk = Top, ix1, ix2;
1688     unsigned char Type = *typex;
1689     int mnel, icol;
1690     SciSparse *Sp;
1691     SciIntMat *Im;
1692
1693     Nbvars = Max(Nbvars, *lnumber);
1694     lw = *lnumber + Top - Rhs;
1695     if (*lnumber > Rhs)
1696     {
1697         Scierror(999, _("%s: bad call to %s! (1rst argument).\n"), fname, "getlistrhsvar");
1698         return FALSE;
1699     }
1700     if (*lnumber > intersiz)
1701     {
1702         Scierror(999, _("%s: (%s) too many arguments in the stack edit stack.h and enlarge intersiz.\n"), fname, "getlistrhsvar");
1703         return FALSE;
1704     }
1705
1706     switch (Type)
1707     {
1708         case 'c':
1709             *n = 1;
1710             if (!C2F(getlistsimat) (fname, &topk, &lw, number, &m1, &n1, &cx1, &cx1, lr, m, nlgh))
1711                 return FALSE;
1712             ix2 = *m * *n;
1713             C2F(in2str) (&ix2, istk(*lr), cstk(cadr(*lr)), ix2 + 1);
1714             *lr = cadr(*lr);
1715             break;
1716         case 'd':
1717             if (!C2F(getlistmat) (fname, &topk, &lw, number, &it, m, n, lr, &lc, nlgh))
1718                 return FALSE;
1719             break;
1720         case 'r':
1721             if (!C2F(getlistmat) (fname, &topk, &lw, number, &it, m, n, lr, &lc, nlgh))
1722                 return FALSE;
1723             ix1 = *m * *n;
1724             C2F(simple) (&ix1, stk(*lr), sstk(iadr(*lr)));
1725             *lr = iadr(*lr);
1726             break;
1727         case 'i':
1728             if (!C2F(getlistmat) (fname, &topk, &lw, number, &it, m, n, lr, &lc, nlgh))
1729                 return FALSE;
1730             ix1 = *m * *n;
1731             C2F(entier) (&ix1, stk(*lr), istk(iadr(*lr)));
1732             *lr = iadr(*lr);
1733             break;
1734         case 'b':
1735             if (!C2F(getlistbmat) (fname, &topk, &lw, number, m, n, lr, nlgh))
1736                 return FALSE;
1737             *lr = *lr;
1738             break;
1739         case 'z':
1740             if (!C2F(getlistmat) (fname, &topk, &lw, number, &it, m, n, lr, &lc, nlgh))
1741                 return FALSE;
1742             ix2 = *m * *n;
1743             if ((it != 1) && (ix2 != 0))
1744             {
1745                 Scierror(999, _("%s: argument %d > (%d) should be a complex matrix.\n"), fname, Rhs + (lw - topk), *number);
1746                 return FALSE;
1747             };
1748             if (!(*lr % 2))
1749             {
1750                 /* bad adress (lr is even) shift up the stack */
1751                 double2z(stk(*lr), stk(*lr) - 1, ix2, ix2);
1752                 ix2 = 2 * ix2;
1753                 *istk(iadr(*lr) - 4) = 133;
1754                 *istk(iadr(*lr) - 3) = iadr(*lr + ix2);
1755                 *istk(iadr(*lr + ix2)) = *m;
1756                 *istk(iadr(*lr + ix2) + 1) = *n;
1757                 *lr = sadr(*lr - 1);
1758             }
1759             else
1760             {
1761                 SciToF77(stk(*lr), ix2, ix2);
1762                 *lr = sadr(*lr);
1763             }
1764             break;
1765         case 'S':
1766             /** getwsmat : must be back in stack1.c from xawelm.f */
1767             if (!C2F(getlistwsmat) (fname, &topk, &lw, number, m, n, &il1, &ild1, nlgh))
1768                 return FALSE;
1769             nn = (*m) * (*n);
1770             ScilabMStr2CM(istk(il1), &nn, istk(ild1), &items, &ierr);
1771             if (ierr == 1)
1772                 return FALSE;
1773             /*
1774              * Warning : lr must have the proper size when calling getrhsvar
1775              * char **Str1; .... GetRhsVar(...., &lr)
1776              */
1777             *((char ***)lr) = items;
1778             break;
1779         case 's':
1780             /* sparse matrices */
1781             Sp = (SciSparse *) lr;
1782             if (!C2F(getlistsparse) (fname, &topk, &lw, number, &it, m, n, &(Sp->nel), &mnel, &icol, &lr1, &lc, nlgh))
1783                 return FALSE;
1784             Sp->m = *m;
1785             Sp->n = *n;
1786             Sp->it = it;
1787             Sp->mnel = istk(mnel);
1788             Sp->icol = istk(icol);
1789             Sp->R = stk(lr1);
1790             Sp->I = stk(lc);
1791             break;
1792         case 'I':
1793             /* int matrices */
1794             Im = (SciIntMat *) lr;
1795             if (!C2F(getlistimat) (fname, &topk, &lw, number, &it, m, n, &lr1, nlgh))
1796                 return FALSE;
1797             Im->m = *m;
1798             Im->n = *n;
1799             Im->it = it;
1800             Im->l = lr1;
1801             Im->D = istk(lr1);
1802             break;
1803         case 'p':
1804             if (!C2F(getlistpointer) (fname, &topk, &lw, number, lr, nlgh))
1805                 return FALSE;
1806             break;
1807         default:
1808             Scierror(999, _("%s: bad call to %s (third argument %c).\n"), fname, "getlistrhsvar", Type);
1809             return FALSE;
1810     }
1811     /* can't perform back data conversion with lists */
1812     C2F(intersci).ntypes[*number - 1] = '$';
1813     return TRUE;
1814 }
1815
1816 /*---------------------------------------------------------------------
1817 * for complex
1818 *---------------------------------------------------------------------*/
1819
1820 int C2F(getlistrhscvar) (int *lnumber, int *number, char *typex, int *it, int *m, int *n, int *lr, int *lc, unsigned long type_len)
1821 {
1822     int ix1, topk = Top, lw;
1823     char *fname = Get_Iname();
1824     unsigned char Type = *typex;
1825
1826     Nbvars = Max(Nbvars, *lnumber);
1827     lw = *lnumber + Top - Rhs;
1828     if (*lnumber > Rhs)
1829     {
1830         Scierror(999, _("%s: bad call to %s! (1rst argument).\n"), fname, "getlistrhscvar");
1831         return FALSE;
1832     }
1833     if (*lnumber > intersiz)
1834     {
1835         Scierror(999, _("%s: (%s) too many arguments in the stack edit stack.h and enlarge intersiz.\n"), fname, "getlistrhscvar");
1836         return FALSE;
1837     }
1838     switch (Type)
1839     {
1840         case 'd':
1841             if (!C2F(getlistmat) (fname, &topk, &lw, number, it, m, n, lr, lc, nlgh))
1842                 return FALSE;
1843             break;
1844         case 'r':
1845             if (!C2F(getlistmat) (fname, &topk, &lw, number, it, m, n, lr, lc, nlgh))
1846                 return FALSE;
1847             ix1 = *m * *n * (*it + 1);
1848             C2F(simple) (&ix1, stk(*lr), sstk(iadr(*lr)));
1849             *lr = iadr(*lr);
1850             *lc = *lr + *m * *n;
1851             break;
1852         case 'i':
1853             if (!C2F(getlistmat) (fname, &topk, &lw, number, it, m, n, lr, lc, nlgh))
1854                 return FALSE;
1855             ix1 = *m * *n * (*it + 1);
1856             C2F(entier) (&ix1, stk(*lr), istk(iadr(*lr)));
1857             *lr = iadr(*lr);
1858             *lc = *lr + *m * *n;
1859             break;
1860         default:
1861             Scierror(999, _("%s: (%s) bad third argument!\n"), fname, "getlistrhscvar");
1862
1863             return FALSE;
1864     }
1865     /* can't perform back data conversion with lists */
1866     C2F(intersci).ntypes[*number - 1] = '$';
1867     return TRUE;
1868 }
1869
1870 /*---------------------------------------------------------------------
1871 *     creates variable number number of type "type" and dims m,n
1872 *     from pointer ptr
1873 *
1874 *---------------------------------------------------------------------*/
1875
1876 int C2F(createvarfromptr) (int *number, char *typex, int *m, int *n, void *iptr, unsigned long type_len)
1877 {
1878     static int un = 1;
1879     unsigned char Type = *typex;
1880     int MN = (*m) * (*n), lr, it, lw1;
1881     char *fname = Get_Iname();
1882
1883     lw1 = *number + Top - Rhs;
1884     switch (Type)
1885     {
1886         case 'd':
1887             if (C2F(createvar) (number, typex, m, n, &lr, type_len) == FALSE)
1888                 return FALSE;
1889             C2F(dcopy) (&MN, *((double **)iptr), &un, stk(lr), &un);
1890             break;
1891         case 'i':
1892         case 'b':
1893             if (C2F(createvar) (number, typex, m, n, &lr, type_len) == FALSE)
1894                 return FALSE;
1895             C2F(icopy) (&MN, *((int **)iptr), &un, istk(lr), &un);
1896             break;
1897         case 'r':
1898             if (C2F(createvar) (number, typex, m, n, &lr, type_len) == FALSE)
1899                 return FALSE;
1900             C2F(rcopy) (&MN, *((float **)iptr), &un, sstk(lr), &un);
1901             break;
1902         case 'c':
1903             if (C2F(createvar) (number, typex, m, n, &lr, type_len) == FALSE)
1904                 return FALSE;
1905             strcpy(cstk(lr), *((char **)iptr));
1906             break;
1907         case 'I':
1908             /* on entry lr must gives the int type */
1909             it = lr = ((SciIntMat *) iptr)->it;
1910             if (C2F(createvar) (number, typex, m, n, &lr, type_len) == FALSE)
1911                 return FALSE;
1912             C2F(tpconv) (&it, &it, &MN, ((SciIntMat *) iptr)->D, &un, istk(lr), &un);
1913             break;
1914         case 'p':
1915             if (C2F(createvar) (number, typex, m, n, &lr, type_len) == FALSE)
1916                 return FALSE;
1917             *stk(lr) = (double)((unsigned long int)iptr);
1918             break;
1919         case 'S':
1920             /* special case: not taken into account in createvar */
1921             Nbvars = Max(*number, Nbvars);
1922             if (!cre_smat_from_str(fname, &lw1, m, n, (char **)iptr, nlgh))
1923                 return FALSE;
1924             C2F(intersci).iwhere[*number - 1] = *Lstk(lw1);
1925             C2F(intersci).ntypes[*number - 1] = '$';
1926             break;
1927         case 's':
1928             /* special case: not taken into account in createvar */
1929             Nbvars = Max(*number, Nbvars);
1930             if (!cre_sparse_from_ptr(fname, &lw1, m, n, (SciSparse *) iptr, nlgh))
1931                 return FALSE;
1932             C2F(intersci).iwhere[*number - 1] = *Lstk(lw1);
1933             C2F(intersci).ntypes[*number - 1] = '$';
1934             break;
1935         default:
1936             Scierror(999, _("%s: (%s) bad second argument!\n"), fname, "createvarfromptr");
1937
1938             return FALSE;
1939     }
1940     /*     this object will be copied with a vcopyobj in putlhsvar */
1941     return TRUE;
1942 }
1943
1944 /*---------------------------------------------------------------------
1945 *     for complex
1946 *---------------------------------------------------------------------*/
1947
1948 int C2F(createcvarfromptr) (int *number, char *typex, int *it, int *m, int *n, double *iptr, double *iptc, unsigned long type_len)
1949 {
1950     unsigned char Type = *typex;
1951     char *fname = Get_Iname();
1952     int lw1, lcs, lrs, ix1;
1953
1954     Nbvars = Max(Nbvars, *number);
1955     if (*number > intersiz)
1956     {
1957         Scierror(999, _("%s: createcvarfromptr: too many arguments on the stack, enlarge intersiz.\n"), fname);
1958         return FALSE;
1959     }
1960     lw1 = *number + Top - Rhs;
1961     switch (Type)
1962     {
1963         case 'd':
1964             if (!C2F(cremat) (fname, &lw1, it, m, n, &lrs, &lcs, nlgh))
1965                 return FALSE;
1966             ix1 = *m * *n;
1967             C2F(cdouble) (&ix1, (double **)iptr, stk(lrs));
1968             if (*it == 1)
1969             {
1970                 ix1 = *m * *n;
1971                 C2F(cdouble) (&ix1, (double **)iptc, stk(lcs));
1972             }
1973             break;
1974         case 'i':
1975             if (!C2F(cremat) (fname, &lw1, it, m, n, &lrs, &lcs, nlgh))
1976                 return FALSE;
1977             ix1 = *m * *n;
1978             C2F(cint) (&ix1, (int **)iptr, stk(lrs));
1979             if (*it == 1)
1980             {
1981                 ix1 = *m * *n;
1982                 C2F(cint) (&ix1, (int **)iptc, stk(lcs));
1983             }
1984             break;
1985         default:
1986             Scierror(999, _("%s: (%s) bad second argument!\n"), fname, "createcvarfromptr");
1987
1988             return FALSE;
1989     }
1990     /*     this object will be copied with a vcopyobj in putlhsvar */
1991     C2F(intersci).ntypes[*number - 1] = '$';
1992     return TRUE;
1993 }
1994
1995 /*---------------------------------------------------------------------
1996 * mklistfromvars :
1997 *     replace the last n variables created at postions pos:pos-1+n
1998 *     by a list of these variables at position pos
1999 *---------------------------------------------------------------------*/
2000
2001 int C2F(mklistfromvars) (int *pos, int *n)
2002 {
2003     int tops = Top;
2004     int k;
2005
2006     for (k = *pos; k < *pos + *n; k++)
2007         C2F(convert2sci) (&k);
2008     Top = Top - Rhs + *pos - 1 + *n;
2009     C2F(mklist) (n);
2010     Top = tops;
2011     C2F(intersci).ntypes[*pos - 1] = '$';
2012     return TRUE;
2013 }
2014
2015 /*---------------------------------------------------------------------
2016 * mktlistfromvars :
2017 *     similar to mklistfromvars but create a tlist
2018 *---------------------------------------------------------------------*/
2019
2020 int C2F(mktlistfromvars) (int *pos, int *n)
2021 {
2022     int type = 16;
2023     int tops = Top;
2024     int k;
2025
2026     for (k = *pos; k < *pos + *n; k++)
2027         C2F(convert2sci) (&k);
2028     Top = Top - Rhs + *pos - 1 + *n;
2029     C2F(mklistt) (n, &type);
2030     Top = tops;
2031     C2F(intersci).ntypes[*pos - 1] = '$';
2032     return TRUE;
2033 }
2034
2035 /*---------------------------------------------------------------------
2036 * mktlistfromvars :
2037 *     similar to mklistfromvars but create a mlist
2038 *---------------------------------------------------------------------*/
2039
2040 int C2F(mkmlistfromvars) (int *pos, int *n)
2041 {
2042     int type = sci_mlist;
2043     int tops = Top;
2044     int k;
2045
2046     for (k = *pos; k < *pos + *n; k++)
2047         C2F(convert2sci) (&k);
2048     Top = Top - Rhs + *pos - 1 + *n;
2049     C2F(mklistt) (n, &type);
2050     Top = tops;
2051     C2F(intersci).ntypes[*pos - 1] = '$';
2052     return TRUE;
2053 }
2054
2055 /*---------------------------------------------------------------------
2056 * call a Scilab function given its name
2057 *---------------------------------------------------------------------*/
2058
2059 int C2F(callscifun) (char *string, unsigned long string_len)
2060 {
2061     int id[nsiz];
2062
2063     C2F(cvname) (id, string, &cx0, string_len);
2064     C2F(putid) (&C2F(recu).ids[(C2F(recu).pt + 1) * nsiz - nsiz], id);
2065     C2F(com).fun = -1;
2066     return 0;
2067 }
2068
2069 /*---------------------------------------------------------------------
2070 * scifunction(number,ptr,mlhs,mrhs) >
2071 *     execute scilab function with mrhs input args and mlhs output
2072 *     variables
2073 *     input args are supposed to be stored in the top of the stack
2074 *     at positions top-mrhs+1:top
2075 *---------------------------------------------------------------------*/
2076
2077 int C2F(scifunction) (int *number, int *ptr, int *mlhs, int *mrhs)
2078 {
2079     int cx26 = 26;
2080     int ix1, ix, k, intop, lw;
2081     int imode, ireftop;
2082
2083     if (intersci_push() == 0)
2084     {
2085         Scierror(999, _("%s: No more memory.\n"), "scifunction");
2086         goto L9999;
2087     }
2088
2089     /*     macro execution inside a builtin gateway */
2090     intop = Top;
2091     Top = Top - Rhs + *number + *mrhs - 1;
2092     ++C2F(recu).pt;
2093     if (C2F(recu).pt > psiz)
2094     {
2095         SciError(cx26);
2096         goto L9999;
2097     }
2098     C2F(recu).ids[C2F(recu).pt * nsiz - nsiz] = Lhs;
2099     C2F(recu).ids[C2F(recu).pt * nsiz - (nsiz - 1)] = Rhs;
2100     C2F(recu).rstk[C2F(recu).pt - 1] = 1001;
2101     Lhs = *mlhs;
2102     Rhs = *mrhs;
2103     ++C2F(recu).niv;
2104     C2F(com).fun = 0;
2105     C2F(com).fin = *ptr;
2106     C2F(recu).icall = 5;
2107     C2F(recu).krec = -1;
2108     /* ************************** copied from callinter.h */
2109 L60:
2110     C2F(parse) ();
2111     /* parse has exited for a built-in evaluation */
2112
2113     if (C2F(com).fun == 99)
2114     {
2115         if (Err > 0 || C2F(errgst).err1 > 0)
2116         {
2117             imode = abs(C2F(errgst).errct) / 100000 % 8;
2118             if (imode != 3)
2119             {
2120                 goto L97;
2121             }
2122         }
2123         C2F(com).fun = 0;
2124         goto L200;
2125     }
2126     if (Err > 0)
2127         goto L97;
2128
2129     if (isRecursionCallToFunction())
2130     {
2131         int gw = getRecursionGatewayToCall();
2132
2133         if (gw == END_OVERLOAD)
2134         {
2135             goto L96;
2136         }
2137         else if (gw == ERROR_GW_ID)
2138         {
2139             goto L89;
2140         }
2141         else
2142         {
2143             k = gw;
2144         }
2145         goto L95;
2146     }
2147     if (isRecursionCallToFunction())
2148     {
2149         int gw = getRecursionGatewayToCall();
2150
2151         if (gw == END_OVERLOAD)
2152         {
2153             goto L96;
2154         }
2155         else if (gw == ERROR_GW_ID)
2156         {
2157             goto L89;
2158         }
2159         else
2160         {
2161             k = gw;
2162         }
2163         goto L95;
2164     }
2165
2166 L89:
2167     if (Top < Rhs)
2168     {
2169         Scierror(22, _("%s: Recursion problems. Sorry ...\n"), "scifunction");
2170         goto L97;
2171     }
2172     if (Top - Rhs + Lhs + 1 >= Bot)
2173     {
2174         Scierror(18, _("%s: Too many names.\n"), "scifunction");
2175         goto L97;
2176     }
2177     /*     ireftop used to reset top if an error occurs during
2178      * the function evaluation */
2179     ireftop = Top - Max(0, Rhs);
2180
2181     goto L91;
2182 L90:
2183     if (Err > 0)
2184         goto L97;
2185     /**/
2186 L91:
2187     k = C2F(com).fun;
2188     C2F(com).fun = 0;
2189     if (k == C2F(recu).krec)
2190     {
2191         Scierror(22, _("%s: Recursion problems. Sorry ...\n"), "scifunction");
2192         goto L97;
2193     }
2194     C2F(recu).krec = -1;
2195     if (k == 0)
2196         goto L60;
2197 L95:
2198     if (!C2F(allowptr) (&k))
2199         C2F(ref2val) ();
2200     C2F(recu).krec = k;
2201     C2F(callinterf) (&k);
2202
2203     C2F(recu).krec = -1;
2204     if (C2F(com).fun >= 0)
2205     {
2206         if (Top - Lhs + 1 > 0)
2207         {
2208             C2F(iset) (&Rhs, &cx0, &C2F(vstk).infstk[Top - Lhs], &cx1);
2209         }
2210         if (C2F(recu).paus > 0)
2211             goto L91;
2212         if (C2F(errgst).err1 > 0)
2213             Top = ireftop;
2214         goto L90;
2215     }
2216     /*    called interface ask for a scilab function to perform the function (fun=-1)
2217      *     the function name is given in ids(1,pt+1)
2218      */
2219     /*     call ref2val removed here because if forces overloading function to
2220      *     be called by value
2221      C2F(ref2val)();*/
2222     C2F(com).fun = 0;
2223     C2F(funs) (&C2F(recu).ids[(C2F(recu).pt + 1) * nsiz - nsiz]);
2224     if (Err > 0)
2225         goto L97;
2226
2227     if (C2F(com).fun > 0)
2228     {
2229         if (C2F(isbyref) (&C2F(com).fun) == 0)
2230             C2F(ref2val) ();
2231         goto L91;
2232     }
2233     if (Fin == 0)
2234     {
2235         SciError(246);
2236         if (Err > 0)
2237             goto L97;
2238         goto L90;
2239     }
2240     ++C2F(recu).pt;
2241     Fin = *Lstk(C2F(com).fin);
2242     C2F(recu).rstk[C2F(recu).pt - 1] = 910;
2243     C2F(recu).icall = 5;
2244     C2F(com).fun = 0;
2245     /*     *call*  macro */
2246     goto L60;
2247 L96:
2248     --C2F(recu).pt;
2249     goto L90;
2250
2251 L97:                           /* error handling */
2252     if ((C2F(recu).niv > 0) && (C2F(recu).paus > 0))
2253     {
2254         C2F(com).fun = 0;
2255         goto L60;
2256     }
2257     goto L9999;
2258     /* ************************** end of copy */
2259 L200:
2260     Lhs = C2F(recu).ids[C2F(recu).pt * nsiz - nsiz];
2261     Rhs = C2F(recu).ids[C2F(recu).pt * nsiz - (nsiz - 1)];
2262     --C2F(recu).pt;
2263     --C2F(recu).niv;
2264     /* + */
2265     Top = intop;
2266     ix1 = *mlhs;
2267     intersci_pop();
2268     for (ix = 1; ix <= ix1; ++ix)
2269     {
2270         lw = Top - Rhs + *number + ix - 1;
2271         C2F(intersci).ntypes[lw - 1] = '$';
2272     }
2273     return TRUE;
2274
2275 L9999:
2276     Top = intop;
2277     --C2F(recu).niv;
2278     if (C2F(errgst).err1 > 0)
2279     {
2280         Lhs = C2F(recu).ids[C2F(recu).pt * nsiz - nsiz];
2281         Rhs = C2F(recu).ids[C2F(recu).pt * nsiz - (nsiz - 1)];
2282         --C2F(recu).pt;
2283         C2F(com).fun = 0;
2284     }
2285     intersci_pop();
2286     return FALSE;
2287 }
2288
2289 /*---------------------------------------------------------------------
2290 * scistring :
2291 *   executes scilab string (name of a scilab function) with mrhs
2292 *     input args and mlhs output variables
2293 *     input args are supposed to be indexed by ifirst,ifirst+1,...
2294 *     thestring= string made of the name of a Scilab function
2295 *     mlhs,mlhs = number of lhs and rhs parameters of the function
2296 *     ifirst,thestring,mlhs and mrhs are input parameters.
2297 *---------------------------------------------------------------------*/
2298
2299 int C2F(scistring) (int *ifirst, char *thestring, int *mlhs, int *mrhs, unsigned long thestring_len)
2300 {
2301     int ret = FALSE;
2302     int ifin = 0, ifun = 0, tops = 0, moutputs = 0;
2303     int id[nsiz];
2304     int lf = 0, op = 0, ils = 0, nnn = thestring_len;
2305
2306     if (nnn <= 2)
2307     {
2308         op = C2F(getopcode) (thestring, thestring_len);
2309     }
2310
2311     if (op == 0)
2312     {
2313         C2F(cvname) (id, thestring, &cx0, nnn);
2314         Fin = 0;
2315         tops = Top;
2316         Top = Top - Rhs + *ifirst + *mrhs - 1;
2317         C2F(funs) (id);
2318         Top = tops;
2319
2320         if (Fin == 0)
2321         {
2322             Scierror(999, _("%s: %s is not a Scilab function.\n"), "scistring", get_fname(thestring, thestring_len));
2323             return ret;
2324         }
2325
2326         if (C2F(com).fun <= 0)
2327         {
2328             lf = *Lstk(Fin);
2329             ils = iadr(lf) + 1;
2330             moutputs = *istk(ils);
2331             ret = C2F(scifunction) (ifirst, &lf, mlhs, mrhs);
2332         }
2333         else
2334         {
2335             ifin = Fin;
2336             ifun = C2F(com).fun;
2337             ret = C2F(scibuiltin) (ifirst, &ifun, &ifin, mlhs, mrhs);
2338         }
2339     }
2340     else
2341     {
2342         ret = C2F(sciops) (ifirst, &op, mlhs, mrhs);
2343     }
2344     return ret;
2345 }
2346
2347 int C2F(getopcode) (char *string, unsigned long string_len)
2348 {
2349     unsigned char ch = string[0];
2350     int op = 0;
2351
2352     if (string_len >= 2)
2353     {
2354         /* .op  or op. */
2355         if (ch == '.')
2356             ch = string[1];
2357         op += 51;
2358     }
2359
2360     switch (ch)
2361     {
2362         case '*':
2363             op += 47;
2364             break;
2365         case '+':
2366             op += 45;
2367             break;
2368         case '-':
2369             op += 46;
2370             break;
2371         case '\'':
2372             op += 53;
2373             break;
2374         case '/':
2375             op += 48;
2376             break;
2377         case '\\':
2378             op += 49;
2379             break;
2380         case '^':
2381             op += 62;
2382             break;
2383         default:
2384             op = 0;
2385             break;
2386     }
2387     return op;
2388 }
2389
2390 /*---------------------------------------------------------------------
2391 *     same as scifunction: executes scilab built-in function (ifin,ifun)
2392 *
2393 *     =(interface-number, function-nmber-in-interface)
2394 *     for the input parameters located at number, number+1, ....
2395 *     mlhs,mrhs = # of lhs and rhs parameters of the function.
2396 *---------------------------------------------------------------------*/
2397
2398 int C2F(scibuiltin) (int *number, int *ifun, int *ifin, int *mlhs, int *mrhs)
2399 {
2400     int srhs = 0, slhs = 0;
2401     int ix = 0, k = 0, intop = 0, lw = 0;
2402     int imode = 0, ireftop = 0;
2403
2404     intop = Top;
2405
2406     if (intersci_push() == 0)
2407     {
2408         Scierror(999, _("%s: No more memory.\n"), "scifunction");
2409         goto L9999;
2410     }
2411
2412     Top = Top - Rhs + *number + *mrhs - 1;
2413     slhs = Lhs;
2414     srhs = Rhs;
2415     Lhs = *mlhs;
2416     Rhs = *mrhs;
2417     C2F(recu).krec = -1;
2418     ++C2F(recu).niv;
2419     goto L90;
2420     /* ***************************** copied from callinter.h  */
2421
2422 L60:
2423     C2F(parse) ();
2424     if (C2F(com).fun == 99)
2425     {
2426         if (Err > 0 || C2F(errgst).err1 > 0)
2427         {
2428             imode = abs(C2F(errgst).errct) / 100000 % 8;
2429             if (imode != 3)
2430                 goto L97;
2431         }
2432         C2F(com).fun = 0;
2433         goto L200;
2434     }
2435     if (Err > 0)
2436         goto L97;
2437
2438     if (isRecursionCallToFunction())
2439     {
2440         int gw = getRecursionGatewayToCall();
2441
2442         if (gw == END_OVERLOAD)
2443         {
2444             goto L96;
2445         }
2446         else if (gw == ERROR_GW_ID)
2447         {
2448             goto L89;
2449         }
2450         else
2451         {
2452             k = gw;
2453         }
2454         goto L95;
2455     }
2456
2457 L89:
2458     if (Top < Rhs)
2459     {
2460         Scierror(22, _("%s: Recursion problems. Sorry ...\n"), _("built in"));
2461         goto L97;
2462     }
2463     if (Top - Rhs + Lhs + 1 >= Bot)
2464     {
2465         Scierror(18, _("%s: Too many names.\n"), "");
2466         goto L97;
2467     }
2468     /*     ireftop used to reset top if an error occurs during
2469      * the function evaluation */
2470     ireftop = Top - Max(0, Rhs);
2471
2472     goto L91;
2473 L90:
2474     if (Err > 0)
2475         goto L97;
2476     /**/
2477 L91:
2478     k = C2F(com).fun;
2479     C2F(com).fun = 0;
2480     if (k == C2F(recu).krec)
2481     {
2482         Scierror(22, _("%s: Recursion problems. Sorry ...\n"), _("built in"));
2483         goto L9999;
2484     }
2485     C2F(recu).krec = -1;
2486     if (k == 0)
2487         goto L60;
2488 L95:
2489     if (!C2F(allowptr) (&k))
2490         C2F(ref2val) ();
2491     C2F(recu).krec = k;
2492     C2F(callinterf) (&k);
2493     C2F(recu).krec = -1;
2494     if (C2F(com).fun >= 0)
2495     {
2496         if (Top - Lhs + 1 > 0)
2497         {
2498             C2F(iset) (&Lhs, &cx0, &C2F(vstk).infstk[Top - Lhs], &cx1);
2499         }
2500         if (C2F(recu).paus > 0)
2501             goto L91;
2502         if (C2F(errgst).err1 > 0)
2503             Top = ireftop;
2504         goto L90;
2505     }
2506     /*    called interface ask for a sci function to perform the function (fun=-1) */
2507     /*     the function name is given in ids(1,pt+1) */
2508     C2F(ref2val) ();
2509     C2F(com).fun = 0;
2510     C2F(funs) (&C2F(recu).ids[(C2F(recu).pt + 1) * nsiz - nsiz]);
2511     if (Err > 0)
2512         goto L97;
2513     if (C2F(com).fun > 0)
2514     {
2515         if (C2F(isbyref) (&C2F(com).fun) == 0)
2516             C2F(ref2val) ();
2517         goto L91;
2518     }
2519     if (Fin == 0)
2520     {
2521         SciError(246);
2522         if (Err > 0)
2523             goto L97;
2524         goto L90;
2525     }
2526     ++C2F(recu).pt;
2527     Fin = *Lstk(C2F(com).fin);
2528     C2F(recu).rstk[C2F(recu).pt - 1] = 910;
2529     C2F(recu).icall = 5;
2530     C2F(com).fun = 0;
2531     /*     *call*  macro */
2532     goto L60;
2533 L96:
2534     --C2F(recu).pt;
2535     goto L90;
2536
2537 L97:                           /* error handling */
2538     if ((C2F(recu).niv > 0) && (C2F(recu).paus > 0))
2539     {
2540         C2F(com).fun = 0;
2541         goto L60;
2542     }
2543     /* ************************** end of copy */
2544 L200:
2545     Lhs = slhs;
2546     Rhs = srhs;
2547     --C2F(recu).niv;
2548     Top = intop;
2549     intersci_pop();
2550     for (ix = 0; ix < *mlhs; ++ix)
2551     {
2552         lw = Top - Rhs + *number + ix;
2553         C2F(intersci).ntypes[lw - 1] = '$';
2554     }
2555     return TRUE;
2556 L9999:
2557     Top = intop;
2558     --C2F(recu).niv;
2559     intersci_pop();
2560     return FALSE;
2561 }
2562
2563 /*---------------------------------------------------------------------
2564 *     same as scibuiltin: executes scilab operation op
2565 *     for the input parameters located at number, number+1, ....
2566 *     mlhs,mrhs = # of lhs and rhs parameters of the operation.
2567 *---------------------------------------------------------------------*/
2568
2569 int C2F(sciops) (int *number, int *op, int *mlhs, int *mrhs)
2570 {
2571     int ifin, ifun, srhs = Rhs, slhs = Lhs, ix, intop = Top, lw;
2572
2573     Fin = *op;
2574     Top = Top - Rhs + *number + *mrhs - 1;
2575     Lhs = *mlhs;
2576     Rhs = *mrhs;
2577
2578     while (1)
2579     {
2580         C2F(allops) ();
2581         if (Err > 0)
2582         {
2583             return FALSE;
2584         };
2585         if (C2F(com).fun == 0)
2586             break;
2587         Top = intop;
2588         ifun = C2F(com).fun;
2589         ifin = Fin;
2590         if (!C2F(scibuiltin) (number, &ifun, &ifin, mlhs, mrhs))
2591         {
2592             return FALSE;
2593         };
2594         if (Err > 0)
2595         {
2596             return FALSE;
2597         };
2598     }
2599     Lhs = slhs;
2600     Rhs = srhs;
2601     Top = intop;
2602
2603     for (ix = 1; ix <= *mlhs; ++ix)
2604     {
2605         lw = Top - Rhs + *number + ix - 1;
2606         C2F(intersci).ntypes[lw - 1] = '$';
2607     }
2608     C2F(com).fun = 0;
2609     Fin = *op;
2610     C2F(recu).icall = 0;
2611     return TRUE;
2612 }
2613
2614 /*-------------------------------------------------------------
2615 *     test and return linear system (syslin tlist)
2616 *     inputs: lw = variable number
2617 *     outputs:
2618 *     N=size of A matrix (square)
2619 *     M=number of inputs = col. dim B matrix
2620 *     P=number of outputs = row. dim of C matrix
2621 *     ptr(A,B,C,D,X0) adresses of A,B,C,D,X0 in stk
2622 *     h=type   h=0.0  continuous system
2623 *              h=1.0  discrete time system
2624 *              h=h    sampled system h=sampling period
2625 -------------------------------------------------------------*/
2626
2627 int C2F(getrhssys) (int *lw, int *n, int *m, int *p, int *ptra, int *ptrb, int *ptrc, int *ptrd, int *ptrx0, double *hx)
2628 {
2629     int cx2 = 2, cx3 = 3, cx4 = 4, cx5 = 5, cx6 = 6;
2630     int ix1, junk, msys, nsys, ix, icord;
2631     int ma, na, mb, nb, mc, nc, il, md, nd;
2632     int mx0, nx0, ptrsys, itimedomain;
2633
2634     static int iwork[23] = { 10, 1, 7, 0, 1, 4, 5, 6, 7, 8, 10, 12, 21, 28, 28, -10, -11,
2635                              -12, -13, -33, 0, 13, 29
2636                            };
2637     if (!C2F(getrhsvar) (lw, "t", &msys, &nsys, &ptrsys, 1L))
2638         return FALSE;
2639     il = iadr(ptrsys) - msys - 1;
2640     /*     syslin tlist=[ chain, (A,B,C,D,X0) ,chain or scalar ]
2641      *                     10     1 1 1 1 1      10       1
2642      */
2643     junk = il + msys + iadr(*istk(il));
2644     if (*istk(junk) != 10)
2645         return FALSE;
2646     if (*istk(il + msys + iadr(*istk(il + 1))) != 1)
2647         return FALSE;
2648     if (*istk(il + msys + iadr(*istk(il + 2))) != 1)
2649         return FALSE;
2650     if (*istk(il + msys + iadr(*istk(il + 3))) != 1)
2651         return FALSE;
2652     if (*istk(il + msys + iadr(*istk(il + 4))) != 1)
2653         return FALSE;
2654     if (*istk(il + msys + iadr(*istk(il + 5))) != 1)
2655         return FALSE;
2656     itimedomain = *istk(il + msys + iadr(*istk(il + 6)));
2657     switch (itimedomain)
2658     {
2659         case sci_strings:
2660             /* Sys(7)='c' or 'd' */
2661             icord = *istk(il + msys + iadr(*istk(il + 6)) + 6);
2662             switch (icord)
2663             {
2664                 case 12:
2665                     *hx = 0.;
2666                     break;
2667                 case 13:
2668                     *hx = 1.;
2669                     break;
2670                 default:
2671                     Scierror(999, _("Invalid time domain.\n"));
2672                     return FALSE;
2673             }
2674             break;
2675         case sci_matrix:
2676             /*     Sys(7)=h */
2677             ix1 = il + msys + iadr(*istk(il + 6)) + 4;
2678             *hx = *stk(sadr(ix1));
2679             break;
2680         default:
2681             Scierror(999, _("Invalid time domain.\n"));
2682             return FALSE;
2683     }
2684     for (ix = 0; ix < 23; ++ix) /* @TODO : what is 23 ? */
2685     {
2686         if (iwork[ix] != *istk(junk + ix))
2687         {
2688             Scierror(999, _("Invalid system.\n"));
2689             return FALSE;
2690         }
2691     }
2692     if (!C2F(getlistrhsvar) (lw, &cx2, "d", &ma, &na, ptra, 1L))
2693         return FALSE;
2694     if (!C2F(getlistrhsvar) (lw, &cx3, "d", &mb, &nb, ptrb, 1L))
2695         return FALSE;
2696     if (!C2F(getlistrhsvar) (lw, &cx4, "d", &mc, &nc, ptrc, 1L))
2697         return FALSE;
2698     if (!C2F(getlistrhsvar) (lw, &cx5, "d", &md, &nd, ptrd, 1L))
2699         return FALSE;
2700     if (!C2F(getlistrhsvar) (lw, &cx6, "d", &mx0, &nx0, ptrx0, 1L))
2701         return FALSE;
2702     if (ma != na)
2703     {
2704         Scierror(999, _("A non square matrix!\n"));
2705         return FALSE;
2706     }
2707     if (ma != mb && mb != 0)
2708     {
2709         Scierror(999, _("Invalid %c,%c matrices.\n"), 'A', 'B');
2710         return FALSE;
2711     }
2712     if (ma != nc && nc != 0)
2713     {
2714         Scierror(999, _("Invalid %c,%c matrices.\n"), 'A', 'C');
2715         return FALSE;
2716     }
2717     if (mc != md && md != 0)
2718     {
2719         Scierror(999, _("Invalid %c,%c matrices.\n"), 'C', 'D');
2720         return FALSE;
2721     }
2722     if (nb != nd && nd != 0)
2723     {
2724         Scierror(999, _("Invalid %c,%c matrices.\n"), 'B', 'D');
2725         return FALSE;
2726     }
2727     *n = ma;
2728     *m = nb;
2729     *p = mc;
2730     return TRUE;
2731 }
2732
2733 /*---------------------------------------------------
2734 * call Scilab error function (for Fortran use)
2735 *---------------------------------------------------*/
2736
2737 int C2F(errorinfo) (char *fname, int *info, unsigned long fname_len)
2738 {
2739     Scierror(998, _("%s: internal error, info=%d.\n"), get_fname(fname, fname_len), *info);
2740     return 0;
2741 }
2742
2743 /*-------------------------------------------------------------
2744 *  returns Maximal available size in scilab stack
2745 *  for variable <<number>> lw
2746 *  In a Fortran call
2747 *     lw =
2748 *     type= 'd','r','i','c'
2749 *     type_len is here for C/Fortran calling conventions
2750 *  This function is used for creating a working array of Maximal dimension
2751 *  Example :
2752 *     lwork=Maxvol(nb,'d')
2753 *     if(.not.createvar(nb,'d',lwork,1,idwork)) return
2754 *     call pipo(   ,stk(idwork),[lwork],...)
2755 *-------------------------------------------------------------*/
2756
2757 int C2F(maxvol) (int *lw, char *lw_type, unsigned long type_len)
2758 {
2759     unsigned char Type = *(unsigned char *)lw_type;
2760
2761     /* I like this one a lot: a kind of free jazz pattern  */
2762     int m = *Lstk(Bot) - sadr(iadr(*Lstk(*lw + Top - Rhs)) + 4);
2763
2764     switch (Type)
2765     {
2766         case 'd':
2767             return m;
2768             break;
2769         case 'i':
2770             return iadr(m);
2771             break;
2772         case 'r':
2773             return iadr(m);
2774             break;
2775         case 'c':
2776             return cadr(m);
2777             break;
2778         case 'z':
2779             return sadr(m) - 3;
2780             break;
2781     }
2782     /* should never get there */
2783     return m;
2784 }
2785
2786 /*---------------------------------------------
2787 * This function checks all the variables which
2788 * where references and restore their contents
2789 * to Scilab value.
2790 *---------------------------------------------*/
2791
2792 static int Check_references()
2793 {
2794     int ivar;
2795
2796     for (ivar = 1; ivar <= Rhs; ++ivar)
2797     {
2798         unsigned char Type = (unsigned char)C2F(intersci).ntypes[ivar - 1];
2799
2800         if (Type != '$')
2801         {
2802             int lw = ivar + Top - Rhs;
2803             int il = iadr(*Lstk(lw));
2804
2805             if (*istk(il) < 0)
2806             {
2807                 int m, n, it, size;
2808
2809                 /* back conversion if necessary of a reference */
2810                 if (*istk(il) < 0)
2811                     il = iadr(*istk(il + 1));
2812                 m = *istk(il + 1);
2813                 n = *istk(il + 2);
2814                 it = *istk(il + 3);
2815                 switch (Type)
2816                 {
2817                     case 'i':
2818                     case 'r':
2819                     case 'd':
2820                         size = m * n * (it + 1);
2821                         break;
2822                     case 'z':
2823                         size = 0;
2824                         break;      /* size is unsued for 'z' in ConvertData; */
2825                     case 'c':
2826                         size = *istk(il + 4 + 1) - *istk(il + 4);
2827                         break;
2828                     case 'b':
2829                         size = m * n;
2830                         break;
2831                     default:
2832                         return FALSE;
2833                 }
2834                 ConvertData(&Type, size, C2F(intersci).lad[ivar - 1]);
2835                 C2F(intersci).ntypes[ivar - 1] = '$';
2836             }
2837         }
2838         else
2839         {
2840         }
2841     }
2842     return TRUE;
2843 }
2844
2845 /*---------------------------------------------------------------------
2846 * int C2F(putlhsvar)()
2847 *     This function put on the stack the lhs
2848 *     variables which are at position lhsvar(i)
2849 *     on the calling stack
2850 *     Warning : this function supposes that the last
2851 *     variable on the stack is at position top-rhs+nbvars
2852 *---------------------------------------------------------------------*/
2853
2854 int C2F(putlhsvar) ()
2855 {
2856     int ix2, ivar, ibufprec, ix, k, lcres, nbvars1;
2857     int plhsk;
2858
2859     Check_references();
2860
2861     for (k = 1; k <= Lhs; k++)
2862     {
2863         if (LhsVar(k))
2864         {
2865             plhsk = *Lstk(LhsVar(k) + Top - Rhs);
2866             if (*istk(iadr(plhsk)) < 0)
2867             {
2868                 if (*Lstk(Bot) > *Lstk(*istk(iadr(plhsk) + 2)))
2869                 {
2870                     LhsVar(k) = *istk(iadr(plhsk) + 2);
2871                     /* lcres = 0 */
2872                 }
2873             }
2874         }
2875     }
2876
2877     if (Err > 0 || C2F(errgst).err1 > 0)
2878         return TRUE;
2879     if (C2F(com).fun == -1)
2880         return TRUE;            /* execution continue with an
2881                                  * overloaded function */
2882     if (LhsVar(1) == 0)
2883     {
2884         Top = Top - Rhs + Lhs;
2885         C2F(objvide) (" ", &Top, 1L);
2886         Nbvars = 0;
2887         return TRUE;
2888     }
2889     nbvars1 = 0;
2890     for (k = 1; k <= Lhs; ++k)
2891         nbvars1 = Max(nbvars1, LhsVar(k));
2892     /* check if output variabe are in increasing order in the stack */
2893     lcres = TRUE;
2894     ibufprec = 0;
2895     for (ix = 1; ix <= Lhs; ++ix)
2896     {
2897         if (LhsVar(ix) < ibufprec)
2898         {
2899             lcres = FALSE;
2900             break;
2901         }
2902         else
2903         {
2904             ibufprec = LhsVar(ix);
2905         }
2906     }
2907     if (!lcres)
2908     {
2909         /* First pass if output variables are not
2910          * in increasing order
2911          */
2912         for (ivar = 1; ivar <= Lhs; ++ivar)
2913         {
2914             ix2 = Top - Rhs + nbvars1 + ivar;
2915             if (!C2F(mvfromto) (&ix2, &LhsVar(ivar)))
2916             {
2917                 return FALSE;
2918             }
2919             LhsVar(ivar) = nbvars1 + ivar;
2920             /* I change type of variable nbvars1 + ivar
2921              * in order to just perform a dcopy at next pass
2922              */
2923             if (nbvars1 + ivar > intersiz)
2924             {
2925                 Scierror(999, _("%s: intersiz is too small.\n"), "putlhsvar");
2926                 return FALSE;
2927             }
2928             C2F(intersci).ntypes[nbvars1 + ivar - 1] = '$';
2929         }
2930     }
2931     /*  Second pass */
2932     for (ivar = 1; ivar <= Lhs; ++ivar)
2933     {
2934         ix2 = Top - Rhs + ivar;
2935         if (!C2F(mvfromto) (&ix2, &LhsVar(ivar)))
2936         {
2937             return FALSE;
2938         }
2939     }
2940     Top = Top - Rhs + Lhs;
2941     LhsVar(1) = 0;
2942     Nbvars = 0;
2943     return TRUE;
2944 }
2945
2946 /*---------------------------------------------------------------------
2947 * mvfromto :
2948 *     this routines copies the variable number i
2949 *     (created by getrhsvar or createvar or by mvfromto itself in a precedent call)
2950 *     from its position on the stack to position itopl
2951 *     returns false if there's no more stack space available
2952 *     - if type(i) # '$'  : This variable is at
2953 *                         position lad(i) on the stack )
2954 *                         and itopl must be the first free position
2955 *                         on the stack
2956 *                         copy is performed + type conversion (type(i))
2957 *     - if type(i) == '$': then it means that object at position i
2958 *                         is the result of a previous call to mvfromto
2959 *                         a copyobj is performed and itopl can
2960 *                         can be any used position on the stack
2961 *                         the object which was at position itopl
2962 *                         is replaced by object at position i
2963 *                         (and access to object itopl+1 can be lost if
2964 *                         the object at position i is <> from object at
2965 *                         position itopl
2966 *---------------------------------------------------------------------*/
2967
2968 static int C2F(mvfromto) (int *itopl, int *ix)
2969 {
2970     int ix1 = 0;
2971     int m = 0;
2972     int n = 0;
2973     int it = 0;
2974     int lcs = 0;
2975     int lrs = 0;
2976     int l = 0;
2977     int size = 0;
2978     int pointed = 0;
2979     unsigned long int ilp = 0;
2980     unsigned char Type;
2981     double wsave;
2982
2983     Type = (unsigned char)C2F(intersci).ntypes[*ix - 1];
2984     if (Type != '$')
2985     {
2986         /* int iwh = *ix + Top - Rhs;
2987          * ilp = iadr(*Lstk(iwh)); */
2988         int iwh = C2F(intersci).iwhere[*ix - 1];
2989
2990         ilp = iadr(iwh);
2991         if (*istk(ilp) < 0)
2992             ilp = iadr(*istk(ilp + 1));
2993         m = *istk(ilp + 1);
2994         n = *istk(ilp + 2);
2995         it = *istk(ilp + 3);
2996     }
2997
2998     switch (Type)
2999     {
3000         case 'i':
3001             if (!C2F(cremat) ("mvfromto", itopl, &it, &m, &n, &lrs, &lcs, 8L))
3002             {
3003                 return FALSE;
3004             }
3005             ix1 = m * n * (it + 1);
3006             C2F(stacki2d) (&ix1, &C2F(intersci).lad[*ix - 1], &lrs);
3007             C2F(intersci).lad[*ix - 1] = iadr(lrs);
3008             break;
3009         case 'r':
3010             if (!C2F(cremat) ("mvfromto", itopl, &it, &m, &n, &lrs, &lcs, 8L))
3011             {
3012                 return FALSE;
3013             }
3014             ix1 = m * n * (it + 1);
3015             C2F(stackr2d) (&ix1, &C2F(intersci).lad[*ix - 1], &lrs);
3016             C2F(intersci).lad[*ix - 1] = iadr(lrs);
3017             break;
3018         case 'd':
3019             if (!C2F(cremat) ("mvfromto", itopl, &it, &m, &n, &lrs, &lcs, 8L))
3020             {
3021                 return FALSE;
3022             }
3023             /* no copy if the two objects are the same
3024              * the cremat above is kept to deal with possible size changes
3025              */
3026             if (C2F(intersci).lad[*ix - 1] != lrs)
3027             {
3028                 ix1 = m * n * (it + 1);
3029                 l = C2F(intersci).lad[*ix - 1];
3030                 if (abs(l - lrs) < ix1)
3031                     C2F(unsfdcopy) (&ix1, stk(l), &cx1, stk(lrs), &cx1);
3032                 else
3033                     C2F(dcopy) (&ix1, stk(l), &cx1, stk(lrs), &cx1);
3034                 C2F(intersci).lad[*ix - 1] = lrs;
3035             }
3036             break;
3037         case 'z':
3038             if (*istk(ilp) == 133)
3039             {
3040                 wsave = *stk(C2F(intersci).lad[*ix - 1]);
3041                 n = *istk(m + 1);
3042                 m = *istk(m);
3043                 it = 1;
3044                 if (!C2F(cremat) ("mvfromto", itopl, &it, &m, &n, &lrs, &lcs, 8L))
3045                 {
3046                     return FALSE;
3047                 }
3048                 z2double(stk(C2F(intersci).lad[*ix - 1]), stk(lrs), m * n, m * n);
3049                 *stk(lrs) = wsave;
3050                 C2F(intersci).lad[*ix - 1] = lrs;
3051             }
3052             else
3053             {
3054                 if (!C2F(cremat) ("mvfromto", itopl, &it, &m, &n, &lrs, &lcs, 8L))
3055                 {
3056                     return FALSE;
3057                 }
3058                 z2double(stk(C2F(intersci).lad[*ix - 1]), stk(lrs), m * n, m * n);
3059                 C2F(intersci).lad[*ix - 1] = lrs;
3060             }
3061             break;
3062         case 'c':
3063             m = *istk(ilp + 4 + 1) - *istk(ilp + 4);
3064             n = 1;
3065             ix1 = m * n;
3066             if (!C2F(cresmat2) ("mvfromto", itopl, &ix1, &lrs, 8L))
3067             {
3068                 return FALSE;
3069             }
3070             C2F(stackc2i) (&ix1, &C2F(intersci).lad[*ix - 1], &lrs);
3071             C2F(intersci).lad[*ix - 1] = cadr(lrs);
3072             break;
3073
3074         case 'b':
3075             if (!C2F(crebmat) ("mvfromto", itopl, &m, &n, &lrs, 8L))
3076             {
3077                 return FALSE;
3078             }
3079             ix1 = m * n;
3080             C2F(icopy) (&ix1, istk(C2F(intersci).lad[*ix - 1]), &cx1, istk(lrs), &cx1);
3081             C2F(intersci).lad[*ix - 1] = lrs;
3082             break;
3083         case '-':
3084             /*    reference  '-' = ascii(45) */
3085             ilp = iadr(*Lstk(*ix));
3086             size = *istk(ilp + 3);
3087             pointed = *istk(ilp + 2);
3088             if (!C2F(cremat) ("mvfromto", itopl, (it = 0, &it), (m = 1, &m), &size, &lrs, &lcs, 8L))
3089             {
3090                 return FALSE;
3091             }
3092             if (C2F(vcopyobj) ("mvfromto", &pointed, itopl, 8L) == FALSE)
3093                 return FALSE;
3094             break;
3095         case 'h':
3096             if (!C2F(crehmat) ("mvfromto", itopl, &m, &n, &lrs, 8L))
3097             {
3098                 return FALSE;
3099             }
3100             /* no copy if the two objects are the same
3101              * the cremat above is kept to deal with possible size changes
3102              */
3103             if (C2F(intersci).lad[*ix - 1] != lrs)
3104             {
3105                 ix1 = m * n;
3106                 l = C2F(intersci).lad[*ix - 1];
3107                 if (abs(l - lrs) < ix1)
3108                     C2F(unsfdcopy) (&ix1, stk(l), &cx1, stk(lrs), &cx1);
3109                 else
3110                     C2F(dcopy) (&ix1, stk(l), &cx1, stk(lrs), &cx1);
3111                 C2F(intersci).lad[*ix - 1] = lrs;
3112             }
3113             break;
3114         case 'p':
3115         case '$':
3116             /*     special case */
3117             if (Top - Rhs + *ix != *itopl)
3118             {
3119                 ix1 = Top - Rhs + *ix;
3120                 if (C2F(vcopyobj) ("mvfromto", &ix1, itopl, 8L) == FALSE)
3121                     return FALSE;
3122             }
3123     }
3124     return TRUE;
3125 }
3126
3127 /*---------------------------------------------------------------------
3128 * copyref
3129 * copy object at position from to position to
3130 * without changing data.
3131 * The copy is only performed if object is a reference
3132 * and ref object is replaced by its value
3133 *---------------------------------------------------------------------*/
3134
3135 int Ref2val(int from, int to)
3136 {
3137     int il, lw;
3138
3139     lw = from + Top - Rhs;
3140     if (from > Rhs)
3141     {
3142         Scierror(999, _("%s: bad call to %s! (1rst argument).\n"), "copyref", "isref");
3143         return FALSE;
3144     }
3145     il = iadr(*Lstk(lw));
3146     if (*istk(il) < 0)
3147     {
3148         int lwd;
3149
3150         /* from contains a reference */
3151         lw = *istk(il + 2);
3152         lwd = to + Top - Rhs;
3153         C2F(copyobj) ("copyref", &lw, &lwd, (unsigned long)strlen("copyref"));
3154     }
3155     return 0;
3156 }
3157
3158 /*---------------------------------------------------------------------
3159 * convert2sci :
3160 *     this routine converts data of variable number num
3161 *     to scilab standard data code
3162 *     see how it is used in matdes.c
3163 *---------------------------------------------------------------------*/
3164
3165 int C2F(convert2sci) (int *ix)
3166 {
3167     int ix1 = Top - Rhs + *ix;
3168
3169     if (!C2F(mvfromto) (&ix1, ix))
3170         return FALSE;
3171     C2F(intersci).ntypes[*ix - 1] = '$';
3172     return TRUE;
3173 }
3174
3175 /*-----------------------------------------------------------
3176 * strcpy_tws : fname[0:nlgh-2]=' '
3177 * fname[nlgh-1] = '\0'
3178 * then second string is copied into first one
3179 * ------------------------------------------------------------*/
3180
3181 void strcpy_tws(char *str1, char *str2, int len)
3182 {
3183     int i;
3184
3185     for (i = 0; i < (int)strlen(str2); i++)
3186         str1[i] = str2[i];
3187     for (i = (int)strlen(str2); i < len; i++)
3188         str1[i] = ' ';
3189     str1[len - 1] = '\0';
3190 }
3191
3192 /*---------------------------------------------------------------------
3193 *     conversion from Scilab code --> ascii
3194 *     + add a 0 at end of string
3195 *---------------------------------------------------------------------*/
3196
3197 int C2F(in2str) (int *n, int *line, char *str, unsigned long str_len)
3198 {
3199     C2F(codetoascii) (n, line, str, str_len);
3200     str[*n] = '\0';
3201     return 0;
3202 }
3203
3204 /*---------------------------------------------------------------------
3205 * Get_Iname:
3206 * Get the name (interfcae name) which was stored in ids while in checkrhs
3207 *---------------------------------------------------------------------*/
3208
3209 static char Fname[nlgh + 1];
3210
3211 static char *Get_Iname()
3212 {
3213     int i;
3214
3215     C2F(cvname) (&C2F(recu).ids[(C2F(recu).pt + 1) * nsiz - nsiz], Fname, &cx1, nlgh);
3216     /** remove trailing blanks **/
3217     for (i = 0; i < nlgh; i++)
3218         if (Fname[i] == ' ')
3219         {
3220             Fname[i] = '\0';
3221             break;
3222         }
3223     Fname[nlgh] = '\0';
3224     return Fname;
3225 }
3226
3227 /*---------------------------------------------------------------------
3228 * Utility for error message
3229 *---------------------------------------------------------------------*/
3230
3231 static char arg_position[56];   /* @TODO WTF is 56 ? */
3232
3233 char *CharPosition(int i)
3234 {
3235     char *tmp_buffer = NULL;
3236
3237     switch (i + 1)
3238     {
3239         case 1:
3240             tmp_buffer = strdup(_("first"));
3241             break;
3242         case 2:
3243             tmp_buffer = strdup(_("second"));
3244             break;
3245         case 3:
3246             tmp_buffer = strdup(_("third"));
3247             break;
3248         case 4:
3249             tmp_buffer = strdup(_("fourth"));
3250             break;
3251         default:
3252             tmp_buffer = strdup(" ");
3253             break;
3254     }
3255     return tmp_buffer;
3256 }
3257
3258 char *ArgPosition(int i)
3259 {
3260     char *tmp_buffer = NULL;
3261
3262     if (i > 0 && i <= 4)
3263     {
3264         tmp_buffer = CharPosition(i - 1);
3265         sprintf(arg_position, _("%s argument"), tmp_buffer);
3266         FREE(tmp_buffer);
3267     }
3268     else
3269     {
3270         sprintf(arg_position, _("argument #%d"), i);
3271     }
3272     return arg_position;
3273 }
3274
3275 char *ArgsPosition(int i, int j)
3276 {
3277     char *tmp_buffer_1 = NULL, *tmp_buffer_2 = NULL;
3278
3279     if (i > 0 && i <= 4)
3280     {
3281         if (j > 0 && j <= 4)
3282         {
3283             tmp_buffer_1 = CharPosition(i - 1);
3284             tmp_buffer_2 = CharPosition(j - 1);
3285             sprintf(arg_position, _("%s and %s arguments"), tmp_buffer_1, tmp_buffer_2);
3286             FREE(tmp_buffer_1);
3287             FREE(tmp_buffer_2);
3288         }
3289         else
3290         {
3291             tmp_buffer_1 = CharPosition(i - 1);
3292             sprintf(arg_position, _("%s argument and argument #%d"), tmp_buffer_1, j);
3293             FREE(tmp_buffer_1);
3294         }
3295     }
3296     else
3297     {
3298         if (j > 0 && j <= 4)
3299         {
3300             tmp_buffer_1 = CharPosition(j - 1);
3301             sprintf(arg_position, _("%s argument and argument #%d"), tmp_buffer_1, i);
3302             FREE(tmp_buffer_1);
3303         }
3304         else
3305             sprintf(arg_position, _("arguments #%d and #%d"), i, j);
3306     }
3307     return arg_position;
3308 }
3309
3310 /*---------------------------------------------------------------------
3311 * Utility for back convertion to Scilab format
3312 * (can be used with GetListRhsVar )
3313 *---------------------------------------------------------------------*/
3314
3315 static void ConvertData(unsigned char *type, int size, int l)
3316 {
3317     int zero = 0, mu = -1;
3318     int laddr;
3319     int prov, m, n, it;
3320     double wsave;
3321
3322     switch (type[0])
3323     {
3324         case 'c':
3325             C2F(cvstr1) (&size, (int *)cstk(l), cstk(l), &zero, size);
3326             break;
3327         case 'r':
3328             C2F(rea2db) (&size, sstk(l), &mu, (double *)sstk(l), &mu);
3329             break;
3330         case 'i':
3331             C2F(int2db) (&size, istk(l), &mu, (double *)istk(l), &mu);
3332             break;
3333         case 'z':
3334             if (*istk(iadr(iadr(l)) - 2) == 133)
3335             {
3336                 /* values @ even adress */
3337                 prov = *istk(iadr(iadr(l)) - 1);
3338                 m = *istk(prov);
3339                 n = *istk(prov + 1);
3340                 it = 1;
3341                 laddr = iadr(l);
3342                 wsave = *stk(laddr);
3343                 /* make header */
3344                 *istk(iadr(iadr(l)) - 2) = 1;
3345                 *istk(iadr(iadr(l)) - 1) = m;
3346                 *istk(iadr(iadr(l))) = n;
3347                 *istk(iadr(iadr(l)) + 1) = it;
3348                 /* convert values */
3349                 z2double(stk(laddr), stk(laddr + 1), m * n, m * n);
3350                 *stk(laddr + 1) = wsave;
3351             }
3352             else
3353             {
3354                 F77ToSci((double *)zstk(l), size, size);
3355             }
3356     }
3357 }
3358
3359 /*---------------------------------------------------------------------
3360 * Utility for checking properties
3361 *---------------------------------------------------------------------*/
3362
3363 static int check_prop(char *mes, int posi, int m)
3364 {
3365     if (m)
3366     {
3367         /* XXXX moduler 999 en fn des messages */
3368         Scierror(999, "%s: %s %s\n", Get_Iname(), ArgPosition(posi), mes);
3369         return FALSE;
3370     }
3371     return TRUE;
3372 }
3373
3374 int check_square(int posi, int m, int n)
3375 {
3376     return check_prop(_("should be square"), posi, m != n);
3377 }
3378
3379 int check_vector(int posi, int m, int n)
3380 {
3381     return check_prop(_("should be a vector"), posi, m != 1 && n != 1);
3382 }
3383
3384 int check_row(int posi, int m, int n)
3385 {
3386     return check_prop(_("should be a row vector"), posi, m != 1);
3387 }
3388
3389 int check_col(int posi, int m, int n)
3390 {
3391     return check_prop(_("should be a column vector"), posi, n != 1);
3392 }
3393
3394 int check_scalar(int posi, int m, int n)
3395 {
3396     return check_prop(_("should be a scalar"), posi, n != 1 || m != 1);
3397 }
3398
3399 int check_dims(int posi, int m, int n, int m1, int n1)
3400 {
3401     if (m != m1 || n != n1)
3402     {
3403         Scierror(999, _("%s: %s has wrong dimensions (%d,%d), expecting (%d,%d).\n"), Get_Iname(), ArgPosition(posi), m, n, m1, n1);
3404         return FALSE;
3405     }
3406     return TRUE;
3407 }
3408
3409 int check_one_dim(int posi, int dim, int val, int valref)
3410 {
3411     if (val != valref)
3412     {
3413         Scierror(999, _("%s: %s has wrong %s dimension (%d), expecting (%d).\n"), Get_Iname(), ArgPosition(posi),
3414                  (dim == 1) ? _("first") : _("second"), val, valref);
3415         return FALSE;
3416     }
3417     return TRUE;
3418 }
3419
3420 int check_length(int posi, int m, int m1)
3421 {
3422     if (m != m1)
3423     {
3424         Scierror(999, _("%s: %s has wrong length %d, expecting (%d).\n"), Get_Iname(), ArgPosition(posi), m, m1);
3425         return FALSE;
3426     }
3427     return TRUE;
3428 }
3429
3430 int check_same_dims(int i, int j, int m1, int n1, int m2, int n2)
3431 {
3432     if (m1 == m2 && n1 == n2)
3433         return TRUE;
3434     Scierror(999, _("%s: %s have incompatible dimensions (%dx%d) # (%dx%d)\n"), Get_Iname(), ArgsPosition(i, j), m1, n1, m2, n2);
3435     return FALSE;
3436 }
3437
3438 int check_dim_prop(int i, int j, int flag)
3439 {
3440     if (flag)
3441     {
3442         Scierror(999, _("%s: %s have incompatible dimensions.\n"), Get_Iname(), ArgsPosition(i, j));
3443         return FALSE;
3444     }
3445     return TRUE;
3446 }
3447
3448 static int check_list_prop(char *mes, int lpos, int posi, int m)
3449 {
3450     if (m)
3451     {
3452         Scierror(999, _("%s: %s should be a list with %d-element being %s.\n"), Get_Iname(), ArgPosition(posi), posi, mes);
3453         return FALSE;
3454     }
3455     return TRUE;
3456 }
3457
3458 int check_list_square(int lpos, int posi, int m, int n)
3459 {
3460     return check_list_prop(_("square"), lpos, posi, (m != n));
3461 }
3462
3463 int check_list_vector(int lpos, int posi, int m, int n)
3464 {
3465     return check_list_prop(_("a vector"), lpos, posi, m != 1 && n != 1);
3466 }
3467
3468 int check_list_row(int lpos, int posi, int m, int n)
3469 {
3470     return check_list_prop(_("a row vector"), lpos, posi, m != 1);
3471 }
3472
3473 int check_list_col(int lpos, int posi, int m, int n)
3474 {
3475     return check_list_prop(_("a column vector"), lpos, posi, n != 1);
3476 }
3477
3478 int check_list_scalar(int lpos, int posi, int m, int n)
3479 {
3480     return check_list_prop(_("a scalar"), lpos, posi, n != 1 || m != 1);
3481 }
3482
3483 int check_list_one_dim(int lpos, int posi, int dim, int val, int valref)
3484 {
3485     if (val != valref)
3486     {
3487         Scierror(999, _("%s: argument %d(%d) has wrong %s dimension (%d), expecting (%d).\n"), Get_Iname(), lpos, posi,
3488                  (dim == 1) ? _("first") : _("second"), val, valref);
3489         return FALSE;
3490     }
3491     return TRUE;
3492 }
3493
3494 /*---------------------------------------------------------------------
3495 * Utility for hand writen data extraction or creation
3496 *---------------------------------------------------------------------*/
3497
3498 int C2F(createdata) (int *lw, int n)
3499 {
3500     int lw1;
3501     char *fname = Get_Iname();
3502
3503     if (*lw > intersiz)
3504     {
3505         Scierror(999, _("%s: (%s) too many arguments in the stack edit stack.h and enlarge intersiz.\n"), fname, "createdata");
3506         return FALSE;
3507     }
3508     Nbvars = Max(*lw, Nbvars);
3509     lw1 = *lw + Top - Rhs;
3510     if (*lw < 0)
3511     {
3512         Scierror(999, _("%s: bad call to %s! (1rst argument).\n"), fname, "createdata");
3513         return FALSE;
3514     }
3515     if (!C2F(credata) (fname, &lw1, n, nlgh))
3516         return FALSE;
3517     C2F(intersci).ntypes[*lw - 1] = '$';
3518     C2F(intersci).iwhere[*lw - 1] = *Lstk(lw1);
3519     C2F(intersci).lad[*lw - 1] = *Lstk(lw1);
3520     return TRUE;
3521 }
3522
3523 /*---------------------------------------------------------------------
3524 * copyvarfromsciptr
3525 *     copy a Scilab variable given by
3526 *      - its first adress l in stk
3527 *      - its size n
3528 *    to the variable position  lw
3529 *----------------------------------------------------------------------*/
3530 int C2F(copyvarfromsciptr) (int lw, int n, int l)
3531 {
3532     int ret, un = 1;
3533
3534     if ((ret = C2F(createdata) (&lw, n)) == FALSE)
3535         return ret;
3536     C2F(unsfdcopy) (&n, stk(l), &un, stk(*Lstk(lw + Top - Rhs)), &un);
3537     return TRUE;
3538 }
3539
3540 void *GetVarPtr(int n)
3541 /* return  the pointer on the first int of the n th variable  data structure  */
3542 {
3543     int l1 = *Lstk(n + Top - Rhs);
3544     int *loci = (int *)stk(l1);
3545
3546     return loci;
3547 }
3548
3549 void *GetData(int lw)
3550 /* Usage: header = (int *) GetData(lw); header[0] = type of variable lw etc */
3551 {
3552     int lw1 = lw + Top - Rhs;
3553     int l1 = *Lstk(lw1);
3554     int *loci = (int *)stk(l1);
3555
3556     if (loci[0] < 0)
3557     {
3558         l1 = loci[1];
3559         loci = (int *)stk(l1);
3560     }
3561     C2F(intersci).ntypes[lw - 1] = '$';
3562     C2F(intersci).iwhere[lw - 1] = l1;
3563     C2F(intersci).lad[lw - 1] = l1;
3564     return loci;
3565 }
3566
3567 int GetDataSize(int lw)
3568 /* get memory used by the argument lw in double world etc */
3569 {
3570     int lw1 = lw + Top - Rhs;
3571     int l1 = *Lstk(lw1);
3572     int *loci = (int *)stk(l1);
3573     int n = *Lstk(lw1 + 1) - *Lstk(lw1);
3574
3575     if (loci[0] < 0)
3576     {
3577         l1 = loci[1];
3578         loci = (int *)stk(l1);
3579         n = loci[3];
3580     }
3581     return n;
3582 }
3583
3584 void *GetRawData(int lw)
3585 /* same as GetData BUT does not go to the pointed variable if lw is a reference */
3586 {
3587     int lw1 = lw + Top - Rhs;
3588     int l1 = *Lstk(lw1);
3589     int *loci = (int *)stk(l1);
3590
3591     C2F(intersci).ntypes[lw - 1] = '$';
3592     C2F(intersci).iwhere[lw - 1] = l1;
3593     /*  C2F(intersci).lad[lw - 1] = l1;  to be checked */
3594     return loci;
3595 }
3596
3597 void *GetDataFromName(char *name)
3598 /* usage:  header = (int *) GetDataFromName("pipo"); header[0] = type of variable pipo etc... */
3599 {
3600     void *header;
3601     int lw;
3602     int fin;
3603
3604     if (C2F(objptr) (name, &lw, &fin, (unsigned long)strlen(name)))
3605     {
3606         header = istk(iadr(*Lstk(fin)));
3607         return (void *)header;
3608     }
3609     else
3610     {
3611         Scierror(999, _("GetDataFromName: variable %s not found.\n"), name);
3612         return (void *)0;
3613     }
3614 }
3615
3616 int C2F(createreference) (int number, int pointed)
3617 /* variable number is created as a reference to variable pointed */
3618 {
3619     int offset;
3620     int point_ed;
3621     int *header;
3622
3623     CreateData(number, 4 * sizeof(int));
3624     header = GetRawData(number);
3625     offset = Top - Rhs;
3626     point_ed = offset + pointed;
3627     header[0] = -*istk(iadr(*Lstk(point_ed)));  /* reference : 1st entry (type) is opposite */
3628     header[1] = *Lstk(point_ed);    /* pointed adress */
3629     header[2] = point_ed;       /* pointed variable */
3630     header[3] = *Lstk(point_ed + 1) - *Lstk(point_ed);  /* size of pointed variable */
3631     C2F(intersci).ntypes[number - 1] = '-';
3632     return 1;
3633 }
3634
3635 int C2F(changetoref) (int number, int pointed)
3636 /* variable number is changed as a reference to variable pointed */
3637 {
3638     int offset;
3639     int point_ed;
3640     int *header;
3641
3642     header = GetRawData(number);
3643     offset = Top - Rhs;
3644     point_ed = offset + pointed;
3645     header[0] = -*istk(iadr(*Lstk(point_ed)));  /* reference : 1st entry (type) is opposite */
3646     header[1] = *Lstk(point_ed);    /* pointed adress */
3647     header[2] = pointed;        /* pointed variable */
3648     header[3] = *Lstk(point_ed + 1) - *Lstk(point_ed);  /* size of pointed variable */
3649     C2F(intersci).ntypes[number - 1] = '-';
3650     return 1;
3651 }
3652
3653 int C2F(createreffromname) (int number, char *name)
3654 /* variable number is created as a reference pointing to variable "name" */
3655 /* name must be an existing Scilab variable */
3656 {
3657     int *header;
3658     int lw;
3659     int fin;
3660
3661     CreateData(number, 4 * sizeof(int));
3662     header = (int *)GetData(number);
3663     if (C2F(objptr) (name, &lw, &fin, (unsigned long)strlen(name)))
3664     {
3665         header[0] = -*istk(iadr(*Lstk(fin)));   /* type of reference = - type of pointed variable */
3666         header[1] = lw;         /* pointed adress */
3667         header[2] = fin;        /* pointed variable */
3668         header[3] = *Lstk(fin + 1) - *Lstk(fin);    /*size of pointed variable */
3669         return 1;
3670     }
3671     else
3672     {
3673         Scierror(999, _("%s: Variable %s not found.\n"), "CreateRefFromName", name);
3674         return 0;
3675     }
3676 }
3677
3678 /*-------------------------------------------------------
3679 * protect the intersci common during recursive calls
3680 *-------------------------------------------------------*/
3681
3682 typedef struct inter_s_
3683 {
3684     int iwhere, nbrows, nbcols, itflag, ntypes, lad, ladc, lhsvar;
3685 } intersci_state;
3686
3687 typedef struct inter_l
3688 {
3689     intersci_state *state;
3690     int nbvars;
3691     struct inter_l *next;
3692 } intersci_list;
3693
3694 static intersci_list *L_intersci;
3695
3696 static int intersci_push(void)
3697 {
3698     int i;
3699     intersci_list *loc;
3700     intersci_state *new;
3701
3702     new = MALLOC(Nbvars * sizeof(intersci_state));
3703     if (new == 0)
3704         return 0;
3705     loc = MALLOC(sizeof(intersci_list));
3706     if (loc == NULL)
3707         return 0;
3708     loc->next = L_intersci;
3709     loc->state = new;
3710     loc->nbvars = Nbvars;
3711     for (i = 0; i < Nbvars; i++)
3712     {
3713         loc->state[i].iwhere = C2F(intersci).iwhere[i];
3714         loc->state[i].ntypes = C2F(intersci).ntypes[i];
3715         loc->state[i].lad = C2F(intersci).lad[i];
3716         loc->state[i].lhsvar = C2F(intersci).lhsvar[i];
3717     }
3718     L_intersci = loc;
3719     return 1;
3720 }
3721
3722 static void intersci_pop(void)
3723 {
3724     int i;
3725     intersci_list *loc = L_intersci;
3726
3727     if (loc == NULL)
3728         return;
3729     Nbvars = loc->nbvars;
3730     for (i = 0; i < Nbvars; i++)
3731     {
3732         C2F(intersci).iwhere[i] = loc->state[i].iwhere;
3733         C2F(intersci).ntypes[i] = loc->state[i].ntypes;
3734         C2F(intersci).lad[i] = loc->state[i].lad;
3735         C2F(intersci).lhsvar[i] = loc->state[i].lhsvar;
3736     }
3737     L_intersci = loc->next;
3738     FREE(loc->state);
3739     FREE(loc);
3740 }
3741
3742 /*
3743 static void intersci_show()
3744 {
3745 int i;
3746 fprintf(stderr,"======================\n");
3747 for ( i = 0 ; i < C2F(intersci).nbvars ; i++ )
3748 {
3749 fprintf(stderr,"%d %d %d\n",i,
3750 C2F(intersci).iwhere[i],
3751 C2F(intersci).ntypes[i]);
3752 }
3753 fprintf(stderr,"======================\n");
3754 }
3755
3756 */