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