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