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