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