Merge remote-tracking branch 'origin/master' into YaSp
[scilab.git] / scilab / modules / core / src / c / stack1.c
1 /*
2  * Scilab ( http://www.scilab.org/ ) - This file is part of Scilab
3  * Copyright (C) 1998-2002 - ENPC - Jean-Philippe Chancelier
4  * Copyright (C) 1998-2007 - INRIA - Serge STEER
5  * Copyright (C) 2004-2007 - INRIA - Allan CORNET
6  * Copyright (C) 2006-2008 - INRIA - Sylvestre LEDRU
7  *
8  * This file must be used under the terms of the CeCILL.
9  * This source file is licensed as described in the file COPYING, which
10  * you should have received as part of this distribution.  The terms
11  * are also available at
12  * http://www.cecill.info/licences/Licence_CeCILL_V2-en.txt
13  *
14  * Please note that piece of code will be rewrited for the Scilab 6 family
15  */
16 /*    Scilab Memory Management library (Stack API) */
17 #include <string.h>
18 #include "stack-c.h"
19 #include "stack1.h"
20 #include "stack2.h"
21 #include "sciprint.h"
22 #include "cvstr.h"
23 #include "localization.h"
24 #include "Scierror.h"
25 #include "do_error_number.h"
26
27 /* Table of constant values */
28
29 static int cx0 = 0;
30 static int cx1 = 1;
31 static int cx4 = 4;
32 static int c_true = TRUE;
33 static int c_false = FALSE;
34
35 /* Static function declarations ... Function only used here */
36 static int C2F(getwsmati) (char *fname, int *topk, int *spos, int *lw, int *m, int *n, int *ilr, int *ilrd, int *inlistx, int *nel,
37                            unsigned long fname_len);
38 static int C2F(gethmati) (char *fname, int *topk, int *spos, int *lw, int *m, int *n, int *lr, int *inlistx, int *nel, unsigned long fname_len);
39 static int C2F(getsmati) (char *fname, int *topk, int *spos, int *lw, int *m, int *n, int *i__, int *j, int *lr, int *nlr, int *inlist__, int *nel,
40                           unsigned long fname_len);
41 static int C2F(getpointeri) (char *fname, int *topk, int *spos, int *lw, int *lr, int *inlist__, int *nel, unsigned long fname_len);
42 static int C2F(getimati) (char *fname, int *topk, int *spos, int *lw, int *it, int *m, int *n, int *lr, int *inlistx, int *nel,
43                           long unsigned int fname_len);
44 static int C2F(getbmati) (char *fname, int *topk, int *spos, int *lw, int *m, int *n, int *lr, int *inlist__, int *nel, unsigned long fname_len);
45 static int C2F(cremati) (char *fname, int *stlw, int *it, int *m, int *n, int *lr, int *lc, int *flagx, unsigned long fname_len);
46 static int C2F(getmati) (char *fname, int *topk, int *spos, int *lw, int *it, int *m, int *n, int *lr, int *lc, int *inlistx, int *nel,
47                          unsigned long fname_len);
48 static int C2F(crebmati) (char *fname, int *stlw, int *m, int *n, int *lr, int *flagx, unsigned long fname_len);
49 static int C2F(crehmati) (char *fname, int *stlw, int *m, int *n, int *lr, int *flagx, unsigned long fname_len);
50 static int C2F(crepointeri) (char *fname, int *stlw, int *lr, int *flagx, unsigned long fname_len);
51 static int C2F(cresparsei) (char *fname, int *stlw, int *it, int *m, int *n, int *nel, int *mnel, int *icol, int *lr, int *lc,
52                             unsigned long fname_len);
53 static int C2F(getsparsei) (char *fname, int *topk, int *spos, int *lw, int *it, int *m, int *n, int *nel, int *mnel, int *icol, int *lr, int *lc,
54                             int *inlistx, int *nellist, unsigned long fname_len);
55
56 int C2F(getrsparse) (char *fname, int *topk, int *lw, int *m, int *n, int *nel, int *mnel, int *icol, int *lr, unsigned long fname_len);
57 int C2F(getlistsmat) (char *fname, int *topk, int *spos, int *lnum, int *m, int *n, int *ix, int *j, int *lr, int *nlr, unsigned long fname_len);
58 int cre_smat_from_str_i(char *fname, int *lw, int *m, int *n, char *Str[], unsigned long fname_len, int *rep);
59 int cre_sparse_from_ptr_i(char *fname, int *lw, int *m, int *n, SciSparse * S, unsigned long fname_len, int *rep);
60 int crelist_G(int *slw, int *ilen, int *lw, int type);
61
62 /**********************************************************************
63 * MATRICES
64 **********************************************************************/
65
66 /*------------------------------------------------------------------
67 * getlistmat :
68 *    checks that spos object is a list
69 *    checks that lnum-element of the list exists and is a matrix
70 *    extracts matrix information(it,m,n,lr,lc)
71 *     In  :
72 *       fname : name of calling function for error message
73 *       topk  : stack ref for error message
74 *       lw    : stack position
75 *     Out :
76 *       [it,m,n] matrix dimensions
77 *       lr : stk(lr+i-1)= real(a(i))
78 *       lc : stk(lc+i-1)= imag(a(i)) exists only if it==1
79 *------------------------------------------------------------------ */
80
81 int C2F(getlistmat) (char *fname, int *topk, int *spos, int *lnum, int *it, int *m, int *n, int *lr, int *lc, unsigned long fname_len)
82 {
83     int nv, ili;
84
85     if (C2F(getilist) (fname, topk, spos, &nv, lnum, &ili, fname_len) == FALSE)
86     {
87         return FALSE;
88     }
89
90     if (*lnum > nv)
91     {
92         Scierror(999, _("%s: argument %d should be a list of size at least %d.\n"), get_fname(fname, fname_len), Rhs + (*spos - *topk), *lnum);
93         return FALSE;
94     }
95     return C2F(getmati) (fname, topk, spos, &ili, it, m, n, lr, lc, &c_true, lnum, fname_len);
96 }
97
98 /*-------------------------------------------------------------------
99 * getmat :
100 *     check that object at position lw is a matrix
101 *     In  :
102 *       fname : name of calling function for error message
103 *       topk  : stack ref for error message
104 *       lw    : stack position ( ``in the top sense'' )
105 *     Out :
106 *       [it,m,n] matrix dimensions
107 *       lr : stk(lr+i-1)= real(a(i))
108 *       lc : stk(lc+i-1)= imag(a(i)) exists only if it==1
109 *------------------------------------------------------------------- */
110
111 int C2F(getmat) (char *fname, int *topk, int *lw, int *it, int *m, int *n, int *lr, int *lc, unsigned long fname_len)
112 {
113     return C2F(getmati) (fname, topk, lw, Lstk(*lw), it, m, n, lr, lc, &c_false, &cx0, fname_len);
114 }
115
116 /*------------------------------------------------------------------
117 * getrmat like getmat but we check for a real matrix
118 *------------------------------------------------------------------ */
119
120 int C2F(getrmat) (char *fname, int *topk, int *lw, int *m, int *n, int *lr, unsigned long fname_len)
121 {
122     int lc, it;
123
124     if (C2F(getmat) (fname, topk, lw, &it, m, n, lr, &lc, fname_len) == FALSE)
125     {
126         return FALSE;
127     }
128
129     if (it != 0)
130     {
131         Scierror(202, _("%s: Wrong type for argument %d: Real matrix expected.\n"), get_fname(fname, fname_len), Rhs + (*lw - *topk));
132         return FALSE;
133     }
134     return TRUE;
135 }
136
137 /* ------------------------------------------------------------------
138 * getcmat like getmat but we check for a complex matrix
139 *------------------------------------------------------------------ */
140
141 int C2F(getcmat) (char *fname, int *topk, int *lw, int *m, int *n, int *lr, unsigned long fname_len)
142 {
143     int lc, it;
144
145     if (C2F(getmat) (fname, topk, lw, &it, m, n, lr, &lc, fname_len) == FALSE)
146     {
147         return FALSE;
148     }
149
150     if (it != 1)
151     {
152         Scierror(202, _("%s: Wrong type for argument %d: Real matrix expected.\n"), get_fname(fname, fname_len), Rhs + (*lw - *topk));
153         return FALSE;
154     }
155     return TRUE;
156 }
157
158 /*------------------------------------------------------------------
159 * matsize :
160 *    like getmat but here m,n are given on entry
161 *    and we check that matrix is of size (m,n)
162 *------------------------------------------------------------------ */
163
164 int C2F(matsize) (char *fname, int *topk, int *lw, int *m, int *n, unsigned long fname_len)
165 {
166     int m1, n1, lc, it, lr;
167
168     if (C2F(getmat) (fname, topk, lw, &it, &m1, &n1, &lr, &lc, fname_len) == FALSE)
169     {
170         return FALSE;
171     }
172     if (*m != m1 || *n != n1)
173     {
174         Scierror(205, _("%s: Wrong size for argument %d: (%d,%d) expected.\n"), get_fname(fname, fname_len), Rhs + (*lw - *topk), *m, *n);
175         return FALSE;
176     }
177     return TRUE;
178 }
179
180 /*-------------------------------------------------------------------
181 * For internal use
182 *------------------------------------------------------------------- */
183
184 static int C2F(getmati) (char *fname, int *topk, int *spos, int *lw, int *it, int *m, int *n, int *lr, int *lc, int *inlistx, int *nel,
185                          unsigned long fname_len)
186 {
187     int il;
188
189     il = iadr(*lw);
190     if (*istk(il) < 0)
191     {
192         il = iadr(*istk(il + 1));
193     }
194     if (*istk(il) != 1)
195     {
196         if (*inlistx)
197         {
198             Scierror(999, _("%s: Wrong type for argument %d (List element: %d): Real or complex matrix expected.\n"), get_fname(fname, fname_len),
199                      Rhs + (*spos - *topk), *nel);
200         }
201         else
202         {
203             Scierror(201, _("%s: Wrong type for argument %d: Real or complex matrix expected.\n"), get_fname(fname, fname_len),
204                      Rhs + (*spos - *topk));
205         }
206         return FALSE;
207     }
208     *m = *istk(il + 1);
209     *n = *istk(il + 2);
210     *it = *istk(il + 3);
211     *lr = sadr(il + 4);
212     if (*it == 1)
213     {
214         *lc = *lr + *m * *n;
215     }
216     return TRUE;
217 }
218
219 /*----------------------------------------------------------
220 *  listcremat(top,numero,lw,....)
221 *      le numero ieme element de la liste en top doit etre un matrice
222 *      stockee a partir de Lstk(lw)
223 *      doit mettre a jour les pointeurs de la liste
224 *      ainsi que stk(top+1)
225 *      si l'element a creer est le dernier
226 *      lw est aussi mis a jour
227 *---------------------------------------------------------- */
228
229 int C2F(listcremat) (char *fname, int *lw, int *numi, int *stlw, int *it, int *m, int *n, int *lrs, int *lcs, unsigned long fname_len)
230 {
231     int ix1, il;
232
233     if (C2F(cremati) (fname, stlw, it, m, n, lrs, lcs, &c_true, fname_len) == FALSE)
234     {
235         return FALSE;
236     }
237
238     *stlw = *lrs + *m * *n * (*it + 1);
239     il = iadr(*Lstk(*lw));
240     ix1 = il + *istk(il + 1) + 3;
241     *istk(il + 2 + *numi) = *stlw - sadr(ix1) + 1;
242     if (*numi == *istk(il + 1))
243     {
244         *Lstk(*lw + 1) = *stlw;
245     }
246     return TRUE;
247 }
248
249 /*----------------------------------------------------------
250 *  cremat :
251 *   checks that a matrix [it,m,n] can be stored at position  lw
252 *   <<pointers>> to real and imaginary part are returned on success
253 *   In :
254 *     lw : position (entier)
255 *     it : type 0 ou 1
256 *     m, n dimensions
257 *   Out :
258 *     lr : stk(lr+i-1)= real(a(i))
259 *     lc : stk(lc+i-1)= imag(a(i)) exists only if it==1
260 *   Side effect : if matrix creation is possible
261 *     [it,m,n] are stored in Scilab stack
262 *     and lr and lc are returned
263 *     but stk(lr+..) and stk(lc+..) are unchanged
264 *---------------------------------------------------------- */
265
266 int C2F(cremat) (char *fname, int *lw, int *it, int *m, int *n, int *lr, int *lc, unsigned long fname_len)
267 {
268
269     if (*lw + 1 >= Bot)
270     {
271         Scierror(18, _("%s: Too many names.\n"), get_fname(fname, fname_len));
272         return FALSE;
273     }
274     if (C2F(cremati) (fname, Lstk(*lw), it, m, n, lr, lc, &c_true, fname_len) == FALSE)
275     {
276         return FALSE;
277     }
278     *Lstk(*lw + 1) = *lr + *m * *n * (*it + 1);
279     return TRUE;
280 }
281
282 /*-------------------------------------------------
283 * Similar to cremat but we only check for space
284 * no data is stored
285 *-------------------------------------------------*/
286
287 int C2F(fakecremat) (int *lw, int *it, int *m, int *n, int *lr, int *lc)
288 {
289     if (*lw + 1 >= Bot)
290     {
291         return FALSE;
292     }
293     if (C2F(cremati) ("cremat", Lstk(*lw), it, m, n, lr, lc, &c_false, 6L) == FALSE)
294     {
295         return FALSE;
296     }
297     *Lstk(*lw + 1) = *lr + *m * *n * (*it + 1);
298     return TRUE;
299 }
300
301 /*---------------------------------------------------------
302 * internal function used by cremat and listcremat
303 *---------------------------------------------------------- */
304 static int C2F(cremati) (char *fname, int *stlw, int *it, int *m, int *n, int *lr, int *lc, int *flagx, unsigned long fname_len)
305 {
306     int ix1;
307     int il;
308     double size = ((double) * m) * ((double) * n) * ((double)(*it + 1));
309
310     il = iadr(*stlw);
311     ix1 = il + 4;
312     Err = sadr(ix1) - *Lstk(Bot);
313     if ((double)Err > -size)
314     {
315         Scierror(17, _("%s: stack size exceeded (Use stacksize function to increase it).\n"), get_fname(fname, fname_len));
316         return FALSE;
317     };
318     if (*flagx)
319     {
320         *istk(il) = 1;
321         /* if m*n=0 then both dimensions are to be set to zero */
322         *istk(il + 1) = Min(*m, *m * *n);
323         *istk(il + 2) = Min(*n, *m * *n);
324         *istk(il + 3) = *it;
325     }
326     ix1 = il + 4;
327     *lr = sadr(ix1);
328     *lc = *lr + *m * *n;
329     return TRUE;
330 }
331
332 /*---------------------------------------------------------
333 *     same as cremat, but without test ( we are below bot)
334 *     and adding a call to putid
335 *     cree une variable de type matrice
336 *     de nom id
337 *     en lw : sans verification de place
338 *---------------------------------------------------------- */
339 int C2F(crematvar) (int *id, int *lw, int *it, int *m, int *n, double *rtab, double *itab)
340 {
341
342     /* Local variables */
343     int i__1;
344     static int lc, il, lr;
345     static int c__1 = 1;
346
347     /* Parameter adjustments */
348     --itab;
349     --rtab;
350     --id;
351
352     /* Function Body */
353     C2F(putid) (&C2F(vstk).idstk[*lw * 6 - 6], &id[1]);
354     il = C2F(vstk).lstk[*lw - 1] + C2F(vstk).lstk[*lw - 1] - 1;
355     *istk(il) = 1;
356     *istk(il + 1) = *m;
357     *istk(il + 2) = *n;
358     *istk(il + 3) = *it;
359     i__1 = il + 4;
360     lr = i__1 / 2 + 1;
361     lc = lr + *m * *n;
362     if (*lw < C2F(vstk).isiz)
363     {
364         i__1 = il + 4;
365         C2F(vstk).lstk[*lw] = i__1 / 2 + 1 + *m * *n * (*it + 1);
366     }
367     i__1 = *m * *n;
368     C2F(unsfdcopy) (&i__1, &rtab[1], &c__1, stk(lr), &c__1);
369     if (*it == 1)
370     {
371         i__1 = *m * *n;
372         C2F(unsfdcopy) (&i__1, &itab[1], &c__1, stk(lc), &c__1);
373     }
374     return 0;
375 }
376
377 /*---------------------------------------------------------
378 *     crebmat without check and call to putid
379 *---------------------------------------------------------- */
380 int C2F(crebmatvar) (int *id, int *lw, int *m, int *n, int *val)
381 {
382     /* Local variables */
383     static int il, lr;
384     int i__1;
385     static int c__1 = 1;
386
387     /* Parameter adjustments */
388     --val;
389     --id;
390
391     C2F(putid) (&C2F(vstk).idstk[*lw * 6 - 6], &id[1]);
392     il = C2F(vstk).lstk[*lw - 1] + C2F(vstk).lstk[*lw - 1] - 1;
393     *istk(il) = 4;
394     *istk(il + 1) = *m;
395     *istk(il + 2) = *n;
396     lr = il + 3;
397     i__1 = il + 3 + *m * *n + 2;
398     C2F(vstk).lstk[*lw] = i__1 / 2 + 1;
399     i__1 = *m * *n;
400     C2F(icopy) (&i__1, &val[1], &c__1, istk(lr), &c__1);
401     return 0;
402 }
403
404 /*---------------------------------------------------------
405 *     cresmatvar without check and call to putid
406 *---------------------------------------------------------- */
407 int C2F(cresmatvar) (int *id, int *lw, char *str, int *lstr, unsigned long str_len)
408 {
409     static int il, mn, lr1, ix1, ilp;
410     static int ilast;
411     static int c__0 = 0;
412
413     /* Parameter adjustments */
414     --id;
415
416     C2F(putid) (&C2F(vstk).idstk[*lw * 6 - 6], &id[1]);
417     il = C2F(vstk).lstk[*lw - 1] + C2F(vstk).lstk[*lw - 1] - 1;
418     mn = 1;
419     ix1 = il + 4 + (*lstr + 1) + (mn + 1);
420     *istk(il) = 10;
421     *istk(il + 1) = 1;
422     *istk(il + 2) = 1;
423     *istk(il + 3) = 0;
424     ilp = il + 4;
425     *istk(ilp) = 1;
426     *istk(ilp + 1) = *istk(ilp) + *lstr;
427     ilast = ilp + mn;
428     lr1 = ilast + *istk(ilp);
429     C2F(cvstr) (lstr, istk(lr1), str, &c__0, str_len);
430     ix1 = ilast + *istk(ilast);
431     C2F(vstk).lstk[*lw] = ix1 / 2 + 1;
432     return 0;
433 }
434
435 /**********************************************************************
436 * INT MATRICES
437 **********************************************************************/
438
439 /* compute requested memory in number of ints */
440
441 #define memused(it,mn) ((((mn)*( it % 10))/sizeof(int))+1)
442
443 /*------------------------------------------------------------------
444 * getilistmat :
445 *    checks that spos object is a list
446 *    checks that lnum-element of the list exists and is an int matrix
447 *    extracts matrix information(it,m,n,lr)
448 *     In  :
449 *       fname : name of calling function for error message
450 *       topk  : stack ref for error message
451 *       lw    : stack position
452 *     Out :
453 *       [it,m,n] matrix dimensions
454 *       it : 1,2,4,11,12,14
455 *       lr : istk(lr+i-1)   : matrix data must be properly cast
456 *                             according to it value
457 *------------------------------------------------------------------ */
458
459 int C2F(getlistimat) (char *fname, int *topk, int *spos, int *lnum, int *it, int *m, int *n, int *lr, unsigned long fname_len)
460 {
461     int nv, ili;
462
463     if (C2F(getilist) (fname, topk, spos, &nv, lnum, &ili, fname_len) == FALSE)
464     {
465         return FALSE;
466     }
467
468     if (*lnum > nv)
469     {
470         Scierror(999, _("%s: Wrong type for argument %d: List of size at least %d expected.\n"), get_fname(fname, fname_len), Rhs + (*spos - *topk),
471                  *lnum);
472         return FALSE;
473     }
474     return C2F(getimati) (fname, topk, spos, &ili, it, m, n, lr, &c_true, lnum, fname_len);
475 }
476
477 /*-------------------------------------------------------------------
478 * getimat :
479 *     check that object at position lw is an int matrix
480 *     In  :
481 *       fname : name of calling function for error message
482 *       topk  : stack ref for error message
483 *       lw    : stack position ( ``in the top sense'' )
484 *     Out :
485 *       [it,m,n] matrix dimensions
486 *       lr : istk(lr+i-1)= a(i)
487 *------------------------------------------------------------------- */
488
489 int C2F(getimat) (char *fname, int *topk, int *lw, int *it, int *m, int *n, int *lr, unsigned long fname_len)
490 {
491     return C2F(getimati) (fname, topk, lw, Lstk(*lw), it, m, n, lr, &c_false, &cx0, fname_len);
492 }
493
494 /*-------------------------------------------------------------------
495 * For internal use
496 *------------------------------------------------------------------- */
497
498 static int C2F(getimati) (char *fname, int *topk, int *spos, int *lw, int *it, int *m, int *n, int *lr, int *inlistx, int *nel,
499                           unsigned long fname_len)
500 {
501     int il;
502
503     il = iadr(*lw);
504     if (*istk(il) < 0)
505     {
506         il = iadr(*istk(il + 1));
507     }
508     if (*istk(il) != 8)
509     {
510         if (*inlistx)
511             Scierror(999, _("%s: Wrong type for argument %d (List element: %d): Int matrix expected.\n"), get_fname(fname, fname_len),
512                      Rhs + (*spos - *topk), *nel);
513         else
514             Scierror(201, _("%s: Wrong type for argument %d: Real or complex matrix expected.\n"), get_fname(fname, fname_len),
515                      Rhs + (*spos - *topk));
516         return FALSE;
517     }
518     *m = *istk(il + 1);
519     *n = *istk(il + 2);
520     *it = *istk(il + 3);
521     *lr = il + 4;
522     return TRUE;
523 }
524
525 /*----------------------------------------------------------
526 *  listcreimat(top,numero,lw,....)
527 *      le numero ieme element de la liste en top doit etre un matrice
528 *      stockee a partir de Lstk(lw)
529 *      doit mettre a jour les pointeurs de la liste
530 *      ainsi que stk(top+1)
531 *      si l'element a creer est le dernier
532 *      lw est aussi mis a jour
533 *---------------------------------------------------------- */
534
535 int C2F(listcreimat) (char *fname, int *lw, int *numi, int *stlw, int *it, int *m, int *n, int *lrs, unsigned long fname_len)
536 {
537     int ix1, il;
538
539     if (C2F(creimati) (fname, stlw, it, m, n, lrs, &c_true, fname_len) == FALSE)
540     {
541         return FALSE;
542     }
543     *stlw = sadr(*lrs + memused(*it, *m * *n));
544     il = iadr(*Lstk(*lw));
545     ix1 = il + *istk(il + 1) + 3;
546     *istk(il + 2 + *numi) = *stlw - sadr(ix1) + 1;
547     if (*numi == *istk(il + 1))
548     {
549         *Lstk(*lw + 1) = *stlw;
550     }
551     return TRUE;
552 }
553
554 /*----------------------------------------------------------
555 *  creimat :
556 *   checks that an int matrix [it,m,n] can be stored at position  lw
557 *   <<pointers>> to real and imaginary part are returned on success
558 *   In :
559 *     lw : position (entier)
560 *     it : type 1,2,4,11,12,14
561 *     m, n dimensions
562 *   Out :
563 *     lr : istk(lr+i-1)=> a(i)
564 *   Side effect : if matrix creation is possible
565 *     [it,m,n] are stored in Scilab stack
566 *     and lr is returned
567 *     but stk(lr+..) are unchanged
568 *---------------------------------------------------------- */
569
570 int C2F(creimat) (char *fname, int *lw, int *it, int *m, int *n, int *lr, unsigned long fname_len)
571 {
572
573     if (*lw + 1 >= Bot)
574     {
575         Scierror(18, _("%s: Too many names.\n"), get_fname(fname, fname_len));
576         return FALSE;
577     }
578     if (C2F(creimati) (fname, Lstk(*lw), it, m, n, lr, &c_true, fname_len) == FALSE)
579     {
580         return FALSE;
581     }
582     *Lstk(*lw + 1) = sadr(*lr + memused(*it, *m * *n));
583     return TRUE;
584 }
585
586 /*---------------------------------------------------------
587 * internal function used by cremat and listcremat
588 *---------------------------------------------------------- */
589
590 int C2F(creimati) (char *fname, int *stlw, int *it, int *m, int *n, int *lr, int *flagx, unsigned long fname_len)
591 {
592     int ix1;
593     int il;
594     double size = memused(*it, ((double) * m) * ((double) * n));
595
596     il = iadr(*stlw);
597     ix1 = il + 4;
598     Err = sadr(ix1) - *Lstk(Bot);
599     if (Err > -size)
600     {
601         Scierror(17, _("%s: stack size exceeded (Use stacksize function to increase it).\n"), get_fname(fname, fname_len));
602         return FALSE;
603     };
604     if (*flagx)
605     {
606         *istk(il) = 8;
607         /* if m*n=0 then both dimensions are to be set to zero */
608         *istk(il + 1) = Min(*m, *m * *n);
609         *istk(il + 2) = Min(*n, *m * *n);
610         *istk(il + 3) = *it;
611     }
612     ix1 = il + 4;
613     *lr = ix1;
614     return TRUE;
615 }
616
617 /**********************************************************************
618 * BOOLEAN MATRICES
619 **********************************************************************/
620
621 /*------------------------------------------------------------------
622 * getlistbmat :
623 *    checks that spos object is a list
624 *    checks that lnum-element of the list exists and is a boolean matrix
625 *    extracts matrix information(m,n,lr)
626 *------------------------------------------------------------------ */
627
628 int C2F(getlistbmat) (char *fname, int *topk, int *spos, int *lnum, int *m, int *n, int *lr, unsigned long fname_len)
629 {
630     int nv;
631     int ili;
632
633     if (C2F(getilist) (fname, topk, spos, &nv, lnum, &ili, fname_len) == FALSE)
634     {
635         return FALSE;
636     }
637
638     if (*lnum > nv)
639     {
640         Scierror(999, _("%s: Wrong size for argument %d: At least %d expected.\n"), get_fname(fname, fname_len), Rhs + (*spos - *topk), *lnum);
641         return FALSE;
642     }
643
644     return C2F(getbmati) (fname, topk, spos, &ili, m, n, lr, &c_true, lnum, fname_len);
645 }
646
647 /*-------------------------------------------------------------------
648 * getbmat :
649 *     check that object at position lw is a boolean matrix
650 *     In  :
651 *       fname : name of calling function for error message
652 *       lw    : stack position
653 *     Out :
654 *       [m,n] matrix dimensions
655 *       lr : istk(lr+i-1)= a(i)
656 *------------------------------------------------------------------- */
657
658 int C2F(getbmat) (char *fname, int *topk, int *lw, int *m, int *n, int *lr, unsigned long fname_len)
659 {
660     return C2F(getbmati) (fname, topk, lw, Lstk(*lw), m, n, lr, &c_false, &cx0, fname_len);
661 }
662
663 /*------------------------------------------------------------------
664 * matbsize :
665 *    like getbmat but here m,n are given on entry
666 *    and we check that matrix is of size (m,n)
667 *------------------------------------------------------------------ */
668
669 int C2F(matbsize) (char *fname, int *topk, int *lw, int *m, int *n, unsigned long fname_len)
670 {
671     int m1, n1, lr;
672
673     if (C2F(getbmat) (fname, topk, lw, &m1, &n1, &lr, fname_len) == FALSE)
674     {
675         return FALSE;
676     }
677     if (*m != m1 || *n != n1)
678     {
679         Scierror(205, _("%s: Wrong size for argument %d: (%d,%d) expected.\n"), get_fname(fname, fname_len), Rhs + (*lw - *topk), *m, *n);
680         return FALSE;
681     }
682     return TRUE;
683 }
684
685 /*-------------------------------------------------------------------
686 * For internal use
687 *------------------------------------------------------------------- */
688
689 static int C2F(getbmati) (char *fname, int *topk, int *spos, int *lw, int *m, int *n, int *lr, int *inlistx, int *nel, unsigned long fname_len)
690 {
691     int il;
692
693     il = iadr(*lw);
694     if (*istk(il) < 0)
695     {
696         il = iadr(*istk(il + 1));
697     }
698
699     if (*istk(il) != 4)
700     {
701         if (*inlistx)
702             Scierror(999, _("%s: Wrong type for argument %d (List element: %d): Boolean matrix expected.\n"), get_fname(fname, fname_len),
703                      Rhs + (*spos - *topk), *nel);
704         else
705         {
706             Scierror(208, _("%s: Wrong type for argument #%d: Boolean matrix expected.\n"), get_fname(fname, fname_len), Rhs + (*spos - *topk));
707         }
708         return FALSE;
709     };
710     *m = *istk(il + 1);
711     *n = *istk(il + 2);
712     *lr = il + 3;
713     return TRUE;
714 }
715
716 /*------------------------------------------------==
717 *      listcrebmat(top,numero,lw,....)
718 *      le numero ieme element de la liste en top doit etre un bmatrice
719 *      stockee a partir de Lstk(lw)
720 *      doit mettre a jour les pointeurs de la liste
721 *      ainsi que stk(top+1)
722 *      si l'element a creer est le dernier
723 *      lw est aussi mis a jour
724 *---------------------------------------------------------- */
725
726 int C2F(listcrebmat) (char *fname, int *lw, int *numi, int *stlw, int *m, int *n, int *lrs, unsigned long fname_len)
727 {
728     int ix1;
729     int il;
730
731     if (C2F(crebmati) (fname, stlw, m, n, lrs, &c_true, fname_len) == FALSE)
732     {
733         return FALSE;
734     }
735
736     ix1 = *lrs + *m * *n + 2;
737     *stlw = sadr(ix1);
738     il = iadr(*Lstk(*lw));
739     ix1 = il + *istk(il + 1) + 3;
740     *istk(il + 2 + *numi) = *stlw - sadr(ix1) + 1;
741     if (*numi == *istk(il + 1))
742     {
743         *Lstk(*lw + 1) = *stlw;
744     }
745     return TRUE;
746 }
747
748 /*----------------------------------------------------------
749 *  crebmat :
750 *   checks that a boolean matrix [m,n] can be stored at position  lw
751 *   <<pointers>> to data is returned on success
752 *   In :
753 *     lw : position (entier)
754 *     m, n dimensions
755 *   Out :
756 *     lr : istk(lr+i-1)= a(i)
757 *   Side effect : if matrix creation is possible
758 *     [m,n] are stored in Scilab stack
759 *     and lr is  returned
760 *     but istk(lr+..) is unchanged
761 *---------------------------------------------------------- */
762
763 int C2F(crebmat) (char *fname, int *lw, int *m, int *n, int *lr, unsigned long fname_len)
764 {
765     int ix1;
766
767     if (*lw + 1 >= Bot)
768     {
769         Scierror(18, _("%s: Too many names.\n"), get_fname(fname, fname_len));
770         return FALSE;
771     }
772
773     if (C2F(crebmati) (fname, Lstk(*lw), m, n, lr, &c_true, fname_len) == FALSE)
774     {
775         return FALSE;
776     }
777
778     ix1 = *lr + *m * *n + 3;
779     *Lstk(*lw + 1) = sadr(ix1);
780     return TRUE;
781 }
782
783 /*-------------------------------------------------
784 * Similar to crebmat but we only check for space
785 * no data is stored
786 *-------------------------------------------------*/
787
788 int C2F(fakecrebmat) (int *lw, int *m, int *n, int *lr)
789 {
790     if (*lw + 1 >= Bot)
791     {
792         Scierror(18, _("%s: Too many names.\n"), "fakecrebmat");
793         return FALSE;
794     }
795     if (C2F(crebmati) ("crebmat", Lstk(*lw), m, n, lr, &c_false, 7L) == FALSE)
796     {
797         return FALSE;
798     }
799     *Lstk(*lw + 1) = sadr(*lr + *m * *n + 3);
800     return TRUE;
801 }
802
803 /*---------------------------------------------------------
804 * internal function used by crebmat and listcrebmat
805 *---------------------------------------------------------- */
806
807 static int C2F(crebmati) (char *fname, int *stlw, int *m, int *n, int *lr, int *flagx, unsigned long fname_len)
808 {
809     double size = ((double) * m) * ((double) * n);
810     int il;
811
812     il = iadr(*stlw);
813     Err = il + 3 - iadr(*Lstk(Bot));
814     if (Err > -size)
815     {
816         Scierror(17, _("%s: stack size exceeded (Use stacksize function to increase it).\n"), get_fname(fname, fname_len));
817         return FALSE;
818     }
819     if (*flagx)
820     {
821         *istk(il) = 4;
822         /*     si m*n=0 les deux dimensions sont mises a zero. */
823         *istk(il + 1) = Min(*m, *m * *n);
824         *istk(il + 2) = Min(*n, *m * *n);
825     }
826     *lr = il + 3;
827     return TRUE;
828 }
829
830 /**********************************************************************
831 * SPARSE MATRICES
832 *       [it,m,n,nel,mnel,icol,lr,lc]
833 *       nel : number of non nul elements
834 *       istk(mnel+i-1), i=1,m : number of non nul elements of row i
835 *       non nul elements are stored in row order as follows:
836 *       istk(icol+j-1) ,j=1,nel, column of the j-th non null element
837 *       stk(lr + j-1)  ,j=1,nel, real value of the j-th non null element
838 *       stk(lc + j-1)  ,j=1,nel, imag. value of the j-th non null element
839 *       lc is to be used only if matrix is complex (it==1)
840 **********************************************************************/
841
842 /*------------------------------------------------------------------
843 * getlistsparse :
844 *    checks that spos object is a list
845 *    checks that lnum-element of the list exists and is a sparse matrix
846 *    extracts matrix information(it,m,n,nel,mnel,icol,lr,lc)
847 *------------------------------------------------------------------ */
848
849 int C2F(getlistsparse) (char *fname, int *topk, int *spos, int *lnum, int *it, int *m, int *n, int *nel, int *mnel, int *icol, int *lr, int *lc,
850                         unsigned long fname_len)
851 {
852     int nv;
853     int ili;
854
855     if (C2F(getilist) (fname, topk, spos, &nv, lnum, &ili, fname_len) == FALSE)
856     {
857         return FALSE;
858     }
859
860     if (*lnum > nv)
861     {
862         Scierror(999, _("%s: Wrong size for argument %d: At least %d expected.\n"), get_fname(fname, fname_len), Rhs + (*spos - *topk), *lnum);
863         return FALSE;
864     }
865
866     return C2F(getsparsei) (fname, topk, spos, &ili, it, m, n, nel, mnel, icol, lr, lc, &c_true, lnum, fname_len);
867
868 }
869
870 /*-------------------------------------------------------------------
871 * getsparse :
872 *     check that object at position lw is a sparse matrix
873 *     In  :
874 *       fname : name of calling function for error message
875 *       lw    : stack position
876 *     Out :
877 *       [it,m,n,nel,mnel,icol,lr,lc] matrix dimensions
878 *------------------------------------------------------------------- */
879
880 int C2F(getsparse) (char *fname, int *topk, int *lw, int *it, int *m, int *n, int *nel, int *mnel, int *icol, int *lr, int *lc,
881                     unsigned long fname_len)
882 {
883     return C2F(getsparsei) (fname, topk, lw, Lstk(*lw), it, m, n, nel, mnel, icol, lr, lc, &c_false, &cx0, fname_len);
884 }
885
886 /*-------------------------------------------------------------------
887 * getrsparse : lie getsparse but we check for a real matrix
888 *------------------------------------------------------------------- */
889
890 int C2F(getrsparse) (char *fname, int *topk, int *lw, int *m, int *n, int *nel, int *mnel, int *icol, int *lr, unsigned long fname_len)
891 {
892     int lc, it;
893
894     if (C2F(getsparse) (fname, topk, lw, &it, m, n, nel, mnel, icol, lr, &lc, fname_len) == FALSE)
895     {
896         return FALSE;
897     }
898
899     if (it != 0)
900     {
901         Scierror(202, _("%s: Wrong type for argument %d: Real matrix expected.\n"), get_fname(fname, fname_len), Rhs + (*lw - *topk));
902         return FALSE;
903     }
904     return TRUE;
905 }
906
907 /*---------------------------------------
908 * internal function for getmat and listgetmat
909 *--------------------------------------- */
910
911 static int C2F(getsparsei) (char *fname, int *topk, int *spos, int *lw, int *it, int *m, int *n, int *nel, int *mnel, int *icol, int *lr, int *lc,
912                             int *inlistx, int *nellist, unsigned long fname_len)
913 {
914     int il;
915
916     il = iadr(*lw);
917     if (*istk(il) < 0)
918     {
919         il = iadr(*istk(il + 1));
920     }
921
922     if (*istk(il) != sci_sparse)
923     {
924         if (*inlistx)
925             Scierror(999, _("%s: Wrong type for argument %d (List element: %d): Sparse matrix expected.\n"), get_fname(fname, fname_len),
926                      Rhs + (*spos - *topk), *nellist);
927         else
928         {
929             Scierror(999, _("%s: Wrong type for argument #%d: Sparse matrix expected.\n"), get_fname(fname, fname_len), Rhs + (*spos - *topk));
930         }
931         return FALSE;
932     }
933     *m = *istk(il + 1);
934     *n = *istk(il + 2);
935     *it = *istk(il + 3);
936     *nel = *istk(il + 4);
937     *mnel = il + 5;
938     *icol = il + 5 + *m;
939     *lr = sadr(il + 5 + *m + *nel);
940     if (*it == 1)
941     {
942         *lc = *lr + *nel;
943     }
944     return TRUE;
945 }
946
947 /*----------------------------------------------------------
948 *      le numero ieme element de la liste en top doit etre une matrice
949 *      sparse stockee a partir de Lstk(lw)
950 *      doit mettre a jour les pointeurs de la liste
951 *      ainsi que stk(top+1)
952 *      si l'element a creer est le dernier
953 *      lw est aussi mis a jour
954 *
955 *---------------------------------------------------------- */
956
957 int C2F(listcresparse) (char *fname, int *lw, int *numi, int *stlw, int *it, int *m, int *n, int *nel, int *mnel, int *icol, int *lrs, int *lcs,
958                         unsigned long fname_len)
959 {
960     int ix1, il;
961
962     if (C2F(cresparsei) (fname, stlw, it, m, n, nel, mnel, icol, lrs, lcs, fname_len) == FALSE)
963     {
964         return FALSE;
965     }
966
967     *stlw = *lrs + *nel * (*it + 1);
968     il = iadr(*Lstk(*lw));
969     ix1 = il + *istk(il + 1) + 3;
970     *istk(il + 2 + *numi) = *stlw - sadr(ix1) + 1;
971     if (*numi == *istk(il + 1))
972     {
973         *Lstk(*lw + 1) = *stlw;
974     }
975     return TRUE;
976 }
977
978 /*----------------------------------------------------------
979 *  cresparse :
980 *   checks that a sparse matrix [it,m,n,nel,mnel,icol] can be stored at position  lw
981 *   <<pointers>> to real and imaginary part are returned on success
982 *   In :
983 *     lw : position (entier)
984 *     it : type 0 ou 1
985 *     m, n,nel  dimensions
986 *   Out :
987 *     mnel,icol,lr,lc
988 *   Side effect : if matrix creation is possible
989 *     [it,m,n,nel] are stored in Scilab stack
990 *     and mnel,icol,lr and lc are returned
991 *     but data is unchanged
992 *---------------------------------------------------------- */
993
994 int C2F(cresparse) (char *fname, int *lw, int *it, int *m, int *n, int *nel, int *mnel, int *icol, int *lr, int *lc, unsigned long fname_len)
995 {
996     if (*lw + 1 >= Bot)
997     {
998         Scierror(18, _("%s: Too many names.\n"), get_fname(fname, fname_len));
999         return FALSE;
1000     }
1001
1002     if (C2F(cresparsei) (fname, Lstk(*lw), it, m, n, nel, mnel, icol, lr, lc, fname_len) == FALSE)
1003     {
1004         return FALSE;
1005     }
1006     *Lstk(*lw + 1) = *lr + *nel * (*it + 1);
1007     return TRUE;
1008 }
1009
1010 /*---------------------------------------------------------
1011 * internal function used by cremat and listcremat
1012 *---------------------------------------------------------- */
1013
1014 static int C2F(cresparsei) (char *fname, int *stlw, int *it, int *m, int *n, int *nel, int *mnel, int *icol, int *lr, int *lc,
1015                             unsigned long fname_len)
1016 {
1017     int il, ix1;
1018
1019     il = iadr(*stlw);
1020     ix1 = il + 5 + *m + *nel;
1021     Err = sadr(ix1) + *nel * (*it + 1) - *Lstk(Bot);
1022     if (Err > 0)
1023     {
1024         Scierror(17, _("%s: stack size exceeded (Use stacksize function to increase it).\n"), get_fname(fname, fname_len));
1025         return FALSE;
1026     };
1027     *istk(il) = sci_sparse;
1028     /*   if m*n=0 the 2 dims are set to zero */
1029     if (*m == 0 || *n == 0)     /* use this new test in place of the product m * n (bruno) */
1030     {
1031         *istk(il + 1) = 0;
1032         *istk(il + 2) = 0;
1033     }
1034     else
1035     {
1036         *istk(il + 1) = *m;
1037         *istk(il + 2) = *n;
1038     }
1039     *istk(il + 3) = *it;
1040     *istk(il + 4) = *nel;
1041     *mnel = il + 5;
1042     *icol = il + 5 + *m;
1043     ix1 = il + 5 + *m + *nel;
1044     *lr = sadr(ix1);
1045     *lc = *lr + *nel;
1046     return TRUE;
1047 }
1048
1049 /**********************************************************************
1050 * VECTORS
1051 **********************************************************************/
1052
1053 /*------------------------------------------------------------------
1054 * getlistvect :
1055 *    checks that spos object is a list
1056 *    checks that lnum-element of the list exists and is a vector
1057 *    extracts vector information(it,m,n,lr,lc)
1058 *------------------------------------------------------------------ */
1059
1060 int C2F(getlistvect) (char *fname, int *topk, int *spos, int *lnum, int *it, int *m, int *n, int *lr, int *lc, unsigned long fname_len)
1061 {
1062     if (C2F(getlistmat) (fname, topk, spos, lnum, it, m, n, lr, lc, fname_len) == FALSE)
1063     {
1064         return FALSE;
1065     }
1066
1067     if (*m != 1 && *n != 1)
1068     {
1069         Scierror(999, _("%s: Wrong type for argument %d (List element: %d): Vector expected.\n"), get_fname(fname, fname_len), Rhs + (*spos - *topk),
1070                  *lnum);
1071         return FALSE;
1072     }
1073     return TRUE;
1074 }
1075
1076 /*-------------------------------------------------------------------
1077 * getvect :
1078 *     check that object at position lw is a vector
1079 *     In  :
1080 *       fname : name of calling function for error message
1081 *       lw    : stack position
1082 *     Out :
1083 *       [it,m,n] matrix dimensions
1084 *       lr : stk(lr+i-1)= real(a(i))
1085 *       lc : stk(lc+i-1)= imag(a(i)) exists only if it==1
1086 *------------------------------------------------------------------- */
1087
1088 int C2F(getvect) (char *fname, int *topk, int *lw, int *it, int *m, int *n, int *lr, int *lc, unsigned long fname_len)
1089 {
1090     if (C2F(getmat) (fname, topk, lw, it, m, n, lr, lc, fname_len) == FALSE)
1091     {
1092         return FALSE;
1093     }
1094
1095     if (*m != 1 && *n != 1)
1096     {
1097         Scierror(214, _("%s: Wrong type for argument %d: Vector expected.\n"), get_fname(fname, fname_len), Rhs + (*lw - *topk));
1098         return FALSE;
1099     };
1100     return TRUE;
1101 }
1102
1103 /*------------------------------------------------------------------
1104 * getrvect : like getvect but we expect a real vector
1105 *------------------------------------------------------------------ */
1106
1107 int C2F(getrvect) (char *fname, int *topk, int *lw, int *m, int *n, int *lr, unsigned long fname_len)
1108 {
1109     if (C2F(getrmat) (fname, topk, lw, m, n, lr, fname_len) == FALSE)
1110     {
1111         return FALSE;
1112     }
1113
1114     if (*m != 1 && *n != 1)
1115     {
1116         Scierror(203, _("%s: Wrong type for argument %d: Real vector expected.\n"), get_fname(fname, fname_len), Rhs + (*lw - *topk));
1117         return FALSE;
1118     }
1119     return TRUE;
1120 }
1121
1122 /*------------------------------------------------------------------
1123 * vectsize :
1124 *    like getvect but here n is given on entry
1125 *    and we check that vector is of size (n)
1126 *------------------------------------------------------------------ */
1127
1128 int C2F(vectsize) (char *fname, int *topk, int *lw, int *n, unsigned long fname_len)
1129 {
1130     int m1, n1, lc, lr, it1;
1131
1132     if (C2F(getvect) (fname, topk, lw, &it1, &m1, &n1, &lr, &lc, fname_len) == FALSE)
1133     {
1134         return FALSE;
1135     }
1136
1137     if (*n != m1 * n1)
1138     {
1139         Scierror(206, _("%s: Wrong size for argument %d: %d expected.\n"), get_fname(fname, fname_len), Rhs + (*lw - *topk), *n);
1140         return FALSE;
1141     }
1142     return TRUE;
1143 }
1144
1145 /**********************************************************************
1146 * SCALAR
1147 **********************************************************************/
1148
1149 /*------------------------------------------------------------------
1150 *     getlistscalar : recupere un scalaire
1151 *------------------------------------------------------------------ */
1152
1153 int C2F(getlistscalar) (char *fname, int *topk, int *spos, int *lnum, int *lr, unsigned long fname_len)
1154 {
1155     int m, n;
1156     int lc, it, nv;
1157     int ili;
1158
1159     if (C2F(getilist) (fname, topk, spos, &nv, lnum, &ili, fname_len) == FALSE)
1160     {
1161         return FALSE;
1162     }
1163
1164     if (*lnum > nv)
1165     {
1166         Scierror(999, _("%s: Wrong size for argument %d: At least %d expected.\n"), get_fname(fname, fname_len), Rhs + (*spos - *topk), *lnum);
1167         return FALSE;
1168     }
1169
1170     if (C2F(getmati) (fname, topk, spos, &ili, &it, &m, &n, lr, &lc, &c_true, lnum, fname_len) == FALSE)
1171     {
1172         return FALSE;
1173     }
1174
1175     if (m * n != 1)
1176     {
1177         Scierror(999, _("%s: Wrong type for argument %d (List element: %d): Scalar expected.\n"), get_fname(fname, fname_len), Rhs + (*spos - *topk),
1178                  *lnum);
1179         return FALSE;
1180     }
1181     return TRUE;
1182 }
1183
1184 /*------------------------------------------------------------------
1185 * getscalar :
1186 *     check that object at position lw is a scalar
1187 *     In  :
1188 *       fname : name of calling function for error message
1189 *       lw    : stack position
1190 *     Out :
1191 *       lr : stk(lr)= scalar_value
1192 *------------------------------------------------------------------ */
1193
1194 int C2F(getscalar) (char *fname, int *topk, int *lw, int *lr, unsigned long fname_len)
1195 {
1196     int m, n;
1197
1198     if (C2F(getrmat) (fname, topk, lw, &m, &n, lr, fname_len) == FALSE)
1199     {
1200         return FALSE;
1201     }
1202
1203     if (m * n != 1)
1204     {
1205         Scierror(204, _("%s: Wrong type for argument %d: Scalar, '%s' or '%s' expected.\n"), get_fname(fname, fname_len), Rhs + (*lw - *topk), "min",
1206                  "max");
1207         return FALSE;
1208     };
1209     return TRUE;
1210 }
1211
1212 /**********************************************************************
1213 * STRING and string Matrices
1214 **********************************************************************/
1215
1216 /*------------------------------------------------------------------
1217 * getlistsmat :
1218 *    checks that spos object is a list
1219 *    checks that lnum-element of the list exists and is a string matrix
1220 *    extracts string matrix information in m,n and (ix,j)-th string in lr nlr
1221 *     In  :
1222 *       fname : name of calling function for error message
1223 *       topk  : stack ref for error message
1224 *       spos  : stack position
1225 *       lnum  : element position in the list
1226 *       ix,j  : indices of the requested element
1227 *     Out :
1228 *       [m,n] : lnum smatrix dimensions
1229 *       lr  : istk(lr+i-1) gives string(ix,j) interbal codes
1230 *       nlr : length of (ix,j)-th string
1231 *------------------------------------------------------------------ */
1232
1233 int C2F(getlistsmat) (char *fname, int *topk, int *spos, int *lnum, int *m, int *n, int *ix, int *j, int *lr, int *nlr, unsigned long fname_len)
1234 {
1235     int nv, ili;
1236
1237     if (C2F(getilist) (fname, topk, spos, &nv, lnum, &ili, fname_len) == FALSE)
1238     {
1239         return FALSE;
1240     }
1241
1242     if (*lnum > nv)
1243     {
1244         Scierror(999, _("%s: Wrong size for argument %d: At least %d expected.\n"), get_fname(fname, fname_len), Rhs + (*spos - *topk), *lnum);
1245         return FALSE;
1246     }
1247     return C2F(getsmati) (fname, topk, spos, &ili, m, n, ix, j, lr, nlr, &c_true, lnum, fname_len);
1248 }
1249
1250 /*-------------------------------------------------------------------
1251 * getsmat :
1252 *     check that object at position lw is a string matrix
1253 *     In  :
1254 *       fname : name of calling function for error message
1255 *       lw    : stack position
1256 *       (ix,j): indices of the string element requested
1257 *     Out :
1258 *       [m,n] matrix dimensions
1259 *       lr  : istk(lr+i-1) gives string(ix,j) internal codes
1260 *       nlr : length of (ix,j)-th string
1261 * Note : getsmat can be used to get a(1,1) and check that a is a string matrix
1262 *        then other elements can be accessed through getsimat
1263 *------------------------------------------------------------------- */
1264
1265 int C2F(getsmat) (char *fname, int *topk, int *lw, int *m, int *n, int *ix, int *j, int *lr, int *nlr, unsigned long fname_len)
1266 {
1267     return C2F(getsmati) (fname, topk, lw, Lstk(*lw), m, n, ix, j, lr, nlr, &c_false, &cx0, fname_len);
1268 }
1269
1270 /*------------------------------------------------------------------
1271 * getsimat :
1272 *     In  :
1273 *       fname : name of calling function for error message
1274 *       lw    : stack position
1275 *       (ix,j): indices of the string element requested
1276 *     Out :
1277 *       [m,n] matrix dimensions
1278 *       lr  : istk(lr+i-1) gives string(ix,j) internal codes
1279 *       nlr : length of (ix,j)-th string
1280 * Note : like getsmat but do not check that object is a string matrix
1281 *------------------------------------------------------------------- */
1282
1283 int C2F(getsimat) (char *fname, int *topk, int *lw, int *m, int *n, int *ix, int *j, int *lr, int *nlr, unsigned long fname_len)
1284 {
1285     return C2F(getsimati) (fname, topk, lw, Lstk(*lw), m, n, ix, j, lr, nlr, &c_false, &cx0, fname_len);
1286 }
1287
1288 /*--------------------------------------------------------------------------
1289 * getlistwsmat :
1290 *    similar to getlistsmat but returned values are different
1291 *       ilr  :
1292 *       ilrd :
1293 *    ilr and ilrd : internal coded versions of the strings
1294 *    which can be converted to C with ScilabMStr2CM (see stack2.c)
1295 *------------------------------------------------------------------ */
1296
1297 int C2F(getlistwsmat) (char *fname, int *topk, int *spos, int *lnum, int *m, int *n, int *ilr, int *ilrd, unsigned long fname_len)
1298 {
1299     int nv, ili;
1300
1301     if (C2F(getilist) (fname, topk, spos, &nv, lnum, &ili, fname_len) == FALSE)
1302     {
1303         return FALSE;
1304     }
1305
1306     if (*lnum > nv)
1307     {
1308         Scierror(999, _("%s: Wrong size for argument %d: At least %d expected.\n"), get_fname(fname, fname_len), Rhs + (*spos - *topk), *lnum);
1309         return FALSE;
1310     }
1311     return C2F(getwsmati) (fname, topk, spos, &ili, m, n, ilr, ilrd, &c_true, lnum, fname_len);
1312 }
1313
1314 /*--------------------------------------------------------------------------
1315 * getwsmat : checks for a mxn string matrix
1316 *    similar to getsmat but returned values are different
1317 *    ilr and ilrd : internal coded versions of the strings
1318 *    which can be converted to C with ScilabMStr2CM (see stack2.c)
1319 *--------------------------------------------------------------------------*/
1320
1321 int C2F(getwsmat) (char *fname, int *topk, int *lw, int *m, int *n, int *ilr, int *ilrd, unsigned long fname_len)
1322 {
1323     return C2F(getwsmati) (fname, topk, lw, Lstk(*lw), m, n, ilr, ilrd, &c_false, &cx0, fname_len);
1324 }
1325
1326 /*-------------------------------------------------------------------
1327 * For internal use
1328 *------------------------------------------------------------------- */
1329
1330 static int C2F(getwsmati) (char *fname, int *topk, int *spos, int *lw, int *m, int *n, int *ilr, int *ilrd, int *inlistx, int *nel,
1331                            unsigned long fname_len)
1332 {
1333     int il;
1334
1335     il = iadr(*lw);
1336     if (*istk(il) < 0)
1337     {
1338         il = iadr(*istk(il + 1));
1339     }
1340     if (*istk(il) != sci_strings)
1341     {
1342         if (*inlistx)
1343         {
1344             Scierror(999, _("%s: Wrong type for argument %d (List element: %d): Matrix of strings expected.\n"), get_fname(fname, fname_len),
1345                      Rhs + (*spos - *topk), *nel);
1346         }
1347         else
1348         {
1349             Scierror(207, _("%s: Wrong type for argument %d: Matrix of strings expected.\n"), get_fname(fname, fname_len), Rhs + (*spos - *topk));
1350         }
1351         return FALSE;
1352     }
1353     *m = *istk(il + 1);
1354     *n = *istk(il + 2);
1355     *ilrd = il + 4;
1356     *ilr = il + 5 + *m * *n;
1357     return TRUE;
1358 }
1359
1360 /*-------------------------------------------------------------------
1361 * For internal use
1362 *------------------------------------------------------------------- */
1363
1364 static int C2F(getsmati) (char *fname, int *topk, int *spos, int *lw, int *m, int *n, int *ix, int *j, int *lr, int *nlr, int *inlistx, int *nel,
1365                           unsigned long fname_len)
1366 {
1367     int il = iadr(*lw);
1368
1369     if (*istk(il) < 0)
1370     {
1371         il = iadr(*istk(il + 1));
1372     }
1373     if (*istk(il) != sci_strings)
1374     {
1375         if (*inlistx)
1376         {
1377             Scierror(999, _("%s: Wrong type for argument %d (List element: %d): String matrix expected.\n"), get_fname(fname, fname_len),
1378                      Rhs + (*spos - *topk), *nel);
1379         }
1380         else
1381         {
1382             Scierror(201, _("%s: Wrong type for argument %d: String matrix expected.\n"), get_fname(fname, fname_len), Rhs + (*spos - *topk));
1383         }
1384         return FALSE;
1385     }
1386     C2F(getsimati) (fname, topk, spos, lw, m, n, ix, j, lr, nlr, inlistx, nel, fname_len);
1387     return TRUE;
1388 }
1389
1390 int C2F(getsimati) (char *fname, int *topk, int *spos, int *lw, int *m, int *n, int *ix, int *j, int *lr, int *nlr, int *inlistx, int *nel,
1391                     unsigned long fname_len)
1392 {
1393     int k, il = iadr(*lw);
1394
1395     if (*istk(il) < 0)
1396     {
1397         il = iadr(*istk(il + 1));
1398     }
1399     *m = *istk(il + 1);
1400     *n = *istk(il + 2);
1401     k = *ix - 1 + (*j - 1) * *m;
1402     *lr = il + 4 + *m * *n + *istk(il + 4 + k);
1403     *nlr = *istk(il + 4 + k + 1) - *istk(il + 4 + k);
1404     return 0;
1405 }
1406
1407 /*----------------------------------------------------------
1408 *     listcresmat(top,numero,lw,....)
1409 *     le  ieme element de la liste en top doit etre une
1410 *     matrice stockee a partir de Lstk(lw)
1411 *     doit mettre a jour les pointeurs de la liste
1412 *     ainsi que Lstk(top+1) si l'element a creer est le dernier
1413 *     lw est aussi mis a jour
1414 *     job==1: nchar est la taille de chaque chaine de la  matrice
1415 *     job==2: nchar est le vecteur des tailles des chaines de la
1416 *             matrice
1417 *     job==3: nchar est le vecteur des pointeurs sur les chaines
1418 *             de la matrice
1419 *---------------------------------------------------------- */
1420
1421 int C2F(listcresmat) (char *fname, int *lw, int *numi, int *stlw, int *m, int *n, int *nchar, int *job, int *ilrs, unsigned long fname_len)
1422 {
1423     int ix1;
1424     int il, sz;
1425
1426     if (C2F(cresmati) (fname, stlw, m, n, nchar, job, ilrs, &sz, fname_len) == FALSE)
1427     {
1428         return FALSE;
1429     }
1430     ix1 = *ilrs + sz;
1431     *stlw = sadr(ix1);
1432     il = iadr(*Lstk(*lw));
1433     ix1 = il + *istk(il + 1) + 3;
1434     *istk(il + 2 + *numi) = *stlw - sadr(ix1) + 1;
1435     if (*numi == *istk(il + 1))
1436     {
1437         *Lstk(*lw + 1) = *stlw;
1438     }
1439     return TRUE;
1440 }
1441
1442 /*----------------------------------------------------------
1443 * cresmat :
1444 *   checks that a string matrix [m,n] of strings
1445 *   (each string is of length nchar)
1446 *   can be stored at position  lw on the stack
1447 * Note that each string can be filled with getsimat
1448 *---------------------------------------------------------- */
1449
1450 int C2F(cresmat) (char *fname, int *lw, int *m, int *n, int *nchar, unsigned long fname_len)
1451 {
1452     int job = 1;
1453     int ix1, ilast, sz, lr;
1454
1455     if (*lw + 1 >= Bot)
1456     {
1457         Scierror(18, _("%s: Too many names.\n"), get_fname(fname, fname_len));
1458         return FALSE;
1459     }
1460     if (C2F(cresmati) (fname, Lstk(*lw), m, n, nchar, &job, &lr, &sz, fname_len) == FALSE)
1461     {
1462         return FALSE;
1463     }
1464     ilast = lr - 1;
1465     ix1 = ilast + *istk(ilast);
1466     *Lstk(*lw + 1) = sadr(ix1);
1467     /* empty strings */
1468     if (*nchar == 0)
1469     {
1470         *Lstk(*lw + 1) += 1;
1471     }
1472     return TRUE;
1473 }
1474
1475 /*------------------------------------------------------------------
1476 *  cresmat1 :
1477 *   checks that a string matrix [m,1] of string of length nchar[i]
1478 *   can be stored at position  lw on the stack
1479 *   nchar : array of length m giving each string length
1480 *  Note that each string can be filled with getsimat
1481 *------------------------------------------------------------------ */
1482
1483 int C2F(cresmat1) (char *fname, int *lw, int *m, int *nchar, unsigned long fname_len)
1484 {
1485     int job = 2, n = 1;
1486     int ix1, ilast, sz, lr;
1487
1488     if (*lw + 1 >= Bot)
1489     {
1490         Scierror(18, _("%s: Too many names.\n"), get_fname(fname, fname_len));
1491         return FALSE;
1492     }
1493     if (C2F(cresmati) (fname, Lstk(*lw), m, &n, nchar, &job, &lr, &sz, fname_len) == FALSE)
1494     {
1495         return FALSE;
1496     }
1497     ilast = lr - 1;
1498     ix1 = ilast + *istk(ilast);
1499     *Lstk(*lw + 1) = sadr(ix1);
1500     return TRUE;
1501 }
1502
1503 /*------------------------------------------------------------------
1504 *  cresmat2 :
1505 *   checks that a string of length nchar can be stored at position  lw
1506 *  Out :
1507 *     lr : istk(lr+i) give access to the internal array
1508 *          allocated for string code
1509 *------------------------------------------------------------------ */
1510
1511 int C2F(cresmat2) (char *fname, int *lw, int *nchar, int *lr, unsigned long fname_len)
1512 {
1513     int job = 1, n = 1, m = 1;
1514     int ix1, ilast, sz;
1515
1516     if (*lw + 1 >= Bot)
1517     {
1518         Scierror(18, _("%s: Too many names.\n"), get_fname(fname, fname_len));
1519         return FALSE;
1520     }
1521     if (C2F(cresmati) (fname, Lstk(*lw), &m, &n, nchar, &job, lr, &sz, fname_len) == FALSE)
1522     {
1523         return FALSE;
1524     }
1525
1526     ilast = *lr - 1;
1527     ix1 = ilast + *istk(ilast);
1528     *Lstk(*lw + 1) = sadr(ix1);
1529     /* empty strings */
1530     if (*nchar == 0)
1531     {
1532         *Lstk(*lw + 1) += 1;
1533     }
1534     *lr = ilast + *istk(ilast - 1);
1535     return TRUE;
1536 }
1537
1538 /*------------------------------------------------------------------
1539 * cresmat3 :
1540 *   Try to create a string matrix S of size mxn
1541 *     - nchar: array of size mxn giving the length of string S(i,j)
1542 *     - buffer : a character array wich contains the concatenation
1543 *             of all the strings
1544 *     - lw  : stack position for string creation
1545 *------------------------------------------------------------------ */
1546
1547 int C2F(cresmat3) (char *fname, int *lw, int *m, int *n, int *nchar, char *buffer, unsigned long fname_len, unsigned long buffer_len)
1548 {
1549     int job = 2;
1550     int ix1, ilast, sz, lr, lr1;
1551
1552     if (*lw + 1 >= Bot)
1553     {
1554         Scierror(18, _("%s: Too many names.\n"), get_fname(fname, fname_len));
1555         return FALSE;
1556     }
1557     if (C2F(cresmati) (fname, Lstk(*lw), m, n, nchar, &job, &lr, &sz, fname_len) == FALSE)
1558     {
1559         return FALSE;
1560     }
1561     ilast = lr - 1;
1562     ix1 = ilast + *istk(ilast);
1563     *Lstk(*lw + 1) = sadr(ix1);
1564
1565     lr1 = ilast + *istk(ilast - (*m) * (*n));
1566     C2F(cvstr) (&sz, istk(lr1), buffer, &cx0, buffer_len);
1567     return TRUE;
1568 }
1569
1570 /*------------------------------------------------------------------
1571 *     checks that an [m,1] string matrix can be stored in the
1572 *     stack.
1573 *     All chains have the same length nchar
1574 *     istk(lr) --- beginning of chains
1575 *------------------------------------------------------------------ */
1576
1577 int C2F(cresmat4) (char *fname, int *lw, int *m, int *nchar, int *lr, unsigned long fname_len)
1578 {
1579     int ix1, ix, ilast, il, nnchar, kij, ilp;
1580
1581     if (*lw + 1 >= Bot)
1582     {
1583         Scierror(18, _("%s: Too many names.\n"), get_fname(fname, fname_len));
1584         return FALSE;
1585     }
1586     nnchar = 0;
1587     ix1 = *m;
1588     for (ix = 1; ix <= ix1; ++ix)
1589     {
1590         nnchar += *nchar;
1591     }
1592     il = iadr(*Lstk(*lw));
1593     ix1 = il + 4 + (nnchar + 1) * *m;
1594     Err = sadr(ix1) - *Lstk(Bot);
1595     if (Err > 0)
1596     {
1597         Scierror(17, _("%s: stack size exceeded (Use stacksize function to increase it).\n"), get_fname(fname, fname_len));
1598         return FALSE;
1599     }
1600     *istk(il) = sci_strings;
1601     *istk(il + 1) = *m;
1602     *istk(il + 2) = 1;
1603     *istk(il + 3) = 0;
1604     ilp = il + 4;
1605     *istk(ilp) = 1;
1606     ix1 = ilp + *m;
1607     for (kij = ilp + 1; kij <= ix1; ++kij)
1608     {
1609         *istk(kij) = *istk(kij - 1) + *nchar;
1610     }
1611     ilast = ilp + *m;
1612     ix1 = ilast + *istk(ilast);
1613     *Lstk(*lw + 1) = sadr(ix1);
1614     *lr = ilast + 1;
1615     return TRUE;
1616 }
1617
1618 /*---------------------------------------------------------
1619 * internal function used by cresmat cresmat1 and listcresmat
1620 * job :
1621 *   case 1: all string are of same length (nchar) in the matrix
1622 *   case 2: nchar is a vector which gives string lengthes
1623 *   case 3: ?
1624 *---------------------------------------------------------- */
1625
1626 int C2F(cresmati) (char *fname, int *stlw, int *m, int *n, int *nchar, int *job, int *lr, int *sz, unsigned long fname_len)
1627 {
1628     int ix1, ix, il, kij, ilp, mn = (*m) * (*n);
1629
1630     il = iadr(*stlw);
1631
1632     /* compute the size of chains */
1633     *sz = 0;
1634     switch (*job)
1635     {
1636         case 1:
1637             *sz = mn * nchar[0];
1638             break;
1639         case 2:
1640             for (ix = 0; ix < mn; ++ix)
1641             {
1642                 *sz += nchar[ix];
1643             }
1644             break;
1645         case 3:
1646             *sz = nchar[mn] - 1;
1647             break;
1648     }
1649     /* check the stack for space */
1650     ix1 = il + 4 + mn + 1 + *sz;
1651     Err = sadr(ix1) - *Lstk(Bot);
1652     if (Err > 0)
1653     {
1654         Scierror(17, _("%s: stack size exceeded (Use stacksize function to increase it).\n"), get_fname(fname, fname_len));
1655         return FALSE;
1656     };
1657
1658     *istk(il) = sci_strings;
1659     *istk(il + 1) = *m;
1660     *istk(il + 2) = *n;
1661     *istk(il + 3) = 0;
1662     ilp = il + 4;
1663     *istk(ilp) = 1;
1664     switch (*job)
1665     {
1666         case 1:
1667             ix1 = mn + ilp;
1668             for (kij = ilp + 1; kij <= ix1; ++kij)
1669             {
1670                 *istk(kij) = *istk(kij - 1) + nchar[0];
1671             }
1672             break;
1673         case 2:
1674             ix = 0;
1675             ix1 = mn + ilp;
1676             for (kij = ilp + 1; kij <= ix1; ++kij)
1677             {
1678                 *istk(kij) = *istk(kij - 2 + 1) + nchar[ix];
1679                 ++ix;
1680             }
1681             break;
1682         case 3:
1683         {
1684             ix1 = mn + 1;
1685             C2F(icopy) (&ix1, nchar, &cx1, istk(ilp), &cx1);
1686         }
1687     }
1688     *lr = ilp + mn + 1;
1689     return TRUE;
1690 }
1691
1692 /*------------------------------------------------------------------
1693 * Try to create a string matrix S of size mxn
1694 *     - m is the number of rows of Matrix S
1695 *     - n is the number of colums of Matrix S
1696 *     - Str : a null terminated array of strings char **Str assumed
1697 *             to contain at least m*n strings
1698 *     - lw  : where to create the matrix on the stack
1699 *------------------------------------------------------------------ */
1700
1701 int cre_smat_from_str_i(char *fname, int *lw, int *m, int *n, char *Str[], unsigned long fname_len, int *rep)
1702 {
1703     int ix1, ix, ilast, il, nnchar, lr1, kij, ilp;
1704     int *pos;
1705
1706     nnchar = 0;
1707     if (Str)
1708         for (ix = 0; ix < (*m) * (*n); ++ix)
1709         {
1710             nnchar += (int)strlen(Str[ix]);
1711         }
1712     else
1713     {
1714         nnchar = 0;
1715     }
1716
1717     il = iadr(*lw);
1718     ix1 = il + 4 + (nnchar + 1) + (*m * *n + 1);
1719     Err = sadr(ix1) - *Lstk(Bot);
1720     if (Err > 0)
1721     {
1722         Scierror(17, _("%s: stack size exceeded (Use stacksize function to increase it).\n"), get_fname(fname, fname_len));
1723         return FALSE;
1724     };
1725     *istk(il) = sci_strings;
1726     *istk(il + 1) = *m;
1727     *istk(il + 2) = *n;
1728     *istk(il + 3) = 0;
1729     ilp = il + 4;
1730     *istk(ilp) = 1;
1731     ix = 0;
1732     ix1 = ilp + *m * *n;
1733     for (kij = ilp + 1; kij <= ix1; ++kij)
1734     {
1735         if (Str)
1736         {
1737             *istk(kij) = *istk(kij - 1) + (int)strlen(Str[ix]);
1738             ++ix;
1739         }
1740         else
1741         {
1742             *istk(kij) = *istk(kij - 1) + 0;
1743             ++ix;
1744         }
1745     }
1746     ilast = ilp + *m * *n;
1747     lr1 = ilast + *istk(ilp);
1748     pos = istk(lr1);
1749     if (Str)
1750     {
1751         for (ix = 0; ix < (*m) * (*n); ix++)
1752         {
1753             int l = (int)strlen(Str[ix]);
1754
1755             C2F(cvstr) (&l, pos, Str[ix], &cx0, l);
1756             pos += l;
1757         }
1758     }
1759     ix1 = ilast + *istk(ilast);
1760     *rep = sadr(ix1);
1761     return TRUE;
1762 }
1763
1764 int cre_smat_from_str(char *fname, int *lw, int *m, int *n, char *Str[], unsigned long fname_len)
1765 {
1766     int rep;
1767
1768     if (*lw + 1 >= Bot)
1769     {
1770         Scierror(18, _("%s: Too many names.\n"), get_fname(fname, fname_len));
1771         return FALSE;
1772     }
1773
1774     if (cre_smat_from_str_i(fname, Lstk(*lw), m, n, Str, fname_len, &rep) == FALSE)
1775     {
1776         return FALSE;
1777     }
1778     *Lstk(*lw + 1) = rep;
1779     return TRUE;
1780 }
1781
1782 int cre_listsmat_from_str(char *fname, int *lw, int *numi, int *stlw, int *m, int *n, char *Str[], unsigned long fname_len)
1783 {
1784     int rep, ix1, il;
1785
1786     if (cre_smat_from_str_i(fname, stlw, m, n, Str, fname_len, &rep) == FALSE)
1787     {
1788         return FALSE;
1789     }
1790     *stlw = rep;
1791     il = iadr(*Lstk(*lw));
1792     ix1 = il + *istk(il + 1) + 3;
1793     *istk(il + 2 + *numi) = *stlw - sadr(ix1) + 1;
1794     if (*numi == *istk(il + 1))
1795     {
1796         *Lstk(*lw + 1) = *stlw;
1797     }
1798     return TRUE;
1799 }
1800
1801 /*------------------------------------------------------------------
1802 * Try to create a sparse matrix S of size mxn
1803 *     - m is the number of rows of Matrix S
1804 *     - n is the number of colums of Matrix S
1805 *     - Str : a null terminated array of strings char **Str assumed
1806 *             to contain at least m*n strings
1807 *     - lw  : where to create the matrix on the stack
1808 *------------------------------------------------------------------ */
1809
1810 int cre_sparse_from_ptr_i(char *fname, int *lw, int *m, int *n, SciSparse * S, unsigned long fname_len, int *rep)
1811 {
1812     double size = (double)((S->nel) * (S->it + 1));
1813
1814     int ix1, il, lr, lc;
1815     int cx1l = 1;
1816
1817     il = iadr(*lw);
1818
1819     ix1 = il + 5 + *m + S->nel;
1820     Err = sadr(ix1) - *Lstk(Bot);
1821     if (Err > -size)
1822     {
1823         Scierror(17, _("%s: stack size exceeded (Use stacksize function to increase it).\n"), get_fname(fname, fname_len));
1824         return FALSE;
1825     };
1826     *istk(il) = sci_sparse;
1827     /* note: code sligtly modified (remark of C. Deroulers in the newsgroup) */
1828     if ((*m == 0) | (*n == 0))
1829     {
1830         *istk(il + 1) = 0;
1831         *istk(il + 2) = 0;
1832     }
1833     else
1834     {
1835         *istk(il + 1) = *m;
1836         *istk(il + 2) = *n;
1837     }
1838     /* end of the modified code */
1839     *istk(il + 3) = S->it;
1840     *istk(il + 4) = S->nel;
1841     C2F(icopy) (&S->m, S->mnel, &cx1l, istk(il + 5), &cx1l);
1842     C2F(icopy) (&S->nel, S->icol, &cx1l, istk(il + 5 + *m), &cx1l);
1843     ix1 = il + 5 + *m + S->nel;
1844     lr = sadr(ix1);
1845     lc = lr + S->nel;
1846     C2F(dcopy) (&S->nel, S->R, &cx1l, stk(lr), &cx1l);
1847     if (S->it == 1)
1848     {
1849         C2F(dcopy) (&S->nel, S->I, &cx1l, stk(lc), &cx1l);
1850     }
1851     *rep = lr + S->nel * (S->it + 1);
1852     return TRUE;
1853 }
1854
1855 int cre_sparse_from_ptr(char *fname, int *lw, int *m, int *n, SciSparse * Str, unsigned long fname_len)
1856 {
1857     int rep;
1858
1859     if (*lw + 1 >= Bot)
1860     {
1861         Scierror(18, _("%s: Too many names.\n"), get_fname(fname, fname_len));
1862         return FALSE;
1863     }
1864
1865     if (cre_sparse_from_ptr_i(fname, Lstk(*lw), m, n, Str, fname_len, &rep) == FALSE)
1866     {
1867         return FALSE;
1868     }
1869     *Lstk(*lw + 1) = rep;
1870     return TRUE;
1871 }
1872
1873 int cre_listsparse_from_ptr(char *fname, int *lw, int *numi, int *stlw, int *m, int *n, SciSparse * Str, unsigned long fname_len)
1874 {
1875     int rep, ix1, il;
1876
1877     if (cre_sparse_from_ptr_i(fname, stlw, m, n, Str, fname_len, &rep) == FALSE)
1878     {
1879         return FALSE;
1880     }
1881     *stlw = rep;
1882     il = iadr(*Lstk(*lw));
1883     ix1 = il + *istk(il + 1) + 3;
1884     *istk(il + 2 + *numi) = *stlw - sadr(ix1) + 1;
1885     if (*numi == *istk(il + 1))
1886     {
1887         *Lstk(*lw + 1) = *stlw;
1888     }
1889     return TRUE;
1890 }
1891
1892 /*------------------------------------------------------------------
1893 * TODO : add comments
1894 * listcrestring
1895 *------------------------------------------------------------------ */
1896
1897 int C2F(listcrestring) (char *fname, int *lw, int *numi, int *stlw, int *nch, int *ilrs, unsigned long fname_len)
1898 {
1899     int ix1, il;
1900
1901     if (C2F(crestringi) (fname, stlw, nch, ilrs, fname_len) == FALSE)
1902     {
1903         return FALSE;
1904     }
1905
1906     ix1 = *ilrs - 1 + *istk(*ilrs - 2 + 1);
1907     *stlw = sadr(ix1);
1908     il = iadr(*Lstk(*lw));
1909     ix1 = il + *istk(il + 1) + 3;
1910     *istk(il + 2 + *numi) = *stlw - sadr(ix1) + 1;
1911     if (*numi == *istk(il + 1))
1912     {
1913         *Lstk(*lw + 1) = *stlw;
1914     }
1915     return TRUE;
1916 }
1917
1918 /*------------------------------------------------------------------
1919 *     verifie que l'on peut stocker une matrice [1,1]
1920 *     de chaine de caracteres a la position spos de la stack
1921 *     en renvoyant .true. ou .false.  suivant la reponse.
1922 *     nchar est le nombre de caracteres que l'on veut stocker
1923 *     Entree :
1924 *       spos : position (entier)
1925 *     Sortie :
1926 *       ilrs
1927 *------------------------------------------------------------------ */
1928
1929 int C2F(crestring) (char *fname, int *spos, int *nchar, int *ilrs, unsigned long fname_len)
1930 {
1931     int ix1;
1932
1933     if (C2F(crestringi) (fname, Lstk(*spos), nchar, ilrs, fname_len) == FALSE)
1934     {
1935         return FALSE;
1936     }
1937     ix1 = *ilrs + *nchar;
1938     *Lstk(*spos + 1) = sadr(ix1);
1939     /* empty strings */
1940     if (*nchar == 0)
1941     {
1942         *Lstk(*spos + 1) += 1;
1943     }
1944     return TRUE;
1945 }
1946
1947 /*------------------------------------------------------------------
1948 *     verifie que l'on peut stocker une matrice [1,1]
1949 *     de chaine de caracteres  a la position stlw en renvoyant .true. ou .false.
1950 *     suivant la reponse.
1951 *     nchar est le nombre de caracteres que l'on veut stcoker
1952 *     Entree :
1953 *       stlw : position (entier)
1954 *     Sortie :
1955 *       nchar : nombre de caracteres stockable
1956 *       lr : pointe sur  a(1,1)=istk(lr)
1957 *------------------------------------------------------------------ */
1958
1959 int C2F(crestringi) (char *fname, int *stlw, int *nchar, int *ilrs, unsigned long fname_len)
1960 {
1961
1962     int ix1, ilast, il;
1963
1964     il = iadr(*stlw);
1965     ix1 = il + 4 + (*nchar + 1);
1966     Err = sadr(ix1) - *Lstk(Bot);
1967     if (Err > 0)
1968     {
1969         Scierror(17, _("%s: stack size exceeded (Use stacksize function to increase it).\n"), get_fname(fname, fname_len));
1970         return FALSE;
1971     };
1972     *istk(il) = sci_strings;
1973     *istk(il + 1) = 1;
1974     *istk(il + 1 + 1) = 1;
1975     *istk(il + 2 + 1) = 0;
1976     *istk(il + 3 + 1) = 1;
1977     *istk(il + 4 + 1) = *istk(il + 3 + 1) + *nchar;
1978     ilast = il + 5;
1979     *ilrs = ilast + *istk(ilast - 2 + 1);
1980     return TRUE;
1981 }
1982
1983 /*---------------------------------------------------------------------
1984 *  checks if we can store a string of size nchar at position lw
1985 *---------------------------------------------------------------------*/
1986
1987 int C2F(fakecresmat2) (int *lw, int *nchar, int *lr)
1988 {
1989     static int cx17 = 17;
1990     int retval;
1991     static int ilast;
1992     static int il;
1993
1994     il = iadr((*Lstk(*lw)));
1995     Err = sadr(il + 4 + (*nchar + 1)) - *Lstk(Bot);
1996     if (Err > 0)
1997     {
1998         SciError(cx17);
1999         retval = FALSE;
2000     }
2001     else
2002     {
2003         ilast = il + 5;
2004         *Lstk(*lw + 1) = sadr(ilast + *istk(ilast));
2005         *lr = ilast + *istk(ilast - 1);
2006         retval = TRUE;
2007     }
2008     return retval;
2009 }
2010
2011 /*------------------------------------------------------------------
2012 *     verifie qu'il y a une matrice de chaine de caracteres en lw-1
2013 *     et verifie que l'on peut stocker l'extraction de la jieme colonne
2014 *     en lw : si oui l'extraction est faite
2015 *     Entree :
2016 *       lw : position (entier)
2017 *       j  : colonne a extraire
2018 *------------------------------------------------------------------ */
2019
2020 int C2F(smatj) (char *fname, int *lw, int *j, unsigned long fname_len)
2021 {
2022     int ix1, ix2;
2023     int incj;
2024     int ix, m, n;
2025     int lj, nj, lr, il1, il2, nlj;
2026     int il1j, il2p;
2027
2028     if (*lw + 1 >= Bot)
2029     {
2030         Scierror(18, _("%s: Too many names.\n"), get_fname(fname, fname_len));
2031         return FALSE;
2032     }
2033     ix1 = *lw - 1;
2034     ix2 = *lw - 1;
2035
2036     if (!C2F(getsmat) (fname, &ix1, &ix2, &m, &n, &cx1, &cx1, &lr, &nlj, fname_len))
2037     {
2038         return FALSE;
2039     }
2040     if (*j > n)
2041     {
2042         return FALSE;
2043     }
2044
2045     il1 = iadr(*Lstk(*lw - 2 + 1));
2046     il2 = iadr(*Lstk(*lw));
2047     /*     nombre de caracteres de la jieme colonne */
2048     incj = (*j - 1) * m;
2049     nj = *istk(il1 + 4 + incj + m) - *istk(il1 + 4 + incj);
2050     /*     test de place */
2051     ix1 = il2 + 4 + m + nj + 1;
2052     Err = sadr(ix1) - *Lstk(Bot);
2053     if (Err > 0)
2054     {
2055         Scierror(17, _("%s: stack size exceeded (Use stacksize function to increase it).\n"), get_fname(fname, fname_len));
2056         return FALSE;
2057     }
2058     *istk(il2) = sci_strings;
2059     *istk(il2 + 1) = m;
2060     *istk(il2 + 1 + 1) = 1;
2061     *istk(il2 + 2 + 1) = 0;
2062     il2p = il2 + 4;
2063     il1j = il1 + 4 + incj;
2064     *istk(il2p) = 1;
2065     ix1 = m;
2066     for (ix = 1; ix <= ix1; ++ix)
2067     {
2068         *istk(il2p + ix) = *istk(il2p - 1 + ix) + *istk(il1j + ix) - *istk(il1j + ix - 2 + 1);
2069     }
2070     lj = *istk(il1 + 4 + incj) + il1 + 4 + m * n;
2071     C2F(icopy) (&nj, istk(lj), &cx1, istk(il2 + 4 + m + 1), &cx1);
2072     ix1 = il2 + 4 + m + nj + 1;
2073     *Lstk(*lw + 1) = sadr(ix1);
2074     return TRUE;
2075 }
2076
2077 /*------------------------------------------------------------------
2078 *     copie la matrice de chaine de caracteres stockee en flw
2079 *     en tlw, les verifications de dimensions
2080 *     ne sont pas faites
2081 *     Lstk(tlw+1) est modifie si necessaire
2082 *------------------------------------------------------------------ */
2083
2084 int C2F(copysmat) (char *fname, int *flw, int *tlw, unsigned long fname_len)
2085 {
2086     int ix1;
2087     int dflw, fflw;
2088     int dtlw;
2089
2090     dflw = iadr(*Lstk(*flw));
2091     fflw = iadr(*Lstk(*flw + 1));
2092     dtlw = iadr(*Lstk(*tlw));
2093     ix1 = fflw - dflw;
2094     C2F(icopy) (&ix1, istk(dflw), &cx1, istk(dtlw), &cx1);
2095     *Lstk(*tlw + 1) = *Lstk(*tlw) + *Lstk(*flw + 1) - *Lstk(*flw);
2096     return 0;
2097 }
2098
2099 /*------------------------------------------------------------------
2100 *     lw designe une matrice de chaine de caracteres
2101 *     on veut changer la taille de la chaine (i,j)
2102 *     et lui donner la valeur nlr
2103 *     cette routine si (i,j) != (m,n) fixe
2104 *     le pointeur de l'argument i+j*m +1
2105 *     sans changer les valeurs de la matrice
2106 *     si (i,j)=(m,n) fixe juste la longeur de la chaine
2107 *     Entree :
2108 *       fname : nom de la routine appellante pour le message
2109 *       d'erreur
2110 *       lw : position dans la pile
2111 *       i,j : indice considere
2112 *       m,n : taille de la matrice
2113 *       lr  :
2114 *------------------------------------------------------------------ */
2115
2116 int C2F(setsimat) (char *fname, int *lw, int *ix, int *j, int *nlr, unsigned long fname_len)
2117 {
2118     int k, m, il;
2119
2120     il = iadr(*Lstk(*lw));
2121     m = *istk(il + 1);
2122     k = *ix - 1 + (*j - 1) * m;
2123     *istk(il + 4 + k + 1) = *istk(il + 4 + k) + *nlr;
2124     return 0;
2125 }
2126
2127 /**********************************************************************
2128 * LISTS
2129 **********************************************************************/
2130
2131 /*-------------------------------------------------------------------
2132 * crelist :creation of a list with ilen elements at slw position
2133 * cretlist:creation of a tlist with ilen elements at slw position
2134 * cremlist:creation of an mlist with ilen elements at slw position
2135 *    In : slw and ilen
2136 *    Out : lw
2137 *     first element can be stored at postion stk(lw)
2138 * Note : elements are to be added to close the list creation
2139 *------------------------------------------------------------------- */
2140
2141 int crelist_G(int *slw, int *ilen, int *lw, int type)
2142 {
2143     int ix1;
2144     int il;
2145
2146     il = iadr(*Lstk(*slw));
2147     *istk(il) = type;
2148     *istk(il + 1) = *ilen;
2149     *istk(il + 2) = 1;
2150     ix1 = il + *ilen + 3;
2151     *lw = sadr(ix1);
2152     if (*ilen == 0)
2153     {
2154         *Lstk(*lw + 1) = *lw;
2155     }
2156     return 0;
2157 }
2158
2159 int C2F(crelist) (int *slw, int *ilen, int *lw)
2160 {
2161     return crelist_G(slw, ilen, lw, 15);
2162 }
2163
2164 int C2F(cretlist) (int *slw, int *ilen, int *lw)
2165 {
2166     return crelist_G(slw, ilen, lw, 16);
2167 }
2168
2169 int C2F(cremlist) (int *slw, int *ilen, int *lw)
2170 {
2171     return crelist_G(slw, ilen, lw, 17);
2172 }
2173
2174 /*------------------------------------------------------------------
2175 * lmatj :
2176 *   checks that there's a list at position  lw-1
2177 *   checks that the j-th element can be extracted at lw position
2178 *   perform the extraction
2179 *       lw : position
2180 *       j  : element to be extracted
2181 *------------------------------------------------------------------ */
2182
2183 int C2F(lmatj) (char *fname, int *lw, int *j, unsigned long fname_len)
2184 {
2185     int ix1, ix2;
2186     int n;
2187     int il, ilj, slj;
2188
2189     if (*lw + 1 >= Bot)
2190     {
2191         Scierror(18, _("%s: Too many names.\n"), get_fname(fname, fname_len));
2192         return FALSE;
2193     }
2194     ix1 = *lw - 1;
2195     ix2 = *lw - 1;
2196     if (!C2F(getilist) (fname, &ix1, &ix2, &n, j, &ilj, fname_len))
2197     {
2198         return FALSE;
2199     }
2200     if (*j > n)
2201     {
2202         return FALSE;
2203     }
2204     /*     a ameliorer */
2205     il = iadr(*Lstk(*lw - 2 + 1));
2206     ix1 = il + 3 + n;
2207     slj = sadr(ix1) + *istk(il + 2 + (*j - 1)) - 1;
2208     n = *istk(il + 2 + *j) - *istk(il + 2 + (*j - 1));
2209     Err = *Lstk(*lw) + n - *Lstk(Bot);
2210     if (Err > 0)
2211     {
2212         return FALSE;
2213     }
2214     C2F(scidcopy) (&n, stk(slj), &cx1, stk(*Lstk(*lw)), &cx1);
2215     *Lstk(*lw + 1) = *Lstk(*lw) + n;
2216     return TRUE;
2217 }
2218
2219 /*------------------------------------------------
2220 *     renvoie .true. si l'argument en lw est une liste
2221 *     Entree :
2222 *      fname : nom de la routine appellante pour le message
2223 *          d'erreur
2224 *      lw : position ds la pile
2225 *      i  : element demande
2226 *     Sortie :
2227 *      n  : nombre d'elements ds la liste
2228 *      ili : le ieme element commence en istk(iadr(ili))
2229 *     ==> pour recuperer un argument il suffit
2230 *     de faire un lk=Lstk(top);Lstk(top)=ili; getmat(...,top,...);stk(top)=lk
2231 *------------------------------------------------*/
2232
2233 int C2F(getilist) (char *fname, int *topk, int *lw, int *n, int *ix, int *ili, unsigned long fname_len)
2234 {
2235     int ix1;
2236     int itype, il;
2237
2238     il = iadr(*Lstk(*lw));
2239     if (*istk(il) < 0)
2240     {
2241         il = iadr(*istk(il + 1));
2242     }
2243
2244     itype = *istk(il);
2245     if (itype < sci_list || itype > sci_mlist)
2246     {
2247         Scierror(210, _("%s: Wrong type for argument %d: List expected.\n"), get_fname(fname, fname_len), Rhs + (*lw - *topk));
2248         return FALSE;
2249     }
2250     *n = *istk(il + 1);
2251     if (*ix <= *n)
2252     {
2253         ix1 = il + 3 + *n;
2254         *ili = sadr(ix1) + *istk(il + 2 + (*ix - 1)) - 1;
2255     }
2256     else
2257     {
2258         *ili = 0;
2259     }
2260     return TRUE;
2261 }
2262
2263 /**********************************************************************
2264 * POLYNOMS
2265 **********************************************************************/
2266
2267 /*------------------------------------------------
2268 *     renvoie .true. si l'argument en lw est une matrice de polynome
2269 *             sinon appelle error et renvoie .false.
2270 *     Entree :
2271 *       fname : nom de la routine appellante pour le message
2272 *       d'erreur
2273 *       lw    : position ds la pile
2274 *     Sortie
2275 *       [it,m,n] caracteristiques de la matrice
2276 *       name : nom de la variable muette ( character*4)
2277 *       namel : taille de name <=4 ( uncounting trailling blanks)
2278 *       soit lij=istk(ilp+(i-1)+(j-1)*m)
2279 *       alors le degre zero de l'elements (i,j) est en
2280 *       stk(lr+lij) (partie reelle ) et stk(lc+lij) (imag)
2281 *       le degre de l'elt (i,j)= l(i+1)j - lij -1
2282 *      implicit undefined (a-z)
2283 *------------------------------------------------*/
2284
2285 int C2F(getpoly) (char *fname, int *topk, int *lw, int *it, int *m, int *n, char *namex, int *namel, int *ilp, int *lr, int *lc,
2286                   unsigned long fname_len, unsigned long name_len)
2287 {
2288     int ix1;
2289
2290     int il;
2291
2292     il = iadr(*Lstk(*lw));
2293     if (*istk(il) != 2)
2294     {
2295         Scierror(212, _("%s: Wrong type for argument %d: Polynomial matrix expected.\n"), get_fname(fname, fname_len), Rhs + (*lw - *topk));
2296         return FALSE;
2297     };
2298     *m = *istk(il + 1);
2299     *n = *istk(il + 2);
2300     *it = *istk(il + 3);
2301     *namel = 4;
2302     C2F(cvstr) (namel, istk(il + 4), namex, &cx1, 4L);
2303 L11:
2304     if (*namel > 0)
2305     {
2306         if (namex[*namel - 1] == ' ')
2307         {
2308             --(*namel);
2309             goto L11;
2310         }
2311     }
2312     *ilp = il + 8;
2313     ix1 = *ilp + *m * *n + 1;
2314     *lr = sadr(ix1) - 1;
2315     *lc = *lr + *istk(*ilp + *m * *n) - 1;
2316     return TRUE;
2317
2318 }
2319
2320 /*------------------------------------------------------------------
2321 *     recupere un polynome
2322 *     md est son degre et son premier element est en
2323 *     stk(lr),stk(lc)
2324 *     Finir les tests
2325 *------------------------------------------------------------------ */
2326
2327 int C2F(getonepoly) (char *fname, int *topk, int *lw, int *it, int *md, char *namex, int *namel, int *lr, int *lc, unsigned long fname_len,
2328                      unsigned long name_len)
2329 {
2330     int m, n;
2331     int ilp;
2332
2333     if (C2F(getpoly) (fname, topk, lw, it, &m, &n, namex, namel, &ilp, lr, lc, fname_len, 4L) == FALSE)
2334     {
2335         return FALSE;
2336     }
2337
2338     if (m * n != 1)
2339     {
2340         Scierror(998, _("%s: Wrong type for argument %d: Polynomial expected.\n"), get_fname(fname, fname_len), Rhs + (*lw - *topk));
2341         return FALSE;
2342     }
2343     *md = *istk(ilp + 1) - *istk(ilp) - 1;
2344     *lr += *istk(ilp);
2345     *lc += *istk(ilp);
2346     return TRUE;
2347 }
2348
2349 /*------------------------------------------------------------------
2350 * pmatj :
2351 *   checks that there's a polynomial matrix  at position  lw-1
2352 *   checks that the j-th column  can be extracted at lw position
2353 *   perform the extraction
2354 *       lw : position
2355 *       j  : column  to be extracted
2356 *------------------------------------------------------------------ */
2357
2358 int C2F(pmatj) (char *fname, int *lw, int *j, unsigned long fname_len)
2359 {
2360     int ix1, ix2;
2361     char namex[4];
2362     int incj;
2363     int ix, l, m, n, namel;
2364     int l2, m2, n2, lc, il, lj, it, lr, il2, ilp;
2365
2366     if (*lw + 1 >= Bot)
2367     {
2368         Scierror(18, _("%s: Too many names.\n"), get_fname(fname, fname_len));
2369         return FALSE;
2370     }
2371     ix1 = *lw - 1;
2372     ix2 = *lw - 1;
2373     if (!C2F(getpoly) (fname, &ix1, &ix2, &it, &m, &n, namex, &namel, &ilp, &lr, &lc, fname_len, 4L))
2374     {
2375         return FALSE;
2376     }
2377     if (*j > n)
2378     {
2379         return FALSE;
2380     }
2381
2382     /*     a ameliorer */
2383     il = iadr(*Lstk(*lw - 2 + 1));
2384     incj = (*j - 1) * m;
2385     il2 = iadr(*Lstk(*lw));
2386     ix1 = il2 + 4;
2387     m2 = Max(m, 1);
2388     ix1 = il + 9 + m * n;
2389     l = sadr(ix1);
2390     n = *istk(il + 8 + m * n) - 1;
2391     ix1 = il2 + 9 + m2;
2392     l2 = sadr(ix1);
2393     n2 = *istk(il + 8 + incj + m) - *istk(il + 8 + incj);
2394     Err = l2 + n2 * (it + 1) - *Lstk(Bot);
2395     if (Err > 0)
2396     {
2397         Scierror(17, _("%s: stack size exceeded (Use stacksize function to increase it).\n"), get_fname(fname, fname_len));
2398         return FALSE;
2399     }
2400     C2F(icopy) (&cx4, istk(il + 3 + 1), &cx1, istk(il2 + 3 + 1), &cx1);
2401     il2 += 8;
2402     il = il + 8 + incj;
2403     lj = l - 1 + *istk(il);
2404     *istk(il2) = 1;
2405     ix1 = m2;
2406     for (ix = 1; ix <= ix1; ++ix)
2407     {
2408         *istk(il2 + ix) = *istk(il2 - 1 + ix) + *istk(il + ix) - *istk(il - 1 + ix);
2409     }
2410     C2F(dcopy) (&n2, stk(lj), &cx1, stk(l2), &cx1);
2411     if (it == 1)
2412     {
2413         C2F(dcopy) (&n2, stk(lj + n), &cx1, stk(l2 + n2), &cx1);
2414     }
2415     *Lstk(Top + 1) = l2 + n2 * (it + 1);
2416     il2 += -8;
2417     *istk(il2) = 2;
2418     *istk(il2 + 1) = m2;
2419     *istk(il2 + 1 + 1) = 1;
2420     *istk(il2 + 2 + 1) = it;
2421     return TRUE;
2422 }
2423
2424 /**********************************************************************
2425 * WORKING ARRAYS
2426 **********************************************************************/
2427
2428 /*------------------------------------------------------------------
2429 * crewmat : uses the rest of the stack as a working area (double)
2430 *    In :
2431 *       lw : position (entier)
2432 *    Out:
2433 *       m  : size that can be used
2434 *       lr : stk(lr+i) is the working area
2435 *------------------------------------------------------------------ */
2436
2437 int C2F(crewmat) (char *fname, int *lw, int *m, int *lr, unsigned long fname_len)
2438 {
2439     int il = 0;
2440
2441     if (*lw + 1 >= Bot)
2442     {
2443         Scierror(18, _("%s: Too many names.\n"), get_fname(fname, fname_len));
2444         return FALSE;
2445     }
2446     il = iadr(*Lstk(*lw));
2447     *m = *Lstk(Bot) - sadr(il + 4);
2448     *istk(il) = 1;
2449     *istk(il + 1) = 1;
2450     *istk(il + 2) = *m;
2451     *istk(il + 3) = 0;
2452     *lr = sadr(il + 4);
2453     *Lstk(*lw + 1) = sadr(il + 4) + *m;
2454     return TRUE;
2455 }
2456
2457 /*------------------------------------------------------------------
2458 * crewimat : uses the rest of the stack as a working area (int)
2459 *    In :
2460 *       lw : position (entier)
2461 *    Out:
2462 *       m  : size that can be used
2463 *       lr : istk(lr+i) is the working area
2464 *------------------------------------------------------------------ */
2465
2466 int C2F(crewimat) (char *fname, int *lw, int *m, int *n, int *lr, unsigned long fname_len)
2467 {
2468     double size = ((double) * m) * ((double) * n);
2469     int ix1, il;
2470
2471     if (*lw + 1 >= Bot)
2472     {
2473         Scierror(18, _("%s: Too many names.\n"), get_fname(fname, fname_len));
2474         return FALSE;
2475     }
2476     il = iadr(*Lstk(*lw));
2477     Err = il + 3 - iadr(*Lstk(Bot));
2478     if (Err > -size)
2479     {
2480         Scierror(17, _("%s: stack size exceeded (Use stacksize function to increase it).\n"), get_fname(fname, fname_len));
2481         return FALSE;
2482     }
2483     *istk(il) = 4;
2484     *istk(il + 1) = *m;
2485     *istk(il + 2) = *n;
2486     *lr = il + 3;
2487     ix1 = il + 3 + *m * *n + 2;
2488     *Lstk(*lw + 1) = sadr(ix1);
2489     return TRUE;
2490 }
2491
2492 /*------------------------------------------------
2493 * getwimat : used to get information about
2494 *     a working area set by crewimat
2495 *     In :
2496 *       fname, topk, lw
2497 *     Out :
2498 *       m, n :  dimensions
2499 *       lr : working area is istk(lr+i) i=0,m*n-1
2500 *------------------------------------------------ */
2501
2502 int C2F(getwimat) (char *fname, int *topk, int *lw, int *m, int *n, int *lr, unsigned long fname_len)
2503 {
2504     int il;
2505
2506     il = iadr(*Lstk(*lw));
2507     if (*istk(il) < 0)
2508     {
2509         il = iadr(*istk(il + 1));
2510     }
2511     if (*istk(il) != sci_boolean)
2512     {
2513         Scierror(213, _("%s: Wrong type for argument %d: Working int matrix expected.\n"), get_fname(fname, fname_len), Rhs + (*lw - *topk));
2514         return FALSE;
2515     };
2516     *m = *istk(il + 1);
2517     *n = *istk(il + 2);
2518     *lr = il + 3;
2519     return TRUE;
2520 }
2521
2522
2523 /*----------------------------------------------------------
2524 *  listcrepointer(top,numero,lw,....)
2525 *---------------------------------------------------------- */
2526
2527 int C2F(listcrepointer) (char *fname, int *lw, int *numi, int *stlw, int *lrs, unsigned long fname_len)
2528 {
2529     int ix1, il;
2530
2531     if (C2F(crepointeri) (fname, stlw, lrs, &c_true, fname_len) == FALSE)
2532     {
2533         return FALSE;
2534     }
2535     *stlw = *lrs + 2;
2536     il = iadr(*Lstk(*lw));
2537     ix1 = il + *istk(il + 1) + 3;
2538     *istk(il + 2 + *numi) = *stlw - sadr(ix1) + 1;
2539     if (*numi == *istk(il + 1))
2540     {
2541         *Lstk(*lw + 1) = *stlw;
2542     }
2543     return TRUE;
2544 }
2545
2546 /*----------------------------------------------------------
2547 *  crepointer :
2548 *---------------------------------------------------------- */
2549
2550 int C2F(crepointer) (char *fname, int *lw, int *lr, unsigned long fname_len)
2551 {
2552
2553     if (*lw + 1 >= Bot)
2554     {
2555         Scierror(18, _("%s: Too many names.\n"), get_fname(fname, fname_len));
2556         return FALSE;
2557     }
2558     if (C2F(crepointeri) (fname, Lstk(*lw), lr, &c_true, fname_len) == FALSE)
2559     {
2560         return FALSE;
2561     }
2562     *Lstk(*lw + 1) = *lr + 2;
2563     return TRUE;
2564 }
2565
2566 /*---------------------------------------------------------
2567 * internal function used by crepointer and listcrepointer
2568 *---------------------------------------------------------- */
2569 static int C2F(crepointeri) (char *fname, int *stlw, int *lr, int *flagx, unsigned long fname_len)
2570 {
2571     int ix1;
2572     int il;
2573
2574     il = iadr(*stlw);
2575     ix1 = il + 4;
2576     Err = sadr(ix1) + 2 - *Lstk(Bot);
2577     if (Err > 0)
2578     {
2579         Scierror(17, _("%s: stack size exceeded (Use stacksize function to increase it).\n"), get_fname(fname, fname_len));
2580         return FALSE;
2581     };
2582     if (*flagx)
2583     {
2584         *istk(il) = sci_pointer;    /* used to be sci_lufact_pointer before Scilab 5.2 */
2585         /* if m*n=0 then both dimensions are to be set to zero */
2586         *istk(il + 1) = 1;
2587         *istk(il + 2) = 1;
2588         *istk(il + 3) = 0;
2589     }
2590     ix1 = il + 4;
2591     *lr = sadr(ix1);
2592     return TRUE;
2593 }
2594
2595 /*------------------------------------------------------------------
2596 *     getlistvectrow : recupere un vecteur ligne dans une liste
2597 *------------------------------------------------------------------ */
2598
2599 int C2F(getlistvectrow) (char *fname, int *topk, int *spos, int *lnum, int *it, int *m, int *n, int *lr, int *lc, unsigned long fname_len)
2600 {
2601     int nv;
2602     int ili;
2603
2604     if (C2F(getilist) (fname, topk, spos, &nv, lnum, &ili, fname_len) == FALSE)
2605     {
2606         return FALSE;
2607     }
2608
2609     if (*lnum > nv)
2610     {
2611         Scierror(999, _("%s: Wrong size for argument %d: At least %d expected.\n"), get_fname(fname, fname_len), Rhs + (*spos - *topk), *lnum);
2612         return FALSE;
2613     }
2614
2615     if (C2F(getmati) (fname, topk, spos, &ili, it, m, n, lr, lc, &c_true, lnum, fname_len) == FALSE)
2616     {
2617         return FALSE;
2618     }
2619     if (*m != 1)
2620     {
2621         Scierror(999, _("%s: Wrong type for argument %d (List element: %d): Row vector expected.\n"), get_fname(fname, fname_len),
2622                  Rhs + (*spos - *topk), *lnum);
2623         return FALSE;
2624     }
2625     return TRUE;
2626 }
2627
2628 /*------------------------------------------------------------------
2629 *     Fonction normalement identique a getmat mais rajoutee
2630 *     pour ne pas avoir a changer le stack.f de interf
2631 *     renvoie .true. si l'argument en spos est une matrice
2632 *             sinon appelle error et renvoie .false.
2633 *     Entree :
2634 *       fname : nom de la routine appellante pour le message
2635 *       d'erreur
2636 *       spos    : position ds la pile
2637 *     Sortie
2638 *       [it,m,n] caracteristiques de la matrice
2639 *       lr : pointe sur la partie reelle ( si la matrice est a
2640 *              a(1,1)=stk(lr)
2641 *            si l'on veut acceder a des entiers
2642 *                a(1,1)=istk(adr(lr,0))
2643 *       lc : pointe sur la partie imaginaire si elle existe sinon sur zero
2644 *------------------------------------------------------------------ */
2645
2646 int C2F(getvectrow) (char *fname, int *topk, int *spos, int *it, int *m, int *n, int *lr, int *lc, unsigned long fname_len)
2647 {
2648     if (C2F(getmati) (fname, topk, spos, Lstk(*spos), it, m, n, lr, lc, &c_false, &cx0, fname_len) == FALSE)
2649     {
2650         return FALSE;
2651     }
2652
2653     if (*m != 1)
2654     {
2655         Scierror(999, _("%s: Wrong type for argument %d: Row vector expected.\n"), get_fname(fname, fname_len), Rhs + (*spos - *topk));
2656         return FALSE;
2657     }
2658     return TRUE;
2659 }
2660
2661 /*------------------------------------------------------------------
2662 *
2663 *------------------------------------------------------------------ */
2664
2665 int C2F(getlistvectcol) (char *fname, int *topk, int *spos, int *lnum, int *it, int *m, int *n, int *lr, int *lc, unsigned long fname_len)
2666 {
2667     int nv;
2668     int ili;
2669
2670     if (C2F(getilist) (fname, topk, spos, &nv, lnum, &ili, fname_len) == FALSE)
2671     {
2672         return FALSE;
2673     }
2674
2675     if (*lnum > nv)
2676     {
2677         Scierror(999, _("%s: Wrong size for argument %d: At least %d expected.\n"), get_fname(fname, fname_len), Rhs + (*spos - *topk), *lnum);
2678         return FALSE;
2679     }
2680     if (C2F(getmati) (fname, topk, spos, &ili, it, m, n, lr, lc, &c_true, lnum, fname_len) == FALSE)
2681     {
2682         return FALSE;
2683     }
2684
2685     if (*n != 1)
2686     {
2687         Scierror(999, _("%s: argument %d >(%d) should be a column vector.\n"), get_fname(fname, fname_len), Rhs + (*spos - *topk), *lnum);
2688         return FALSE;
2689     }
2690     return TRUE;
2691 }
2692
2693 /*------------------------------------------------------------------
2694 *     Fonction normalement identique a getmat mais rajoutee
2695 *     pour ne pas avoir a changer le stack.f de interf
2696 *     renvoie .true. si l'argument en spos est une matrice
2697 *             sinon appelle error et renvoie .false.
2698 *     Entree :
2699 *       fname : nom de la routine appellante pour le message
2700 *       d'erreur
2701 *       spos    : position ds la pile
2702 *     Sortie
2703 *       [it,m,n] caracteristiques de la matrice
2704 *       lr : pointe sur la partie reelle ( si la matrice est a
2705 *              a(1,1)=stk(lr)
2706 *            si l'on veut acceder a des entiers
2707 *                a(1,1)=istk(adr(lr,0))
2708 *       lc : pointe sur la partie imaginaire si elle existe sinon sur zero
2709 *------------------------------------------------------------------ */
2710
2711 int C2F(getvectcol) (char *fname, int *topk, int *spos, int *it, int *m, int *n, int *lr, int *lc, unsigned long fname_len)
2712 {
2713
2714     if (C2F(getmati) (fname, topk, spos, Lstk(*spos), it, m, n, lr, lc, &c_false, &cx0, fname_len) == FALSE)
2715     {
2716         return FALSE;
2717     }
2718
2719     if (*n != 1)
2720     {
2721         Scierror(999, _("%s: Wrong type for argument %d: Column vector expected.\n"), get_fname(fname, fname_len), Rhs + (*spos - *topk));
2722         return FALSE;
2723     }
2724     return TRUE;
2725 }
2726
2727 int C2F(getlistsimat) (char *fname, int *topk, int *spos, int *lnum, int *m, int *n, int *ix, int *j, int *lr, int *nlr, unsigned long fname_len)
2728 {
2729     int nv;
2730     int ili;
2731
2732     if (C2F(getilist) (fname, topk, spos, &nv, lnum, &ili, fname_len) == FALSE)
2733     {
2734         return FALSE;
2735     }
2736
2737     if (*lnum > nv)
2738     {
2739         Scierror(999, _("%s: Wrong size for argument %d: At least %d expected.\n"), get_fname(fname, fname_len), Rhs + (*spos - *topk), *lnum);
2740         return FALSE;
2741     }
2742     return C2F(getsmati) (fname, topk, spos, &ili, m, n, ix, j, lr, nlr, &c_true, lnum, fname_len);
2743 }
2744
2745 /*-------------------------------------------------------------------
2746 *     recuperation d'un pointer
2747 *------------------------------------------------------------------- */
2748
2749 int C2F(getpointer) (char *fname, int *topk, int *lw, int *lr, unsigned long fname_len)
2750 {
2751     return C2F(getpointeri) (fname, topk, lw, Lstk(*lw), lr, &c_false, &cx0, fname_len);
2752 }
2753
2754 /*------------------------------------------------------------------
2755 * getlistpointer :
2756 *    checks that spos object is a list
2757 *    checks that lnum-element of the list exists and is a pointer
2758 *    extracts pointer value
2759 *     In  :
2760 *       fname : name of calling function for error message
2761 *       topk  : stack ref for error message
2762 *       spos    : stack position
2763 *     Out :
2764 *       lw : stk(lw) a <<pointer>> casted to a double
2765 *------------------------------------------------------------------ */
2766
2767 int C2F(getlistpointer) (char *fname, int *topk, int *spos, int *lnum, int *lw, unsigned long fname_len)
2768 {
2769     int nv, ili;
2770
2771     if (C2F(getilist) (fname, topk, spos, &nv, lnum, &ili, fname_len) == FALSE)
2772     {
2773         return FALSE;
2774     }
2775
2776     if (*lnum > nv)
2777     {
2778         Scierror(999, _("%s: Wrong size for argument %d: At least %d expected.\n"), get_fname(fname, fname_len), Rhs + (*spos - *topk), *lnum);
2779         return FALSE;
2780     }
2781     return C2F(getpointeri) (fname, topk, spos, &ili, lw, &c_true, lnum, fname_len);
2782 }
2783
2784 /*-------------------------------------------------------------------
2785 * For internal use
2786 *------------------------------------------------------------------- */
2787
2788 static int C2F(getpointeri) (char *fname, int *topk, int *spos, int *lw, int *lr, int *inlistx, int *nel, unsigned long fname_len)
2789 {
2790     int il;
2791
2792     il = iadr(*lw);
2793     if (*istk(il) < 0)
2794     {
2795         il = iadr(*istk(il + 1));
2796     }
2797     if (*istk(il) != sci_pointer)
2798     {
2799         /* used to be sci_lufact_pointer before Scilab 5.2 */
2800         sciprint("----%d\n", *istk(il));
2801         if (*inlistx)
2802             Scierror(197, _("%s: Wrong type for argument %d (List element: %d): Boxed pointer expected.\n"), get_fname(fname, fname_len),
2803                      Rhs + (*spos - *topk), *nel);
2804         else
2805         {
2806             Scierror(198, _("%s: Wrong type for argument #%d: Boxed pointer expected.\n"), get_fname(fname, fname_len), Rhs + (*spos - *topk));
2807         }
2808         return FALSE;
2809     }
2810     *lr = sadr(il + 4);
2811     return TRUE;
2812 }
2813
2814 /*-----------------------------------------------------------
2815 *     creates a matlab-like sparse matrix
2816 *-----------------------------------------------------------*/
2817
2818 int C2F(mspcreate) (int *lw, int *m, int *n, int *nzMax, int *it)
2819 {
2820     int ix1;
2821     int jc, il, ir;
2822     int NZMAX;
2823     int k, pr;
2824     double size;
2825
2826     if (*lw + 1 >= Bot)
2827     {
2828         Scierror(18, _("%s: Too many names.\n"), "");
2829         return FALSE;
2830     }
2831
2832     il = iadr(*Lstk(*lw));
2833     NZMAX = *nzMax;
2834     if (NZMAX == 0)
2835     {
2836         NZMAX = 1;
2837     }
2838     ix1 = il + 4 + (*n + 1) + NZMAX;
2839     size = (*it + 1) * NZMAX;
2840     Err = sadr(ix1) - *Lstk(Bot);
2841     if (Err > -size)
2842     {
2843         Scierror(17, _("%s: stack size exceeded (Use stacksize function to increase it).\n"), "");
2844         return FALSE;
2845     };
2846     *istk(il) = sci_matlab_sparse;
2847     /*        si m*n=0 les deux dimensions sont mises a zero.
2848      *istk(il +1) = Min(*m , *m * *n);
2849      *istk(il + 1 +1) = Min(*n, *m * *n);     */
2850     *istk(il + 1) = *m;
2851     *istk(il + 2) = *n;
2852     *istk(il + 3) = *it;
2853     *istk(il + 4) = NZMAX;
2854     jc = il + 5;
2855
2856     for (k = 0; k < *n + 1; ++k)
2857     {
2858         *istk(jc + k) = 0;    /* Jc =0 */
2859     }
2860     ir = jc + *n + 1;
2861     for (k = 0; k < NZMAX; ++k)
2862     {
2863         *istk(ir + k) = 0;    /* Ir = 0 */
2864     }
2865     pr = sadr(ir + NZMAX);
2866
2867     for (k = 0; k < NZMAX; ++k)
2868     {
2869         *stk(pr + k) = 0;    /* Pr =0  */
2870     }
2871     ix1 = il + 4 + (*n + 1) + NZMAX;
2872     *Lstk(*lw + 1) = sadr(ix1) + (*it + 1) * NZMAX + 1;
2873
2874     C2F(intersci).ntypes[*lw - Top + Rhs - 1] = '$';
2875     C2F(intersci).iwhere[*lw - Top + Rhs - 1] = *Lstk(*lw);
2876     /* C2F(intersci).lad[*lw-Top+Rhs-1] = should point to numeric data */
2877     return TRUE;
2878 }
2879
2880 /**********************************************************************
2881 * Utilities
2882 **********************************************************************/
2883
2884 /*------------------------------------------
2885 * get_fname used for function names which can be non
2886 * null-terminated strings when coming from
2887 * a Fortran call
2888 *------------------------------------------*/
2889
2890 static char Fname[nlgh + 1];
2891
2892 char *get_fname(char *fname, unsigned long fname_len)
2893 {
2894     int i = 0;
2895     int minlength = Min(fname_len, nlgh);
2896
2897     strncpy(Fname, fname, minlength);
2898     Fname[minlength] = '\0';
2899     for (i = 0; i < (int)minlength; i++)
2900         if (Fname[i] == ' ')
2901         {
2902             Fname[i] = '\0';
2903             break;
2904         }
2905     return Fname;
2906 }
2907
2908 /*------------------------------------------------------------------
2909 * realmat :
2910 *     Top is supposed to be a matrix
2911 *     and the matrix is chnaged to its real part
2912 *------------------------------------------------------------------ */
2913
2914 int C2F(realmat) (void)
2915 {
2916     int ix1;
2917     int m, n, il;
2918
2919     il = iadr(*Lstk(Top));
2920     if (*istk(il + 3) == 0)
2921     {
2922         return 0;
2923     }
2924     m = *istk(il + 1);
2925     n = *istk(il + 2);
2926     *istk(il + 3) = 0;
2927     ix1 = il + 4;
2928     *Lstk(Top + 1) = sadr(ix1) + m * n;
2929     return 0;
2930 }
2931
2932 /*------------------------------------------------------------------
2933 *     copie l'objet qui est a la position lw de la pile
2934 *     a la position lwd de la pile
2935 *     copie faite avec dcopy
2936 *     pas de verification
2937 *      implicit undefined (a-z)
2938 *------------------------------------------------------------------ */
2939
2940 int C2F(copyobj) (char *fname, int *lw, int *lwd, unsigned long fname_len)
2941 {
2942     int ix1, l, ld;
2943
2944     l = *Lstk(*lw);
2945     ld = *Lstk(*lwd);
2946
2947     ix1 = *Lstk(*lw + 1) - l;
2948     /* check for overlaping region */
2949     if (l + ix1 > ld || ld + ix1 > l)
2950     {
2951         C2F(unsfdcopy) (&ix1, stk(l), &cx1, stk(ld), &cx1);
2952     }
2953     else
2954     {
2955         C2F(scidcopy) (&ix1, stk(l), &cx1, stk(ld), &cx1);
2956     }
2957     *Lstk(*lwd + 1) = ld + ix1;
2958     return 0;
2959 }
2960
2961 /*------------------------------------------------
2962 *     copie l'objet qui est a la position lw de la pile
2963 *     a la position lwd de la pile
2964 *     copie faite avec dcopy
2965 *     et verification
2966 *------------------------------------------------*/
2967
2968 int C2F(vcopyobj) (char *fname, int *lw, int *lwd, unsigned long fname_len)
2969 {
2970     int l;
2971     int l1, lv;
2972
2973     l = *Lstk(*lw);
2974     lv = *Lstk(*lw + 1) - *Lstk(*lw);
2975     l1 = *Lstk(*lwd);
2976     if (*lwd + 1 >= Bot)
2977     {
2978         Scierror(18, _("%s: Too many names.\n"), get_fname(fname, fname_len));
2979         return FALSE;
2980     }
2981     Err = *Lstk(*lwd) + lv - *Lstk(Bot);
2982     if (Err > 0)
2983     {
2984         Scierror(17, _("%s: stack size exceeded (Use stacksize function to increase it).\n"), get_fname(fname, fname_len));
2985         return FALSE;
2986     }
2987     /* check for overlaping region */
2988     if (l + lv > l1 || l1 + lv > l)
2989     {
2990         C2F(unsfdcopy) (&lv, stk(l), &cx1, stk(l1), &cx1);
2991     }
2992     else
2993     {
2994         C2F(scidcopy) (&lv, stk(l), &cx1, stk(l1), &cx1);
2995     }
2996
2997     *Lstk(*lwd + 1) = *Lstk(*lwd) + lv;
2998     return TRUE;
2999 }
3000
3001 /*------------------------------------------------==
3002 *     suppose qu'il y a une matrice en lw de taille it1,m1,n1,mn1,
3003 *     et une autre en lw+1 de taille it2,m2,n2,mn2
3004 *     et echange les matrices et change les valeurs de it1,m1,n1,...
3005 *     apres echange la taille de la matrice en lw est stocke ds(it1,m1,n1)
3006 *     et celle en lw+1 est stocke ds (it2,m2,n2)
3007 *     effet de bord il faut que lw+2 soit une place libre
3008 *------------------------------------------------== */
3009
3010 int C2F(swapmat) (char *fname, int *topk, int *lw, int *it1, int *m1, int *n1, int *mn1, int *it2, int *m2, int *n2, int *mn2,
3011                   unsigned long fname_len)
3012 {
3013     int ix1, ix2;
3014     int lc, lr;
3015
3016     ix1 = *lw + 1;
3017
3018     if (C2F(cremat) (fname, &ix1, it1, m1, n1, &lr, &lc, fname_len) == FALSE)
3019     {
3020         return FALSE;
3021     }
3022
3023     ix1 = *lw + 2;
3024     C2F(copyobj) (fname, lw, &ix1, fname_len);
3025     ix1 = *lw + 1;
3026     C2F(copyobj) (fname, &ix1, lw, fname_len);
3027     ix1 = *lw + 2;
3028     ix2 = *lw + 1;
3029     C2F(copyobj) (fname, &ix1, &ix2, fname_len);
3030     if (C2F(getmat) (fname, topk, lw, it1, m1, n1, &lr, &lc, fname_len) == FALSE)
3031     {
3032         return FALSE;
3033     }
3034
3035     ix1 = *lw + 1;
3036
3037     if (C2F(getmat) (fname, topk, &ix1, it2, m2, n2, &lr, &lc, fname_len) == FALSE)
3038     {
3039         return FALSE;
3040     }
3041
3042     *mn1 = *m1 * *n1;
3043     *mn2 = *m2 * *n2;
3044
3045     return TRUE;
3046 }
3047
3048 /*------------------------------------------------==
3049 *     verifie qu'en lw il y a une matrice de taille (it1,m1,n1)
3050 *     deplace cette matrice en lw+1, en reservant en lw
3051 *     la place pour stocker une matrice (it,m,n)
3052 *     insmat  verifie  qu'on a la place de faire tout ca
3053 *     appelle error en cas de probleme
3054 *     Remarque : noter par exemple que si it=it1,m1=m,n1=n
3055 *        alors apres le contenu de la matrice en lw est une copie de
3056 *        celle en lw+1
3057 *     Remarque : lw doit etre top car sinon on perd ce qu'il y avait avant
3058 *        en lw+1,....,lw+n
3059 *     Entree :
3060 *        lw : position
3061 *        it ,m,n : taille de la matrice a inserer
3062 *     Sortie :
3063 *       lr : pointe sur la partie reelle de la matrice
3064 *            en lw (   a(1,1)=stk(lr))
3065 *       lc : pointe sur la partie imaginaire si besoin est
3066 *       lr1,lc1 : meme signification mais pour la matrice en lw+1
3067 *            ( matrice qui a ete copiee de lw a lw+1
3068 *------------------------------------------------== */
3069
3070 int C2F(insmat) (int *topk, int *lw, int *it, int *m, int *n, int *lr, int *lc, int *lr1, int *lc1)
3071 {
3072
3073     int ix1;
3074     int c_n1 = -1;
3075     int m1, n1;
3076     int lc0, it1, lr0;
3077
3078     if (C2F(getmat) ("insmat", topk, lw, &it1, &m1, &n1, &lr0, &lc0, 6L) == FALSE)
3079     {
3080         return FALSE;
3081     }
3082
3083     if (C2F(cremat) ("insmat", lw, it, m, n, lr, lc, 6L) == FALSE)
3084     {
3085         return FALSE;
3086     }
3087
3088     ix1 = *lw + 1;
3089
3090     if (C2F(cremat) ("insmat", &ix1, &it1, &m1, &n1, lr1, lc1, 6L) == FALSE)
3091     {
3092         return FALSE;
3093     }
3094
3095     ix1 = m1 * n1 * (it1 + 1);
3096     C2F(dcopy) (&ix1, stk(lr0), &c_n1, stk(*lr1), &c_n1);
3097     return TRUE;
3098 }
3099
3100 /*------------------------------------------------
3101 *     imprime le contenu de la pile en lw en mode entier ou
3102 *       double precision suivant typ
3103 *------------------------------------------------*/
3104
3105 int C2F(stackinfo) (int *lw, int *typ)
3106 {
3107     int ix, l, m, n;
3108     int il, nn;
3109
3110     if (*lw == 0)
3111     {
3112         return 0;
3113     }
3114     il = iadr(*Lstk(*lw));
3115     if (*istk(il) < 0)
3116     {
3117         il = iadr(*istk(il + 1));
3118     }
3119     m = *istk(il + 1);
3120     n = *istk(il + 1 + 1);
3121
3122     sciprint("-----------------stack-info-----------------\n");
3123     sciprint("lw=%d -[istk]-> il lw+1 -[istk]-> %d\n", *lw, iadr(*Lstk(*lw + 1)));
3124     sciprint("istk(%d:..) ->[%d %d %d %d ....]\n", il, istk(il), istk(il + 1), istk(il + 2), istk(il + 3));
3125     if (*typ == 1)
3126     {
3127         l = sadr(il + 4);
3128         nn = Min(m * n, 3);
3129         for (ix = 0; ix <= nn - 1; ++ix)
3130         {
3131             sciprint("%5.2f  ", stk(l + ix));
3132         }
3133     }
3134     else
3135     {
3136         l = il + 4;
3137         nn = Min(m * n, 3);
3138         for (ix = 0; ix <= nn - 1; ++ix)
3139         {
3140             sciprint("%5d  ", istk(l + ix));
3141         }
3142     }
3143     sciprint("\n");
3144     sciprint("-----------------stack-info-----------------\n");
3145     return 0;
3146 }
3147
3148 /*------------------------------------------------
3149 * allmat :
3150 *  checks if object at position lw is a matrix
3151 *  (scalar,string,polynom)
3152 *  In :
3153 *     fname,topk,lw
3154 *  Out :
3155 *     m,n
3156 *------------------------------------------------*/
3157
3158 int C2F(allmat) (char *fname, int *topk, int *lw, int *m, int *n, unsigned long fname_len)
3159 {
3160     int itype, il;
3161
3162     il = iadr(*Lstk(*lw));
3163     if (*istk(il) < 0)
3164     {
3165         il = iadr(*istk(il + 1));
3166     }
3167     itype = *istk(il);
3168     if (itype != sci_matrix && itype != sci_poly && itype != sci_strings)
3169     {
3170         Scierror(209, _("%s: Wrong type for argument %d: Matrix expected.\n"), get_fname(fname, fname_len), Rhs + (*lw - *topk));
3171         return FALSE;
3172     }
3173     *m = *istk(il + 1);
3174     *n = *istk(il + 2);
3175     return TRUE;
3176 }
3177
3178 /*------------------------------------------------
3179 * Assume that object at position lw is a matrix
3180 * and set its size to (m,n)
3181 *------------------------------------------------*/
3182
3183 int C2F(allmatset) (char *fname, int *lw, int *m, int *n, unsigned long fname_len)
3184 {
3185     int il;
3186
3187     il = iadr(*Lstk(*lw));
3188     if (*istk(il) < 0)
3189     {
3190         il = iadr(*istk(il + 1));
3191     }
3192     *istk(il + 1) = *m;
3193     *istk(il + 2) = *n;
3194     return 0;
3195 }
3196
3197 /*------------------------------------------------
3198 *     cree un objet vide en lw et met a jour lw+1
3199 *     en fait lw doit etre top
3200 *     verifie les cas particuliers lw=0 ou lw=1
3201 *     ainsi que le cas particulier ou une fonction
3202 *     n'a pas d'arguments (ou il faut faire top=top+1)
3203 *------------------------------------------------ */
3204
3205 int C2F(objvide) (char *fname, int *lw, unsigned long fname_len)
3206 {
3207     if (*lw == 0 || Rhs < 0)
3208     {
3209         ++(*lw);
3210     }
3211     *istk(iadr(*Lstk(*lw))) = 0;
3212     *Lstk(*lw + 1) = *Lstk(*lw) + 2;
3213     return 0;
3214 }
3215
3216 /*------------------------------------------------
3217 *     renvoie .true. si l'argument en lw est un ``external''
3218 *             sinon appelle error et renvoie .false.
3219 *     si l'argument est un external de type string
3220 *         on met a jour la table des fonctions externes
3221 *         corespondante en appellant fun
3222 *     Entree :
3223 *       fname : nom de la routine appellante pour le message
3224 *       d'erreur
3225 *       topk : numero d'argument d'appel pour le message d'erreur
3226 *       lw    : position ds la pile
3227 *     Sortie
3228 *       type vaut true ou false
3229 *       si l'external est de type chaine de caracteres
3230 *       la chaine est mise ds name
3231 *       et type est mise a true
3232 *------------------------------------------------ */
3233
3234 int C2F(getexternal) (char *fname, int *topk, int *lw, char *namex, int *typex, void (*setfun) (char *, int *), unsigned long fname_len,
3235                       unsigned long name_len)
3236 {
3237     int ret_value;
3238     int irep;
3239     int m, n;
3240     int il, lr;
3241     int nlr;
3242     int i;
3243
3244     il = C2F(gettype) (lw);
3245     switch (il)
3246     {
3247         case sci_u_function:
3248         case sci_c_function:
3249         case sci_list:
3250             ret_value = TRUE;
3251             *typex = FALSE;
3252             break;
3253         case sci_strings:
3254             ret_value = C2F(getsmat) (fname, topk, lw, &m, &n, &cx1, &cx1, &lr, &nlr, fname_len);
3255             *typex = TRUE;
3256             for (i = 0; i < (int)name_len; i++)
3257             {
3258                 namex[i] = ' ';
3259             }
3260             if (ret_value == TRUE)
3261             {
3262                 C2F(cvstr) (&nlr, istk(lr), namex, &cx1, name_len);
3263                 namex[nlr] = '\0';
3264                 (*setfun) (namex, &irep);   /* , name_len); */
3265                 if (irep == 1)
3266                 {
3267                     Scierror(50, _("%s: entry point %s not found in predefined tables or link table.\n"), get_fname(fname, fname_len), namex);
3268                     ret_value = FALSE;
3269                 }
3270             }
3271             break;
3272         default:
3273             Scierror(211, _("%s: Wrong type for argument #%d: Function or string (external function) expected.\n"), get_fname(fname, fname_len),
3274                      Rhs + (*lw - *topk));
3275             ret_value = FALSE;
3276             break;
3277     }
3278     return ret_value;
3279 }
3280
3281 /*------------------------------------------------
3282 *------------------------------------------------ */
3283
3284 int C2F(checkval) (char *fname, int *ival1, int *ival2, unsigned long fname_len)
3285 {
3286     if (*ival1 != *ival2)
3287     {
3288         Scierror(999, _("%s: Incompatible sizes.\n"), get_fname(fname, fname_len));
3289         return FALSE;
3290     };
3291     return TRUE;
3292 }
3293
3294 /*-------------------------------------------------------------
3295 *      recupere si elle existe la variable name dans la stack et
3296 *      met sa valeur a la position top et top est incremente
3297 *      ansi que rhs
3298 *      si la variable cherchee n'existe pas on renvoie false
3299 *------------------------------------------------------------- */
3300
3301 int C2F(optvarget) (char *fname, int *topk, int *iel, char *namex, unsigned long fname_len, unsigned long name_len)
3302 {
3303     int id[nsiz];
3304
3305     C2F(cvname) (id, namex, &cx0, name_len);
3306     Fin = 0;
3307     /*     recupere la variable et incremente top */
3308     C2F(stackg) (id);
3309     if (Fin == 0)
3310     {
3311         Scierror(999, _("%s: Optional argument %d not given and default value %s not found.\n"), get_fname(fname, fname_len), *iel, namex);
3312         return FALSE;
3313     }
3314     ++Rhs;
3315     return TRUE;
3316 }
3317
3318 /*-------------------------------------------------------------
3319 * this routine adds nlr characters (coded in istk(*lr))
3320 * + a null character in Scilab character buffer C2F(cha1).buf
3321 * the characters are stored at position lbuf
3322 * lbuf,lbufi,lbuff are the updated :
3323 *     buf(lbufi:lbuff) will give the characters in buf at Fortran level
3324 * and lbuf will give the next available position (i.e lbuff+2 since
3325 * '\0' is added at position lbuff+1
3326 *
3327 * Note that at Fortran level buf(lbufi:lbuff) can be used as a C string argument
3328 * since it is null terminated
3329 *
3330 *------------------------------------------------------------- */
3331
3332 int C2F(bufstore) (char *fname, int *lbuf, int *lbufi, int *lbuff, int *lr, int *nlr, unsigned long fname_len)
3333 {
3334     *lbufi = *lbuf;
3335     *lbuff = *lbufi + *nlr - 1;
3336     *lbuf = *lbuff + 2;
3337     if (*lbuff > bsiz)
3338     {
3339         Scierror(999, _("%f: No more space to store string arguments.\n"), get_fname(fname, fname_len));
3340         return FALSE;
3341     }
3342     /* lbufi is a Fortran indice ==> offset -1 at C level */
3343     C2F(cvstr) (nlr, istk(*lr), C2F(cha1).buf + (*lbufi - 1), &cx1, *lbuff - (*lbufi - 1));
3344     C2F(cha1).buf[*lbuff] = '\0';
3345     return TRUE;
3346 }
3347
3348 /*-------------------------------------------------------------
3349 *
3350 *------------------------------------------------------------- */
3351 int C2F(credata) (char *fname, int *lw, int m, unsigned long fname_len)
3352 {
3353     int lr;
3354
3355     lr = *Lstk(*lw);
3356     if (*lw + 1 >= Bot)
3357     {
3358         Scierror(18, _("%s: Too many names.\n"), get_fname(fname, fname_len));
3359         return FALSE;
3360     }
3361
3362     Err = lr - *Lstk(Bot);
3363     if (Err > -m)
3364     {
3365         Scierror(17, _("%s: stack size exceeded (Use stacksize function to increase it).\n"), get_fname(fname, fname_len));
3366         return FALSE;
3367     };
3368     /*  *Lstk(*lw +1) = lr + 1 + m/sizeof(double);  */
3369     /*    type 0  */
3370     *istk(iadr(lr)) = 0;
3371     *Lstk(*lw + 1) = lr + (m + sizeof(double) - 1) / sizeof(double);
3372     return TRUE;
3373 }
3374
3375 /* ==============================================================
3376 MATRIX OF HANDLE
3377 ================================================================= */
3378 /*---------------------------------------------------------
3379 * internal function used by crehmat and listcrehmat
3380 *---------------------------------------------------------- */
3381
3382 static int C2F(crehmati) (char *fname, int *stlw, int *m, int *n, int *lr, int *flagx, unsigned long fname_len)
3383 {
3384     int ix1;
3385     int il;
3386     double size = ((double) * m) * ((double) * n);
3387
3388     il = iadr(*stlw);
3389     ix1 = il + 4;
3390     Err = sadr(ix1) - *Lstk(Bot);
3391     if ((double)Err > -size)
3392     {
3393         Scierror(17, _("%s: stack size exceeded (Use stacksize function to increase it).\n"), get_fname(fname, fname_len));
3394         return FALSE;
3395     };
3396     if (*flagx)
3397     {
3398         *istk(il) = sci_handles;
3399         /* if m*n=0 then both dimensions are to be set to zero */
3400         *istk(il + 1) = Min(*m, *m * *n);
3401         *istk(il + 2) = Min(*n, *m * *n);
3402         *istk(il + 3) = 0;
3403     }
3404     ix1 = il + 4;
3405     *lr = sadr(ix1);
3406     return TRUE;
3407 }
3408
3409 /*----------------------------------------------------------
3410 *  listcrehmat(top,numero,lw,....)
3411 *      le numero ieme element de la liste en top doit etre un matrice
3412 *      stockee a partir de Lstk(lw)
3413 *      doit mettre a jour les pointeurs de la liste
3414 *      ainsi que stk(top+1)
3415 *      si l'element a creer est le dernier
3416 *      lw est aussi mis a jour
3417 *---------------------------------------------------------- */
3418
3419 int C2F(listcrehmat) (char *fname, int *lw, int *numi, int *stlw, int *m, int *n, int *lrs, unsigned long fname_len)
3420 {
3421     int ix1, il;
3422
3423     if (C2F(crehmati) (fname, stlw, m, n, lrs, &c_true, fname_len) == FALSE)
3424     {
3425         return FALSE;
3426     }
3427
3428     *stlw = *lrs + *m * *n;
3429     il = iadr(*Lstk(*lw));
3430     ix1 = il + *istk(il + 1) + 3;
3431     *istk(il + 2 + *numi) = *stlw - sadr(ix1) + 1;
3432     if (*numi == *istk(il + 1))
3433     {
3434         *Lstk(*lw + 1) = *stlw;
3435     }
3436     return TRUE;
3437 }
3438
3439 /*----------------------------------------------------------
3440 *  crehmat :
3441 *   checks that a matrix of handle of size [m,n] can be stored at position  lw
3442 *   <<pointers>> to data is returned on success
3443 *   In :
3444 *     lw : position (entier)
3445 *     m, n dimensions
3446 *   Out :
3447 *     lr : stk(lr+i-1)= h(i)
3448 *   Side effect : if matrix creation is possible
3449 *     [m,n] are stored in Scilab stack
3450 *     and lr is returned but stk(lr+..)  are unchanged
3451 *---------------------------------------------------------- */
3452
3453 int C2F(crehmat) (char *fname, int *lw, int *m, int *n, int *lr, unsigned long fname_len)
3454 {
3455
3456     if (*lw + 1 >= Bot)
3457     {
3458         Scierror(18, _("%s: Too many names.\n"), get_fname(fname, fname_len));
3459         return FALSE;
3460     }
3461     if (C2F(crehmati) (fname, Lstk(*lw), m, n, lr, &c_true, fname_len) == FALSE)
3462     {
3463         return FALSE;
3464     }
3465     *Lstk(*lw + 1) = *lr + *m * *n;
3466     return TRUE;
3467 }
3468
3469 /*------------------------------------------------------------------
3470 * getlisthmat :
3471 *    checks that spos object is a list
3472 *    checks that lnum-element of the list exists and is a matrix
3473 *    extracts matrix information(m,n,lr)
3474 *     In  :
3475 *       fname : name of calling function for error message
3476 *       topk  : stack ref for error message
3477 *       lw    : stack position
3478 *     Out :
3479 *       [m,n] matrix dimensions
3480 *       lr : stk(lr+i-1)= h(i))
3481 *------------------------------------------------------------------ */
3482
3483 int C2F(getlisthmat) (char *fname, int *topk, int *spos, int *lnum, int *m, int *n, int *lr, unsigned long fname_len)
3484 {
3485     int nv, ili;
3486
3487     if (C2F(getilist) (fname, topk, spos, &nv, lnum, &ili, fname_len) == FALSE)
3488     {
3489         return FALSE;
3490     }
3491
3492     if (*lnum > nv)
3493     {
3494         Scierror(999, _("%s: Wrong size for argument %d: At least %d expected.\n"), get_fname(fname, fname_len), Rhs + (*spos - *topk), *lnum);
3495         return FALSE;
3496     }
3497     return C2F(gethmati) (fname, topk, spos, &ili, m, n, lr, &c_true, lnum, fname_len);
3498 }
3499
3500 /*-------------------------------------------------------------------
3501 * gethmat :
3502 *     check that object at position lw is a matrix
3503 *     In  :
3504 *       fname : name of calling function for error message
3505 *       topk  : stack ref for error message
3506 *       lw    : stack position ( ``in the top sense'' )
3507 *     Out :
3508 *       [m,n] matrix dimensions
3509 *       lr : stk(lr+i-1)= h(i)
3510 *------------------------------------------------------------------- */
3511
3512 int C2F(gethmat) (char *fname, int *topk, int *lw, int *m, int *n, int *lr, unsigned long fname_len)
3513 {
3514     return C2F(gethmati) (fname, topk, lw, Lstk(*lw), m, n, lr, &c_false, &cx0, fname_len);
3515 }
3516
3517 /*-------------------------------------------------------------------
3518 * For internal use
3519 *------------------------------------------------------------------- */
3520
3521 static int C2F(gethmati) (char *fname, int *topk, int *spos, int *lw, int *m, int *n, int *lr, int *inlistx, int *nel, unsigned long fname_len)
3522 {
3523     int il;
3524
3525     il = iadr(*lw);
3526     if (*istk(il) < 0)
3527     {
3528         il = iadr(*istk(il + 1));
3529     }
3530     if (*istk(il) != sci_handles)
3531     {
3532         if (*inlistx)
3533             Scierror(999, _("%s: Wrong type for argument %d (List element: %d): Matrix of handle expected.\n"), get_fname(fname, fname_len),
3534                      Rhs + (*spos - *topk), *nel);
3535         else
3536         {
3537             Scierror(200, _("%s: Wrong type for argument #%d: Matrix of handle expected.\n"), get_fname(fname, fname_len), Rhs + (*spos - *topk));
3538         }
3539         return FALSE;
3540     }
3541     *m = *istk(il + 1);
3542     *n = *istk(il + 2);
3543     *lr = sadr(il + 4);
3544     return TRUE;
3545 }