← Back to branch summary

~ubuntu-branches/ubuntu/karmic/scilab/karmic

« back to all changes in this revision

Viewing changes to routines/sound/fileio.c

  • Committer: Bazaar Package Importer
  • Author(s): Torsten Werner
  • Date: 2002-03-21 16:57:43 UTC
  • Revision ID: james.westby@ubuntu.com-20020321165743-e9mv12c1tb1plztg
Tags: upstream-2.6
Import upstream version 2.6

Show diffs side-by-side

added added

removed removed

Lines of Context:
routines/sound/fileio.c
 
1
/*********************************************************************
 
2
 * This Software is ( Copyright ENPC 1998 )                          *
 
3
 * Jean-Philippe Chancelier Enpc/Cergrene                            *
 
4
 * See also the copyright below for do_printf                        *
 
5
 * interface and implementation of xxprintf and xxscanf functions    *
 
6
 * for scilab                                                        *
 
7
 *                                                                   * 
 
8
 * Modified May 2000 by S. Steer for vectorization of                *
 
9
 * *printf and *scanf                                                *
 
10
 *********************************************************************/
 
11
 
 
12
#include <math.h>
 
13
#include <stdio.h>
 
14
#ifdef __STDC__
 
15
#include <stdlib.h>
 
16
#else 
 
17
#include <malloc.h>
 
18
#endif
 
19
#include <string.h>
 
20
 
 
21
#include <ctype.h>  /* isdigit */
 
22
#include "../graphics/Math.h"
 
23
#include "../stack-c.h"
 
24
#include "../sun/Sun.h"
 
25
 
 
26
extern char * SciGetLine __PARAMS((char *));
 
27
extern FILE *GetFile __PARAMS((int *));
 
28
extern void C2F(zzledt1) __PARAMS((char *buffer, int *buf_size, int *len_line, int *eof, long int dummy1)); 
 
29
extern int C2F(xscion) __PARAMS((int *));
 
30
extern int sciprint2 __PARAMS((int i,char *fmt, ...));
 
31
static int do_printf __PARAMS((char *fname,FILE * fp, char *format,int n_args,
 
32
                              int arg_cnt,int lcount,char **strv));
 
33
 
 
34
/*if maxscan is increased don't forget to chage the (*printer)(......) 
 
35
  in do_scanf procedure */
 
36
#define MAXSCAN 30
 
37
 
 
38
typedef union {
 
39
  char * c;
 
40
  long unsigned int lui;
 
41
  short unsigned int sui;
 
42
  unsigned int ui;
 
43
  long int li;
 
44
  short int si;
 
45
  int i;
 
46
  double lf;
 
47
  float f;
 
48
} rec_entry;
 
49
typedef union {
 
50
  double d;
 
51
  char * s;
 
52
} entry;
 
53
typedef enum {SF_C,SF_S,SF_LUI,SF_SUI,SF_UI,SF_LI,SF_SI,SF_I,SF_LF,SF_F} sfdir;
 
54
static int Store_Scan __PARAMS((int *nrow,int *ncol,sfdir *type_s,sfdir *type,
 
55
                               int *retval, int*retval_s, rec_entry *buf, 
 
56
                               entry **data,int rowcount,int n));
 
57
static void Free_Scan  __PARAMS((int rowcount,int ncol,sfdir *type_s,entry **data));
 
58
static int Sci_Store __PARAMS((int nrow,int ncol,entry* data,sfdir *type,int retval));
 
59
 
 
60
int SciStrtoStr __PARAMS((int *Scistring,int *nstring,int *ptrstrings,char **strh));
 
61
 
 
62
static int do_scanf __PARAMS((char *fname,  FILE *fp, char *format,int *nargs, 
 
63
                             char *strv,int *retval,rec_entry *buf,sfdir *type));
 
64
#define RET_END -2
 
65
#define RET_BUG -1 
 
66
#define FAIL 0
 
67
#define OK 1
 
68
#define MEM_LACK -3
 
69
#define MISMATCH -4
 
70
#define NOT_ENOUGH_ARGS -5
 
71
 
 
72
static int GetString __PARAMS((char *fname,int *first,int *arg,int narg,
 
73
                              int *ir,int ic,char **sval) );
 
74
static int GetScalarInt __PARAMS((char *fname,int *first,int *arg,int narg,
 
75
                                 int *ir,int ic,int *ival));
 
76
static int GetScalarDouble  __PARAMS((char *fname,int *first,int *arg,int narg,
 
77
                                     int *ir,int ic,double *dval));
 
78
static int StringConvert __PARAMS((char *str));
 
79
static int ReadLine __PARAMS((FILE *fd));
 
80
int NumTokens __PARAMS((char *str));
 
81
 
 
82
/*********************************************************************
 
83
 * Scilab printf function OK 
 
84
 *********************************************************************/
 
85
 
 
86
int int_objprintf(fname)
 
87
     char *fname;
 
88
{
 
89
  static int l1, m1, n1, lcount, rval, k, typ, mx, mk, nk;
 
90
  Nbvars = 0;
 
91
  CheckRhs(1,1000);
 
92
  CheckLhs(0,1);
 
93
  if ( Rhs < 1 ) 
 
94
    { 
 
95
      Scierror(999,"Error:\tRhs must be > 0\r\n");
 
96
      return 0;
 
97
    }
 
98
  GetRhsVar(1,"c",&m1,&n1,&l1);
 
99
 
 
100
  mx=0;
 
101
  if (Rhs>=2) {
 
102
    GetMatrixdims(2,&mx,&nk);
 
103
    for (k=3;k<=Rhs;k++) {
 
104
      GetMatrixdims(k,&mk,&nk);
 
105
      mx = Min(mx,mk);
 
106
    }
 
107
  }
 
108
  lcount = 1;
 
109
  if (Rhs == 1) 
 
110
    rval=do_printf("printf",stdout,cstk(l1),Rhs,1,lcount,(char **)0);
 
111
  else
 
112
    while (1) 
 
113
      {
 
114
        if ((rval = do_printf("printf",stdout,cstk(l1),Rhs,1,lcount,(char **)0)) < 0) break;
 
115
        lcount++;
 
116
        if (lcount>mx) break;
 
117
      }
 
118
  if (rval == RET_BUG) return 0;
 
119
  LhsVar(1)=0; /** No return value **/
 
120
  PutLhsVar();
 
121
  return 0;
 
122
}  
 
123
 
 
124
/*********************************************************************
 
125
 * Scilab fprintf function OK 
 
126
 *********************************************************************/
 
127
 
 
128
int int_objfprintf(fname)
 
129
     char *fname;
 
130
{
 
131
  FILE *f;
 
132
  static int l1, m1, n1,l2,m2,n2,lcount,rval, mx, mk, nk, k;
 
133
  Nbvars = 0;
 
134
  CheckRhs(1,1000);
 
135
  CheckLhs(0,1);
 
136
  if ( Rhs < 2 ) 
 
137
    { 
 
138
      Scierror(999,"Error:\tRhs must be >= 2\r\n");
 
139
      return 0;
 
140
    }
 
141
  GetRhsVar(1,"i",&m1,&n1,&l1); /* file id */
 
142
  GetRhsVar(2,"c",&m2,&n2,&l2); /* format */
 
143
  if ((f= GetFile(istk(l1))) == (FILE *)0)
 
144
    {
 
145
      Scierror(999,"fprintf:\t wrong file descriptor %d\r\n",*istk(l1));
 
146
      return 0;
 
147
    }
 
148
  mx=0;
 
149
  if (Rhs>=3) {
 
150
    GetMatrixdims(3,&mx,&nk);
 
151
    for (k=4;k<=Rhs;k++) {
 
152
      GetMatrixdims(k,&mk,&nk);
 
153
      mx = Min(mx,mk);
 
154
    }
 
155
  }
 
156
  lcount=1;
 
157
  if (Rhs == 2) 
 
158
    rval=do_printf("fprintf",f,cstk(l2),Rhs,2,lcount,(char **)0);
 
159
  else
 
160
    while (1) 
 
161
      {
 
162
        if ((rval=do_printf("fprintf",f,cstk(l2),Rhs,2,lcount,(char **)0)) < 0) break;
 
163
        lcount++;
 
164
        if (lcount>mx) break;
 
165
      }
 
166
  if (rval == RET_BUG) return 0;
 
167
  LhsVar(1)=0; /** No return value **/
 
168
  PutLhsVar();
 
169
  return 0;
 
170
}  
 
171
 
 
172
/*********************************************************************
 
173
 * Scilab sprintf function OK 
 
174
 *********************************************************************/
 
175
 
 
176
int int_objsprintf(fname)
 
177
     char *fname;
 
178
{
 
179
  unsigned long lstr;
 
180
  static int l1, m1, n1,n2,lcount,rval,blk=200;
 
181
  static int k;
 
182
  char ** strs;
 
183
  char *str,*str1;
 
184
  int n,nmax,cat_to_last,ll;
 
185
  Nbvars = 0;
 
186
  CheckRhs(1,1000);
 
187
  CheckLhs(0,1);
 
188
  if ( Rhs < 1 ) 
 
189
    { 
 
190
      Scierror(999,"Error:\tRhs must be > 0\r\n");
 
191
      return 0;
 
192
    }
 
193
  GetRhsVar(1,"c",&m1,&n1,&l1);
 
194
  n=0; /* output line counter */
 
195
  nmax=0;
 
196
  strs=NULL;
 
197
  lcount=1;
 
198
  cat_to_last=0;
 
199
 
 
200
  while (1) 
 
201
    {
 
202
      if ((rval=do_printf("sprintf",(FILE *) 0,cstk(l1),Rhs,1,lcount,
 
203
                          (char **) &lstr)) < 0) break; 
 
204
      lcount++;
 
205
      str=(char *) lstr;
 
206
      str1=str;
 
207
      while (*str != '\0') {
 
208
        if (strncmp(str,"\\n",2) ==0) {
 
209
          k=(int)(str-str1);
 
210
          if (! cat_to_last) { /*add a new line */
 
211
            if (n==nmax) {
 
212
              nmax+=blk;
 
213
              if ( (strs = (char **) realloc(strs,nmax*sizeof(char **))) == NULL) goto mem;
 
214
            }
 
215
            if ((strs[n]=malloc((k+1))) == NULL) goto mem;
 
216
            strncpy(strs[n],str1, k);
 
217
            strs[n][k]='\0';
 
218
            n++;
 
219
          }
 
220
          else { /* cat to previous line */
 
221
            ll=strlen(strs[n-1]);
 
222
            if ((strs[n-1]=realloc(strs[n-1],(k+1+ll))) == NULL) goto mem;
 
223
            strncpy(&(strs[n-1][ll]),str1, k);
 
224
            strs[n-1][k+ll]='\0';
 
225
          }
 
226
          k=0;
 
227
          str+=2;
 
228
          str1=str;
 
229
          cat_to_last=0;
 
230
        }
 
231
        else
 
232
          str++;
 
233
      }
 
234
      k=(int)(str-str1);
 
235
      if (k>0) {
 
236
        if ((! cat_to_last) || (n == 0)) { /*add a new line */
 
237
          if (n==nmax) {
 
238
            nmax+=blk;
 
239
            if ( (strs = (char **) realloc(strs,nmax*sizeof(char **))) == NULL) goto mem;
 
240
          }
 
241
          if ((strs[n]=malloc((k+1))) == NULL) goto mem;
 
242
          strncpy(strs[n],str1, k);
 
243
          strs[n][k]='\0';
 
244
          n++;
 
245
          
 
246
        }
 
247
        else { /* cat to previous line */
 
248
            ll=strlen(strs[n-1]);
 
249
            if ((strs[n-1]=realloc(strs[n-1],(k+1+ll))) == NULL) goto mem;
 
250
            strncpy(&(strs[n-1][ll]),str1, k);
 
251
            strs[n-1][k+ll]='\0';
 
252
        }
 
253
      }
 
254
      if (strncmp(str-2,"\\n",2) !=0) cat_to_last=1;
 
255
      if (Rhs == 1) break;
 
256
 
 
257
    }
 
258
  if (rval == RET_BUG) return 0;
 
259
  /** Create a Scilab String : lstr must not be freed **/
 
260
  n2=1;
 
261
  CreateVarFromPtr( 2, "S", &n, &n2, strs);
 
262
  for (k=0;k<n;k++) free(strs[k]);
 
263
  free(strs);
 
264
  LhsVar(1)=2;
 
265
  PutLhsVar();    
 
266
  return 0;
 
267
 mem:
 
268
  Scierror(999,"sprintf: cannot allocate cannot allocate more memory \r\n");
 
269
  return 0;
 
270
}  
 
271
 
 
272
/*********************************************************************
 
273
 * Scilab scanf function
 
274
 *********************************************************************/
 
275
#define MAXSTR 512
 
276
 
 
277
 
 
278
int int_objscanf(fname)
 
279
     char *fname;
 
280
{
 
281
  static char String[MAXSTR];
 
282
  static int l1, m1, n1, len= MAXSTR-1,iarg,maxrow,nrow,rowcount,ncol;
 
283
  int args,retval,retval_s,lline,status,iflag,err,n_count;
 
284
  entry *data;
 
285
  rec_entry buf[MAXSCAN];
 
286
  sfdir  type[MAXSCAN],type_s[MAXSCAN];
 
287
 
 
288
  Nbvars = 0;
 
289
  CheckRhs(1,2);
 
290
  if (Rhs==2) {
 
291
    GetRhsVar(1,"i",&m1,&n1,&l1);
 
292
    if (m1*n1 != 1) {
 
293
      Scierror(999,"Error: in scanf: incorrect first argument\r\n");
 
294
      return 0;
 
295
    }
 
296
    iarg=2;
 
297
    maxrow=*istk(l1);
 
298
 
 
299
  }
 
300
  else {
 
301
    iarg=1;
 
302
    maxrow=1;
 
303
  }
 
304
  GetRhsVar(iarg,"c",&m1,&n1,&l1); /** format **/
 
305
  n_count=StringConvert(cstk(l1))+1;  /* conversion */
 
306
  /** Read a line with Scilab read function **/
 
307
  C2F(xscion)(&iflag);
 
308
  if (n_count>1) {
 
309
    Scierror(999,"Error: in scanf: format cannot include \\n \r\n");
 
310
    return 0;
 
311
  }
 
312
 
 
313
  nrow=maxrow; 
 
314
  rowcount = -1; /* number-1 of result lines already got */
 
315
  while (1) {
 
316
    rowcount++;
 
317
    if ((maxrow >= 0) && (rowcount >= maxrow)) break;
 
318
    /* get a line */
 
319
    if ( iflag == 0) 
 
320
      C2F(zzledt)(String,&len,&lline,&status,strlen(String));
 
321
    else
 
322
      C2F(zzledt1)(String,&len,&lline,&status,strlen(String));
 
323
    if(status != 0) 
 
324
      {
 
325
        Scierror(999,"Error: in scanf\r\n");
 
326
        return 0;
 
327
      }
 
328
    if (lline == 0) {String[0] = ' ';lline=1;}
 
329
    /** use the scaned line as input **/
 
330
    args = Rhs; /* args set to Rhs on entry */
 
331
    if (do_scanf("scanf",(FILE *) 0,cstk(l1),&args,String,&retval,buf,type) < 0) return 0;
 
332
 
 
333
    if ((err=Store_Scan(&nrow,&ncol,type_s,type,&retval,&retval_s,
 
334
                        buf,&data,rowcount,args)) <0 ) {
 
335
      switch (err) {
 
336
      case MISMATCH:
 
337
        if (maxrow>=0) {
 
338
          Free_Scan(rowcount,ncol,type_s,&data);
 
339
          Scierror(999,"Error: in fscanf: data mismatch\r\n");
 
340
          return 0;
 
341
        }
 
342
        break;
 
343
      case MEM_LACK:
 
344
        Free_Scan(rowcount,ncol,type_s,&data);
 
345
        Scierror(999,"Error: in scanf: cannot allocate more memory \r\n");
 
346
        return 0;
 
347
        break;
 
348
      }
 
349
      if (err ==MISMATCH) break;
 
350
    }
 
351
  } /*  while (1) */
 
352
 
 
353
  /* create Scilab variables with each column of data */
 
354
  err=Sci_Store(rowcount,ncol,data,type_s,retval_s);
 
355
  if (err==MEM_LACK) { Scierror(999,"Error: in sscanf: cannot allocate more memory \r\n");}
 
356
  return 0;
 
357
} 
 
358
 
 
359
/*********************************************************************
 
360
 * Scilab sscanf function
 
361
 *********************************************************************/
 
362
 
 
363
int int_objsscanf(fname)
 
364
     char *fname;
 
365
{
 
366
  static int l1, m1, n1,l2,m2,n2,iarg,maxrow,nrow,rowcount,ncol;
 
367
  int args,retval,retval_s,err,n_count,lw,il1,ild1,skip;
 
368
  int k;
 
369
 
 
370
  entry *data;
 
371
  rec_entry buf[MAXSCAN];
 
372
  sfdir  type[MAXSCAN],type_s[MAXSCAN];
 
373
  char* str;
 
374
 
 
375
  Nbvars = 0;
 
376
  CheckRhs(2,3);
 
377
  if (Rhs==3) {
 
378
    GetRhsVar(1,"i",&m1,&n1,&l1);
 
379
    if (m1*n1!=1) {
 
380
      Scierror(999,"Error: in sscanf: incorrect first argument\r\n");
 
381
      return 0;
 
382
    }
 
383
    iarg=2;
 
384
    maxrow=*istk(l1);
 
385
 
 
386
  }
 
387
  else {
 
388
    iarg=1;
 
389
    maxrow=1;
 
390
  }
 
391
  lw = iarg + Top - Rhs; /* Scilab string vector */
 
392
  if (! C2F(getwsmat)("sscanf",&Top,&lw,&m1,&n1,&il1,&ild1,6L)) return 0;
 
393
  GetRhsVar(iarg+1,"c",&m2,&n2,&l2); /* Format */
 
394
  n_count=StringConvert(cstk(l2))+1;  /* conversion */
 
395
  if (maxrow >= 0) 
 
396
    if (maxrow*n_count>m1*n1) {
 
397
      Scierror(999,"Error: in sscanf: not enough entries in str\r\n");
 
398
      return 0;
 
399
    }
 
400
 
 
401
  k=0;
 
402
  nrow=maxrow; 
 
403
  rowcount = -1; /* number-1 of result lines already got */
 
404
  while (1) {
 
405
    rowcount++;
 
406
    if ((maxrow >= 0) && (rowcount >= maxrow)) break;
 
407
 
 
408
    skip=*istk(ild1+k)-1;
 
409
    SciStrtoStr(istk(il1+skip),&n_count,istk(ild1+k),&str);
 
410
    k +=n_count;
 
411
      
 
412
    args = Rhs; /* args set to Rhs on entry */
 
413
    err = do_scanf("sscanf",(FILE *)0,cstk(l2),&args,str,&retval,buf,type);
 
414
    free(str);
 
415
    if ( err < 0)  return 0;
 
416
    if ((err=Store_Scan(&nrow,&ncol,type_s,type,&retval,&retval_s,
 
417
                        buf,&data,rowcount,args)) <0 ) {
 
418
      switch (err) {
 
419
      case MISMATCH:
 
420
        if (maxrow>=0) {
 
421
          Free_Scan(rowcount,ncol,type_s,&data);
 
422
          Scierror(999,"Error: in sscanf: data mismatch\r\n");
 
423
          return 0;
 
424
        }
 
425
        break;
 
426
      case MEM_LACK:
 
427
        Free_Scan(rowcount,ncol,type_s,&data);
 
428
        Scierror(999,"Error: in sscanf: cannot allocate more memory \r\n");
 
429
        return 0;
 
430
        break;
 
431
      }
 
432
      if (err==MISMATCH) break;
 
433
    }
 
434
  } /* while */
 
435
  /* create Scilab variables with each column of data */
 
436
  err=Sci_Store(rowcount,ncol,data,type_s,retval_s);
 
437
  if (err==MEM_LACK) { Scierror(999,"Error: in sscanf: cannot allocate more memory \r\n");}
 
438
  return 0;
 
439
}
 
440
 
 
441
/*********************************************************************
 
442
 * Scilab fscanf function
 
443
 *********************************************************************/
 
444
 
 
445
int int_objfscanf(fname)
 
446
     char *fname;
 
447
{
 
448
  static int l1, m1, n1,l2,m2,n2,iarg,maxrow,nrow,rowcount,ncol;
 
449
  FILE  *f;
 
450
  int args,retval,retval_s,err;
 
451
  entry *data;
 
452
  long int pos;
 
453
 
 
454
  rec_entry buf[MAXSCAN];
 
455
  sfdir  type[MAXSCAN],type_s[MAXSCAN];
 
456
 
 
457
  Nbvars = 0;
 
458
  CheckRhs(2,3);
 
459
 
 
460
  if (Rhs==3) {
 
461
    GetRhsVar(1,"i",&m1,&n1,&l1);
 
462
    if (m1*n1 != 1 ) {
 
463
      Scierror(999,"Error: in fscanf: incorrect first argument\r\n");
 
464
      return 0;
 
465
    }
 
466
    iarg=2;
 
467
    maxrow=*istk(l1);
 
468
  }
 
469
  else {
 
470
    iarg=1;
 
471
    maxrow=1;
 
472
  }
 
473
 
 
474
  GetRhsVar(iarg,"i",&m1,&n1,&l1);
 
475
  GetRhsVar(iarg+1,"c",&m2,&n2,&l2);/* format */
 
476
 
 
477
  StringConvert(cstk(l2));  /* conversion */
 
478
  if ((f= GetFile(istk(l1))) == (FILE *)0)
 
479
    {
 
480
      Scierror(999,"fprintf:\t wrong file descriptor %d\r\n",*istk(l1));
 
481
      return 0;
 
482
    }
 
483
  nrow=maxrow; 
 
484
  rowcount = -1;
 
485
  while (1) {
 
486
    rowcount++;
 
487
    if ((maxrow >= 0) && (rowcount >= maxrow)) break;
 
488
    args = Rhs; /* args set to Rhs on entry */
 
489
    pos=ftell(f);
 
490
    if ( do_scanf("fscanf",f,cstk(l2),&args,(char *)0,&retval,buf,type) < 0 )  return 0;
 
491
    if ((err=Store_Scan(&nrow,&ncol,type_s,type,&retval,&retval_s,
 
492
                        buf,&data,rowcount,args)) <0 ) {
 
493
      switch (err) {
 
494
      case MISMATCH:
 
495
        if (maxrow>=0) {
 
496
          Free_Scan(rowcount,ncol,type_s,&data);
 
497
          Scierror(999,"Error: in fscanf: data mismatch\r\n");
 
498
          return 0;
 
499
        }
 
500
        fseek(f,pos,SEEK_SET);
 
501
        break;
 
502
      case MEM_LACK:
 
503
        Free_Scan(rowcount,ncol,type_s,&data);
 
504
        Scierror(999,"Error: in fscanf: cannot allocate more memory \r\n");
 
505
        return 0;
 
506
        break;
 
507
      }
 
508
      if (err==MISMATCH) break;
 
509
    }
 
510
  } /* while */
 
511
 
 
512
 
 
513
  /* create Scilab variable with each column of data */
 
514
  err=Sci_Store(rowcount,ncol,data,type_s,retval_s);
 
515
  if (err==MEM_LACK) { Scierror(999,"Error: in sscanf: cannot allocate more memory \r\n");}
 
516
  return 0;
 
517
}  
 
518
 
 
519
 
 
520
/*********************************************************************
 
521
 * Scilab numtokens
 
522
 *********************************************************************/
 
523
 
 
524
int int_objnumTokens(fname)
 
525
     char *fname;
 
526
{
 
527
  static int l1,m1,n1,l2,un=1;
 
528
  Nbvars = 0;
 
529
  CheckRhs(1,1);
 
530
  GetRhsVar(1,"c",&m1,&n1,&l1);
 
531
  StringConvert(cstk(l1));  /* conversion */
 
532
  CreateVar(2, "d", &un, &un, &l2);
 
533
  *stk(l2) = (double) NumTokens(cstk(l1));
 
534
  LhsVar(1) = 2;
 
535
  PutLhsVar();
 
536
  return 0;
 
537
}  
 
538
 
 
539
 
 
540
/*********************************************************************
 
541
 * Scilab fprintfMat function
 
542
 *********************************************************************/
 
543
 
 
544
int int_objfprintfMat(fname)
 
545
     char *fname;
 
546
{
 
547
  int l1, m1, n1,l2,m2,n2,m3,n3,l3,i,j;
 
548
  FILE  *f;
 
549
  char *Format;
 
550
  Nbvars = 0;
 
551
  CheckRhs(1,3); 
 
552
  CheckLhs(1,1);
 
553
  GetRhsVar(1,"c",&m1,&n1,&l1);/* file name */
 
554
  GetRhsVar(2,"d",&m2,&n2,&l2);/* data */
 
555
  if ( Rhs == 3) 
 
556
    {
 
557
      GetRhsVar(3,"c",&m3,&n3,&l3);/* format */
 
558
      StringConvert(cstk(l3));  /* conversion */
 
559
      Format = cstk(l3);
 
560
    }
 
561
  else 
 
562
    {
 
563
      Format = "%f";
 
564
    }
 
565
  if (( f = fopen(cstk(l1),"w")) == (FILE *)0) 
 
566
    {
 
567
      Scierror(999,"Error: in function %s, cannot open file %s\r\n",
 
568
               fname,cstk(l1));
 
569
      return 0;
 
570
    }
 
571
  for (i = 0 ; i < m2 ; i++ ) 
 
572
    {
 
573
      for ( j = 0 ; j < n2 ; j++) 
 
574
        {
 
575
          fprintf(f,Format,*stk(l2+i + m2*j));
 
576
          fprintf(f," ");
 
577
        }
 
578
      fprintf(f,"\n");
 
579
    }
 
580
  fclose(f);
 
581
  LhsVar(1)=0 ; /** no return value **/
 
582
  PutLhsVar();
 
583
  return 0;
 
584
}  
 
585
 
 
586
/*********************************************************************
 
587
 * Scilab fscanMat function
 
588
 *********************************************************************/
 
589
#define INFOSIZE 1024
 
590
static char Info[INFOSIZE];
 
591
 
 
592
int int_objfscanfMat(fname)
 
593
     char *fname;
 
594
{
 
595
  double x;
 
596
  static int l1, m1, n1,l2,m2,n2;
 
597
  int i,j,rows,cols,lres,n;
 
598
  int vl=-1;
 
599
  FILE  *f;
 
600
  char *Format;
 
601
  Nbvars = 0;
 
602
  CheckRhs(1,1); /** just 1 <<pour l''instant>> **/
 
603
  CheckLhs(1,1);
 
604
  GetRhsVar(1,"c",&m1,&n1,&l1);/* file name */
 
605
  if ( Rhs == 2) 
 
606
    {
 
607
      GetRhsVar(2,"c",&m2,&n2,&l2);/* format */
 
608
      StringConvert(cstk(l2));  /* conversion */
 
609
      Format = cstk(l2);
 
610
    }
 
611
  else 
 
612
    {
 
613
      Format = 0;
 
614
    }
 
615
  if (( f = fopen(cstk(l1),"r")) == (FILE *)0) 
 
616
    {
 
617
      Scierror(999,"Error: in function %s, cannot open file %s\r\n",
 
618
               fname,cstk(l1));
 
619
      return 0;
 
620
    }
 
621
  /*** first pass to get colums and rows ***/
 
622
  strcpy(Info,"--------");
 
623
  n =0; 
 
624
  while ( sscanf(Info,"%lf",&x) <= 0 && n != EOF ) 
 
625
    { n=ReadLine(f); vl++;}
 
626
  if ( n == EOF )
 
627
    {
 
628
      Scierror(999,"Error: in function %s, cannot read data in file %s\r\n",
 
629
               fname,cstk(l1));
 
630
      fclose(f);
 
631
      return 0;
 
632
    }
 
633
  cols = NumTokens(Info);
 
634
  rows = 1;
 
635
  while (1) 
 
636
    { 
 
637
      n=ReadLine(f);
 
638
      if ( n == EOF ||  n == 0 ) break;
 
639
      if ( sscanf(Info,"%lf",&x) <= 0) break;
 
640
      rows++;
 
641
    }
 
642
  if ( cols == 0 || rows == 0) rows=cols=0;
 
643
  CreateVar(Rhs+1, "d", &rows, &cols, &lres);
 
644
  /** second pass to read data **/
 
645
  rewind(f);
 
646
  /** skip non numeric lines **/
 
647
  for ( i = 0 ; i < vl ; i++) ReadLine(f);
 
648
  for (i=0; i < rows ;i++)
 
649
    for (j=0;j < cols;j++)
 
650
      { 
 
651
        double xloc;
 
652
        fscanf(f,"%lf",&xloc);
 
653
        *stk(lres+i+rows*j)=xloc;
 
654
      }
 
655
  fclose(f);
 
656
  LhsVar(1)=Rhs+1;
 
657
  PutLhsVar();
 
658
  return 0;
 
659
}  
 
660
 
 
661
static int ReadLine_Old(fd)
 
662
     FILE *fd;
 
663
{
 
664
  int n;
 
665
  n= fscanf(fd,"%[^\n]%*c",Info);
 
666
  if ( n==0) n=fscanf(fd,"%*c");
 
667
  return(n);
 
668
}
 
669
 
 
670
static int ReadLine(fd)
 
671
     FILE *fd;
 
672
{
 
673
  int n=0;
 
674
  while (1)
 
675
    {
 
676
      char c = getc(fd);
 
677
      if ( n > INFOSIZE) 
 
678
        {
 
679
          sciprint("Error Info buffer is too small (too many columns in your file ?)\r\n");
 
680
          return EOF ;/** A changer XXXX : pour retourner un autre message **/
 
681
        }
 
682
      Info[n]= c ; 
 
683
      if ( c == '\n') { Info[n] = '\0' ; return 1;}
 
684
      else if ( c == EOF ) return EOF;  
 
685
      n++;
 
686
    }
 
687
}
 
688
 
 
689
 
 
690
 
 
691
/***************************************
 
692
 * Test de TestNumTokens 
 
693
 ***************************************/
 
694
#ifdef TEST 
 
695
static void TestNumTokens()
 
696
{
 
697
  char buf[30], format[20];
 
698
  strcpy(format,"%d Tokens in <%s>\n");
 
699
  strcpy(buf,"un deux trois");fprintf(stderr,format,NumTokens(buf),buf);
 
700
  strcpy(buf,"un");  fprintf(stderr,format,NumTokens(buf),buf);
 
701
  strcpy(buf,"un deux trois  "); fprintf(stderr,format,NumTokens(buf),buf);
 
702
  strcpy(buf,"un\tdeux\ttrois\n"); fprintf(stderr,format,NumTokens(buf),buf);
 
703
  fprintf(stderr,format, NumTokens((char *) 0) , ((char *) 0));
 
704
  strcpy(buf,"un\t");  fprintf(stderr,format,NumTokens(buf),buf);
 
705
  strcpy(buf," \t\nun");  fprintf(stderr,format,NumTokens(buf),buf);
 
706
  strcpy(buf,"1.0  1.0");fprintf(stderr,format,NumTokens(buf),buf);
 
707
}
 
708
#endif 
 
709
 
 
710
int NumTokens(string)
 
711
     char string[];
 
712
{
 
713
  char buf[128];
 
714
  int n=1;
 
715
  int lnchar=0,ntok=-1;
 
716
  int length = strlen(string)+1;
 
717
  if (string != 0)
 
718
    { 
 
719
      /** Counting leading white spaces **/
 
720
      sscanf(string,"%*[ \t\n]%n",&lnchar);
 
721
      while ( n != 0 && n != EOF && lnchar <= length  )
 
722
        { 
 
723
          int nchar1=0,nchar2=0;
 
724
          ntok++;
 
725
          n= sscanf(&(string[lnchar]),
 
726
                    "%[^ \n\t]%n%*[ \t\n]%n",buf,&nchar1,&nchar2);
 
727
          lnchar += (nchar2 <= nchar1) ? nchar1 : nchar2 ;
 
728
        }
 
729
      return(ntok);
 
730
    }
 
731
  return(FAIL);
 
732
}
 
733
 
 
734
 
 
735
/***************************************************************
 
736
 * Emulation of Ansi C XXscanf functions 
 
737
 * The number of scaned object is hardwired (MAXSCAN) 
 
738
 * and scaned strings (%s,%c %[) are limited to MAX_STR characters
 
739
 *
 
740
 * XXXX Could be changed to eliminate the MAXSCAN limitation 
 
741
 * 
 
742
 ****************************************************************/
 
743
 
 
744
#define MAX_STR 1024
 
745
 
 
746
#define VPTR void * 
 
747
 
 
748
 
 
749
typedef int (*PRINTER) __PARAMS((FILE *, char *,...));
 
750
typedef int (*FLUSH) __PARAMS((FILE *));
 
751
 
 
752
int voidflush(fp) 
 
753
     FILE *fp ;
 
754
{
 
755
  return 0;
 
756
};
 
757
 
 
758
static int do_scanf (fname,fp,format,nargs,strv,retval,buf,type)
 
759
     char *fname;
 
760
     FILE *fp;
 
761
     char *format;
 
762
     int  *nargs;
 
763
     char *strv;
 
764
     int *retval;
 
765
     rec_entry buf[];
 
766
     sfdir  type[];
 
767
{
 
768
  int i;
 
769
  char sformat[MAX_STR];
 
770
  void *ptrtab[MAXSCAN];
 
771
  int nc[MAXSCAN];
 
772
  int n_directive_count=0;
 
773
  char save,directive;
 
774
  char *p,*p1;
 
775
  register char *q;
 
776
  char *target,*sval;
 
777
  int l_flag=0, h_flag=0,width_flag,width_val,ign_flag,str_width_flag=0;
 
778
  int num_conversion = -1;      /* for error messages and counting arguments*/
 
779
 
 
780
 
 
781
  PRINTER printer;              /* pts at fprintf() or sprintf() */
 
782
  if (fp == (FILE *) 0)         
 
783
    {
 
784
      /* doing sscanf or scanf */
 
785
      target = strv;
 
786
      printer = (PRINTER) sscanf;
 
787
    }
 
788
  else
 
789
    {
 
790
      /* doing fscanf */
 
791
      target = (char *) fp;
 
792
      printer = (PRINTER) fscanf;
 
793
    }
 
794
  
 
795
  q = format;
 
796
  *retval = 0;
 
797
 
 
798
  /* Traverse format string, doing scanf(). */
 
799
  while (1)
 
800
    {
 
801
      /* scanf */
 
802
      p=q;
 
803
      while (*q != '%' && *q != '\0' ) q++;
 
804
      if ( *q == '%' && *(q+1) == '%' ) 
 
805
        {
 
806
          q=q+2;
 
807
          while (*q != '%' && *q != '\0' ) q++;
 
808
        }
 
809
      if (*q == 0) 
 
810
        {
 
811
          break ;
 
812
        }
 
813
 
 
814
      q++; /** q point to character following % **/
 
815
 
 
816
      
 
817
      /* 
 
818
       * We have found a conversion specifier, figure it out,
 
819
       * then scan the data asociated with it.
 
820
       */
 
821
 
 
822
 
 
823
      /* mark the '%' with p1 */
 
824
      
 
825
      p1 = q - 1; 
 
826
 
 
827
      /* check for width field */
 
828
 
 
829
      while ( isdigit(((int)*q)) ) q++;
 
830
      width_flag =0;
 
831
 
 
832
      if ( p1+1 != q ) 
 
833
        {         
 
834
          char w= *q;
 
835
          *q='\0';
 
836
          width_flag = 1;
 
837
          sscanf(p1+1,"%d",&width_val);
 
838
          *q=w;
 
839
        }
 
840
 
 
841
      /* check for ignore argument */
 
842
 
 
843
      ign_flag=0;
 
844
 
 
845
      if (*q == '*')
 
846
        {
 
847
          /* Ignore the argument in the input args */
 
848
          /*num_conversion = Max(num_conversion-1,0);*/
 
849
          ign_flag = 1;
 
850
          q++;
 
851
        }
 
852
      else
 
853
 
 
854
      /* check for %l or %h */
 
855
 
 
856
      l_flag = h_flag = 0;
 
857
 
 
858
      if (*q == 'l')
 
859
        {
 
860
          q++;
 
861
          l_flag = 1;
 
862
        }
 
863
      else if (*q == 'h')
 
864
        {
 
865
          q++;
 
866
          h_flag = 1;
 
867
        }
 
868
 
 
869
      /* directive points to the scan directive  */
 
870
 
 
871
      directive = *q++;
 
872
 
 
873
      if ( directive == '[' )
 
874
        {
 
875
          char *q1=q--;
 
876
          /** we must find the closing bracket **/
 
877
          while ( *q1 != '\0' && *q1 != ']') q1++;
 
878
          if ( *q1 == '\0') 
 
879
            {
 
880
              Scierror(998,"Error:\tscanf, unclosed [ directive\r\n");
 
881
              return RET_BUG;
 
882
            }
 
883
          if ( q1 == q +1 || strncmp(q,"[^]",3)==0 ) 
 
884
            {
 
885
              q1++;
 
886
              while ( *q1 != '\0' && *q1 != ']') q1++;  
 
887
              if ( *q1 == '\0') 
 
888
                {
 
889
                  Scierror(998,"Error:\tscanf unclosed [ directive\r\n");
 
890
                  return RET_BUG;
 
891
                }
 
892
            }
 
893
          directive = *q1++;
 
894
          q=q1;
 
895
        }
 
896
 
 
897
      /** accumulate characters in the format up to next % directive **/
 
898
      /*** unused 
 
899
      while ( *q != '\0' && *q != '%' ) q++;
 
900
      if ( *q == '%' && *(q+1) == '%' ) 
 
901
        {
 
902
          q=q+2;
 
903
          while (*q != '%' && *q != '\0' ) q++;
 
904
        }
 
905
        **/
 
906
      save = *q;
 
907
      /* *q = 0; */
 
908
      
 
909
      /** if (debug) Sciprintf("Now directive [%s],%c\r\n",p,directive); **/
 
910
      
 
911
      if ( ign_flag != 1) 
 
912
        {
 
913
          num_conversion++;
 
914
          if ( num_conversion > MAXSCAN ) 
 
915
            {
 
916
              Scierror(998,"Error:\tscanf too many (%d > %d) conversion required\r\n",
 
917
                       num_conversion,MAXSCAN);
 
918
              return RET_BUG;
 
919
            }
 
920
          switch (directive )
 
921
            {
 
922
            case ']':
 
923
              if (width_flag == 0 ) str_width_flag = 1;
 
924
              if (width_flag == 1 && width_val > MAX_STR-1 )
 
925
                {
 
926
                  Scierror(998,"Error:\tscanf, width field %d is too long (> %d) for %%[ directive\r\n",
 
927
                           width_val,MAX_STR-1);
 
928
                  return RET_BUG;
 
929
                }
 
930
              if ((buf[num_conversion].c=malloc(MAX_STR))==NULL) return MEM_LACK;
 
931
              ptrtab[num_conversion] =  buf[num_conversion].c;
 
932
              type[num_conversion] = SF_S;
 
933
              break;
 
934
            case 's':
 
935
              if (l_flag + h_flag) {
 
936
                Scierror(998,"Error:\tscanf: bad conversion\r\n");
 
937
                return RET_BUG;
 
938
              }
 
939
              if (width_flag == 0 ) str_width_flag = 1;
 
940
              if (width_flag == 1 && width_val > MAX_STR-1 )
 
941
                {
 
942
                  Scierror(998,"Error:\tscanf, width field %d is too long (< %d) for %%s directive\r\n",
 
943
                           width_val,MAX_STR-1);
 
944
                  return RET_BUG;
 
945
                }
 
946
              if ((buf[num_conversion].c=malloc(MAX_STR))==NULL) return MEM_LACK;
 
947
              ptrtab[num_conversion] =  buf[num_conversion].c;
 
948
              type[num_conversion] = SF_S;
 
949
              break;
 
950
            case 'c':
 
951
              if (l_flag + h_flag) {
 
952
                Scierror(998,"Error:\tscanf: bad conversion\r\n");
 
953
                return RET_BUG;
 
954
              }
 
955
              if ( width_flag == 1 ) 
 
956
                nc[num_conversion ] = width_val;
 
957
              else
 
958
                nc[num_conversion ] = 1;
 
959
              if (width_flag == 1 && width_val > MAX_STR-1 )
 
960
                {
 
961
                  Scierror(998,"Error:\tscanf width field %d is too long (< %d) for %%c directive\r\n",
 
962
                           width_val,MAX_STR-1);
 
963
                  return RET_BUG;
 
964
                }
 
965
              if ((buf[num_conversion].c=malloc(MAX_STR))==NULL) return MEM_LACK;
 
966
              ptrtab[num_conversion] =  buf[num_conversion].c;
 
967
              type[num_conversion] = SF_C;
 
968
              break;
 
969
            case 'o':
 
970
            case 'u':
 
971
            case 'x':
 
972
            case 'X':
 
973
              if ( l_flag ) 
 
974
                {
 
975
                  ptrtab[num_conversion] =  &buf[num_conversion].lui;
 
976
                  type[num_conversion] = SF_LUI;
 
977
                }
 
978
              else if ( h_flag) 
 
979
                {
 
980
                  ptrtab[num_conversion] =  &buf[num_conversion].sui;
 
981
                  type[num_conversion] = SF_SUI;
 
982
                }
 
983
              else 
 
984
                {
 
985
                  ptrtab[num_conversion] =  &buf[num_conversion].ui;
 
986
                  type[num_conversion] = SF_UI;
 
987
                }
 
988
              break;
 
989
            case 'D':
 
990
              ptrtab[num_conversion] =  &buf[num_conversion].li;
 
991
              type[num_conversion] = SF_LI;
 
992
              break;
 
993
            case 'n':
 
994
              /** count the n directives since they are not counted by retval **/
 
995
              n_directive_count++;
 
996
            case 'i':
 
997
            case 'd':
 
998
              if ( l_flag ) 
 
999
                {
 
1000
                  ptrtab[num_conversion] =  &buf[num_conversion].li;
 
1001
                  type[num_conversion] = SF_LI;
 
1002
                }
 
1003
              else if ( h_flag) 
 
1004
                {
 
1005
                  ptrtab[num_conversion] =  &buf[num_conversion].si;
 
1006
                  type[num_conversion] = SF_SI;
 
1007
                }
 
1008
              else 
 
1009
                {
 
1010
                  ptrtab[num_conversion] =  &buf[num_conversion].i;
 
1011
                  type[num_conversion] = SF_I;
 
1012
                }
 
1013
              break;
 
1014
            case 'e':
 
1015
            case 'f':
 
1016
            case 'g':
 
1017
            case 'E':
 
1018
            case 'G':
 
1019
              if (h_flag)
 
1020
                {
 
1021
                  Scierror(998,"Error:\tscanf: bad conversion\r\n");
 
1022
                  return RET_BUG;
 
1023
                }
 
1024
              else if (l_flag) 
 
1025
                {
 
1026
                  ptrtab[num_conversion] =  &buf[num_conversion].lf;
 
1027
                  type[num_conversion] = SF_LF;
 
1028
                }
 
1029
              else
 
1030
                {
 
1031
                  ptrtab[num_conversion] =  &buf[num_conversion].f;
 
1032
                  type[num_conversion] = SF_F;
 
1033
                }
 
1034
              break;
 
1035
            default:
 
1036
              Scierror(998,"Error:\tscanf: bad conversion\r\n");
 
1037
              return RET_BUG;
 
1038
            }
 
1039
          *q = save;
 
1040
        }
 
1041
    }
 
1042
  /** we replace %s and %[ directive with a max length field **/
 
1043
  
 
1044
  if ( str_width_flag == 1) 
 
1045
    {
 
1046
      char *f1=format;
 
1047
      char *f2=sformat;
 
1048
      char *slast = sformat + MAX_STR-1 -4;
 
1049
      while ( *f1 != '\0'  ) 
 
1050
        {
 
1051
          int n;
 
1052
          *f2++ = *f1++;
 
1053
          
 
1054
          if ( *(f1-1) == '%' && ( *(f1) == 's'  || *(f1) == '['))
 
1055
            {
 
1056
              n=sprintf(f2,"%d",MAX_STR-1);
 
1057
              f2 += n;
 
1058
              *f2++ = *f1++;
 
1059
            }
 
1060
          if ( f2 == slast )
 
1061
            {
 
1062
              Scierror(998,"Error:\tscanf, format is too long (> %d) \r\n",MAX_STR-1);
 
1063
              return RET_BUG;
 
1064
            }
 
1065
        }
 
1066
      *f2='\0';
 
1067
      format = sformat;
 
1068
    }
 
1069
    
 
1070
 
 
1071
  /** Calling scanf function : 
 
1072
    Only  num_conversion +1 qrgument are used 
 
1073
    the last arguments transmited points to nothing 
 
1074
    but this is not a problem since they won't be used ***/
 
1075
 
 
1076
 
 
1077
  *retval = (*printer) ((VPTR) target,format,ptrtab[0],ptrtab[1],ptrtab[2],
 
1078
                        ptrtab[3],ptrtab[4],ptrtab[5],ptrtab[6],ptrtab[7],
 
1079
                        ptrtab[8],ptrtab[9],ptrtab[10],ptrtab[11],ptrtab[12],
 
1080
                        ptrtab[13],ptrtab[14],ptrtab[15],ptrtab[16],ptrtab[17],
 
1081
                        ptrtab[18],ptrtab[19],ptrtab[20],ptrtab[21],ptrtab[22],
 
1082
                        ptrtab[23],ptrtab[24],ptrtab[25],ptrtab[26],ptrtab[27],
 
1083
                        ptrtab[28],ptrtab[29]);
 
1084
  /** *nargs counts the number of corectly scaned arguments **/
 
1085
  *nargs = Min(num_conversion+1,Max(*retval+n_directive_count,0));
 
1086
 
 
1087
  for ( i=1 ; i <= *nargs ; i++) 
 
1088
    if ( type[i-1]  == SF_C ) {
 
1089
      sval=(char *) ptrtab[i-1];
 
1090
      sval[nc[i-1]]='\0';
 
1091
    }
 
1092
  return 0;
 
1093
}
 
1094
 
 
1095
 
 
1096
/***************************************************************
 
1097
                                                                
 
1098
  do_printf: code extraced from RLab and hacked for Scilab 
 
1099
              by Jean-Philippe Chancelier 1998. 
 
1100
 
 
1101
    Copyright (C) 1995  Ian R. Searle
 
1102
    This program is free software; you can redistribute it and/or modify
 
1103
    it under the terms of the GNU General Public License as published by
 
1104
    the Free Software Foundation; either version 2 of the License, or
 
1105
    (at your option) any later version.
 
1106
 
 
1107
    This program is distributed in the hope that it will be useful,
 
1108
    but WITHOUT ANY WARRANTY; without even the implied warranty of
 
1109
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 
1110
    GNU General Public License for more details.
 
1111
 
 
1112
    You should have received a copy of the GNU General Public License
 
1113
    along with this program; if not, write to the Free Software
 
1114
    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 
1115
 *************************************************************** */
 
1116
 
 
1117
 
 
1118
/*---------- types and defs for doing printf ------------*/
 
1119
#define  PF_C           0
 
1120
#define  PF_S           1
 
1121
#define  PF_D           2       /* int conversion */
 
1122
#define  PF_LD          3       /* long int */
 
1123
#define  PF_F           4       /* float conversion */
 
1124
 
 
1125
/* for switch on number of '*' and type */
 
1126
 
 
1127
#define  AST(num,type)  (5*(num)+(type))
 
1128
 
 
1129
/* Buffer for printf **/
 
1130
 
 
1131
#define MAX_SPRINTF_SIZE  4096
 
1132
static char sprintf_buff[MAX_SPRINTF_SIZE];
 
1133
static char *sprintf_limit = sprintf_buff + MAX_SPRINTF_SIZE;
 
1134
 
 
1135
static int do_printf (fname,fp,format,nargs,argcnt,lcount,strv)
 
1136
     char *fname;
 
1137
     FILE *fp;
 
1138
     char *format;
 
1139
     int nargs,argcnt,lcount;
 
1140
     char **strv;
 
1141
{
 
1142
  int previous_t=0; 
 
1143
  int m1;
 
1144
  char save;
 
1145
  char *p;
 
1146
  register char *q;
 
1147
  char *target;
 
1148
  int l_flag, h_flag;           /* seen %ld or %hd  */
 
1149
  int ast_cnt;
 
1150
  int ast[2];
 
1151
  double dval = 0.0;
 
1152
  int rval=0;
 
1153
  char *sval;
 
1154
  int num_conversion = 0;       /* for error messages */
 
1155
  int pf_type = 0;              /* conversion type */
 
1156
  PRINTER printer;              /* pts at fprintf() or sprintf() */
 
1157
  FLUSH   flush;
 
1158
  int arg_cnt,ccount;
 
1159
 
 
1160
  int retval;                   /* Attempt to return C-printf() return-val */
 
1161
  arg_cnt = argcnt;
 
1162
  ccount = 1;
 
1163
 
 
1164
  q = format;
 
1165
  retval = 0;
 
1166
 
 
1167
  if (fp == (FILE *) 0)         
 
1168
    {
 
1169
      /* doing sprintf */
 
1170
      target = sprintf_buff;
 
1171
      flush = voidflush;
 
1172
      printer = (PRINTER) sprintf;
 
1173
    }
 
1174
  else if ( fp == stdout ) 
 
1175
    {
 
1176
      /** doing printf **/
 
1177
      target =  (char *) 0; /* unused */
 
1178
      flush = fflush;
 
1179
      printer = (PRINTER) sciprint2;
 
1180
    }
 
1181
  else 
 
1182
    {
 
1183
      /* doing fprintf */
 
1184
      target = (char *) fp;     /* will never change */
 
1185
      flush = fflush;
 
1186
      printer = (PRINTER) fprintf;
 
1187
    }
 
1188
 
 
1189
  /* Traverse format string, doing printf(). */
 
1190
  while (1)
 
1191
    {
 
1192
      if (fp)                   /* printf */
 
1193
        /** XXXX on pourrait couper en deux pour separer fp==stdout et fp == file **/
 
1194
        {
 
1195
          while (*q != '%')
 
1196
            {
 
1197
              switch (*q) 
 
1198
                {
 
1199
                case 0 : 
 
1200
                  fflush (fp);
 
1201
                  return (retval);
 
1202
                  break;
 
1203
                case '\\':
 
1204
                  q++;
 
1205
                  switch (*q) 
 
1206
                    {
 
1207
                    case 0 : 
 
1208
                      fflush (fp);
 
1209
                      return (retval);
 
1210
                      break;
 
1211
                    case 'r':
 
1212
                      (*printer) ((VPTR) target, "\r");
 
1213
                      q++;
 
1214
                      retval++;
 
1215
                      break;
 
1216
                    case 'n':
 
1217
                      if ( fp == stdout ) 
 
1218
                        (*printer) ((VPTR) target, "\r");
 
1219
                      (*printer) ((VPTR) target, "\n");
 
1220
                      q++;
 
1221
                      retval++;
 
1222
                      break;
 
1223
                    case 't':
 
1224
                      (*printer) ((VPTR) target, "\t");
 
1225
                      q++;
 
1226
                      retval++;
 
1227
                      break;
 
1228
                    case '\\':
 
1229
                      (*printer) ((VPTR) target, "\\");
 
1230
                      q++;
 
1231
                      retval++;
 
1232
                      break;
 
1233
                    default:
 
1234
                      /**  putc (*q, fp); **/
 
1235
                      (*printer) ((VPTR) target, "%c",*q);
 
1236
                      q++;
 
1237
                      retval++;
 
1238
                    }
 
1239
                  break;
 
1240
                default:
 
1241
                  /**  putc (*q, fp); **/
 
1242
                  (*printer) ((VPTR) target, "%c",*q);
 
1243
                  q++;
 
1244
                  retval++;
 
1245
                  break;
 
1246
                }
 
1247
            }
 
1248
        }
 
1249
      else
 
1250
        {
 
1251
          /* sprintf() */
 
1252
          while (*q != '%')
 
1253
            {
 
1254
              if (*q == 0)
 
1255
                {
 
1256
                  if (target > sprintf_limit)   /* damaged */
 
1257
                    {
 
1258
                      Scierror(998,"Error:\tsprintf problem, buffer too small\r\n");
 
1259
                      return RET_BUG;
 
1260
                    }
 
1261
                  else
 
1262
                    {
 
1263
                      /* really done */
 
1264
                      *target = '\0';
 
1265
                      *strv = sprintf_buff;
 
1266
                      return (retval);
 
1267
                    }
 
1268
                }
 
1269
              else
 
1270
                {
 
1271
                  *target++ = *q++;
 
1272
                  retval++;
 
1273
                }
 
1274
            }
 
1275
        }
 
1276
 
 
1277
      num_conversion++;
 
1278
 
 
1279
      if (*++q == '%')          /* %% */
 
1280
        {
 
1281
          if (fp)
 
1282
            {
 
1283
              /** putc (*q, fp); **/
 
1284
              (*printer) ((VPTR) target, "%c",*q);
 
1285
              retval++;
 
1286
            }
 
1287
          else
 
1288
            {
 
1289
              *target++ = *q;
 
1290
            }
 
1291
          q++;
 
1292
          continue;
 
1293
        }
 
1294
 
 
1295
      /* 
 
1296
       * We have found a conversion specifier, figure it out,
 
1297
       * then print the data associated with it.
 
1298
       */
 
1299
 
 
1300
 
 
1301
      /* mark the '%' with p */
 
1302
      p = q - 1;
 
1303
 
 
1304
      /* eat the flags */
 
1305
      while (*q == '-' || *q == '+' || *q == ' ' ||
 
1306
             *q == '#' || *q == '0')
 
1307
        q++;
 
1308
 
 
1309
      ast_cnt = 0;              /* asterisk count */
 
1310
      if (*q == '*')
 
1311
        {
 
1312
          /* Use current arg as field width spec */
 
1313
          rval=GetScalarInt(fname,&previous_t,&arg_cnt,nargs,&ccount,lcount,&m1);
 
1314
          if (rval <= 0) {
 
1315
            if (rval== NOT_ENOUGH_ARGS) goto bad;
 
1316
            return rval;
 
1317
          }
 
1318
                           
 
1319
          ast[ast_cnt++] = m1;
 
1320
          q++;
 
1321
 
 
1322
        }
 
1323
      else
 
1324
        while ( isdigit(((int)*q)))  q++;
 
1325
      /* width is done */
 
1326
 
 
1327
      if (*q == '.')            /* have precision */
 
1328
        {
 
1329
          q++;
 
1330
          if (*q == '*')
 
1331
            {
 
1332
              /* Use current arg as precision spec */
 
1333
              rval=GetScalarInt(fname,&previous_t,&arg_cnt,nargs,&ccount,lcount,&m1);
 
1334
              if (rval <= 0) {
 
1335
                if (rval== NOT_ENOUGH_ARGS) goto bad;
 
1336
                return rval;
 
1337
              }
 
1338
              ast[ast_cnt++] = m1;
 
1339
              q++;
 
1340
            }
 
1341
          else
 
1342
            while ( isdigit(((int)*q)) ) q++;
 
1343
        }
 
1344
 
 
1345
 
 
1346
      l_flag = h_flag = 0;
 
1347
 
 
1348
      if (*q == 'l')
 
1349
        {
 
1350
          q++;
 
1351
          l_flag = 1;
 
1352
        }
 
1353
      else if (*q == 'h')
 
1354
        {
 
1355
          q++;
 
1356
          h_flag = 1;
 
1357
        }
 
1358
 
 
1359
      /* Set pf_type and load val */
 
1360
      switch (*q++)
 
1361
        {
 
1362
        case 's':
 
1363
          if (l_flag + h_flag)
 
1364
            Scierror(998,"Warning:\tprintf: bad conversion l or h flag mixed with s directive\r\n");
 
1365
          rval=GetString(fname,&previous_t,&arg_cnt,nargs,&ccount,lcount,&sval);
 
1366
          if (rval <= 0) {
 
1367
            if (rval== NOT_ENOUGH_ARGS) goto bad;
 
1368
            return rval;
 
1369
          }
 
1370
          pf_type = PF_S;
 
1371
          break;
 
1372
        case 'c':
 
1373
          if (l_flag + h_flag)
 
1374
            Scierror(998,"Warning:\tprintf: bad conversion l or h flag mixed with c directive\r\n");
 
1375
          rval=GetString(fname,&previous_t,&arg_cnt,nargs,&ccount,lcount,&sval);
 
1376
          if (rval <= 0) {
 
1377
            if (rval== NOT_ENOUGH_ARGS) goto bad;
 
1378
            return rval;
 
1379
          }
 
1380
          pf_type = PF_C;
 
1381
          break;
 
1382
        case 'd':
 
1383
          rval=GetScalarDouble(fname,&previous_t,&arg_cnt,nargs,&ccount,lcount,&dval);
 
1384
          if (rval <= 0) {
 
1385
            if (rval== NOT_ENOUGH_ARGS) goto bad;
 
1386
            return rval;
 
1387
          }
 
1388
          pf_type = PF_D;
 
1389
          break;
 
1390
 
 
1391
        case 'o':
 
1392
          Scierror(998,"Error:\tprintf: \"o\" format not allowed\r\n");
 
1393
          return RET_BUG;
 
1394
          break;
 
1395
 
 
1396
        case 'x':
 
1397
          rval=GetScalarDouble(fname,&previous_t,&arg_cnt,nargs,&ccount,lcount,&dval);
 
1398
          if (rval <= 0) {
 
1399
            if (rval== NOT_ENOUGH_ARGS) goto bad;
 
1400
            return rval;
 
1401
          }
 
1402
          pf_type = PF_D;
 
1403
          break;
 
1404
 
 
1405
        case 'X':
 
1406
          rval=GetScalarDouble(fname,&previous_t,&arg_cnt,nargs,&ccount,lcount,&dval);
 
1407
          if (rval <= 0) {
 
1408
            if (rval== NOT_ENOUGH_ARGS) goto bad;
 
1409
            return rval;
 
1410
          }
 
1411
          pf_type = PF_D;
 
1412
          break;
 
1413
 
 
1414
        case 'i':
 
1415
        case 'u':
 
1416
          /* use strod() here */
 
1417
          rval=GetScalarDouble(fname,&previous_t,&arg_cnt,nargs,&ccount,lcount,&dval);
 
1418
          if (rval <= 0) {
 
1419
            if (rval== NOT_ENOUGH_ARGS) goto bad;
 
1420
            return rval;
 
1421
          }
 
1422
          pf_type = l_flag ? PF_LD : PF_D;
 
1423
          break;
 
1424
 
 
1425
        case 'e':
 
1426
        case 'g':
 
1427
        case 'f':
 
1428
        case 'E':
 
1429
        case 'G':
 
1430
          if (h_flag + l_flag)
 
1431
            {
 
1432
              Scierror(998,"Error:\tprintf: bad conversion\r\n");
 
1433
              return RET_BUG;
 
1434
            }
 
1435
          /* use strod() here */
 
1436
          rval=GetScalarDouble(fname,&previous_t,&arg_cnt,nargs,&ccount,lcount,&dval);
 
1437
          if (rval <= 0) {
 
1438
            if (rval== NOT_ENOUGH_ARGS) goto bad;
 
1439
            return rval;
 
1440
          }
 
1441
          pf_type = PF_F;
 
1442
          break;
 
1443
 
 
1444
        default:
 
1445
          Scierror(998,"Error:\tprintf: bad conversion\r\n");
 
1446
          return RET_BUG;
 
1447
        }
 
1448
 
 
1449
      save = *q;
 
1450
      *q = 0;
 
1451
 
 
1452
      /* ready to call printf() */
 
1453
      /* 
 
1454
       * target:   The output file (or variable for sprintf())
 
1455
       * p:        the beginning of the format
 
1456
       * ast:      array with asterisk values
 
1457
       */
 
1458
      switch (AST (ast_cnt, pf_type))
 
1459
        {
 
1460
        case AST (0, PF_C):
 
1461
          retval += (*printer) ((VPTR) target, p, sval[0]);
 
1462
          free(sval);
 
1463
          break;
 
1464
 
 
1465
        case AST (1, PF_C):
 
1466
          retval += (*printer) ((VPTR) target, p, ast[0], sval[0]);
 
1467
          free(sval);
 
1468
          break;
 
1469
 
 
1470
        case AST (2, PF_C):
 
1471
          retval += (*printer) ((VPTR) target, p, ast[0], ast[1],sval[0]);
 
1472
          free(sval);
 
1473
          break;
 
1474
 
 
1475
        case AST (0, PF_S):
 
1476
          retval += (*printer) ((VPTR) target, p, sval);
 
1477
          free(sval);
 
1478
          break;
 
1479
 
 
1480
        case AST (1, PF_S):
 
1481
          retval += (*printer) ((VPTR) target, p, ast[0], sval);
 
1482
          free(sval);
 
1483
          break;
 
1484
 
 
1485
        case AST (2, PF_S):
 
1486
          retval += (*printer) ((VPTR) target, p, ast[0], ast[1], sval);
 
1487
          free(sval);
 
1488
          break;
 
1489
 
 
1490
        case AST (0, PF_D):
 
1491
          retval += (*printer) ((VPTR) target, p, (int) dval);
 
1492
          break;
 
1493
 
 
1494
        case AST (1, PF_D):
 
1495
          retval += (*printer) ((VPTR) target, p, ast[0], (int) dval);
 
1496
          break;
 
1497
 
 
1498
        case AST (2, PF_D):
 
1499
          retval += (*printer) ((VPTR) target, p, ast[0], ast[1], (int) dval);
 
1500
          break;
 
1501
 
 
1502
        case AST (0, PF_LD):
 
1503
          retval += (*printer) ((VPTR) target, p, (long int) dval);
 
1504
          break;
 
1505
 
 
1506
        case AST (1, PF_LD):
 
1507
          retval += (*printer) ((VPTR) target, p, ast[0], (long int) dval);
 
1508
          break;
 
1509
 
 
1510
        case AST (2, PF_LD):
 
1511
          retval += (*printer) ((VPTR) target, p, ast[0], ast[1], (long int) dval);
 
1512
          break;
 
1513
 
 
1514
        case AST (0, PF_F):
 
1515
          retval += (*printer) ((VPTR) target, p, dval);
 
1516
          break;
 
1517
 
 
1518
        case AST (1, PF_F):
 
1519
          retval += (*printer) ((VPTR) target, p, ast[0], dval);
 
1520
          break;
 
1521
 
 
1522
        case AST (2, PF_F):
 
1523
          retval += (*printer) ((VPTR) target, p, ast[0], ast[1], dval);
 
1524
          break;
 
1525
        }
 
1526
      if (fp == (FILE *) 0)
 
1527
        while (*target)
 
1528
          target++;
 
1529
      *q = save;
 
1530
    }
 
1531
  return (retval);
 
1532
 bad:
 
1533
  (*printer) ((VPTR) target, "\n");
 
1534
  (*flush) ((FILE *) target);
 
1535
  Scierror(998,"Error:\tprintf: not enough arguments\r\n");
 
1536
  return RET_BUG;
 
1537
}
 
1538
 
 
1539
 
 
1540
 
 
1541
 
 
1542
 
 
1543
/****************************************************
 
1544
 * Utility functions 
 
1545
 ****************************************************/
 
1546
 
 
1547
static int  GetString(fname,previous_t,arg,narg,ic,ir,sval) 
 
1548
     char *fname,**sval;
 
1549
     int *previous_t,*arg,narg,*ic,ir;
 
1550
{
 
1551
  int mx,nx,il,ild,lw,k,one=1;
 
1552
  char *p;
 
1553
  
 
1554
  if (*previous_t != 2) {
 
1555
    *arg = *arg+1;*ic=1;
 
1556
    *previous_t = 2;
 
1557
  }
 
1558
  lw = *arg + Top - Rhs;
 
1559
  
 
1560
  if (! C2F(getwsmat)(fname,&Top,&lw,&mx,&nx,&il,&ild, strlen(fname))) return RET_BUG;
 
1561
  else {
 
1562
    if ( *ic>nx ) {
 
1563
      *arg=*arg+1;
 
1564
      if (*arg>narg ) return NOT_ENOUGH_ARGS;
 
1565
      *ic=1;
 
1566
      lw = *arg + Top - Rhs;
 
1567
      if (! C2F(getwsmat)(fname,&Top,&lw,&mx,&nx,&il,&ild, strlen(fname))) return RET_BUG;
 
1568
    }
 
1569
  }
 
1570
  if (ir>mx) return RET_END;
 
1571
  k=ir-1+mx*(*ic-1);
 
1572
  if (SciStrtoStr(istk(il-1+*istk(ild+k)),&one,istk(ild+k),&p) < 0) return MEM_LACK;
 
1573
  *ic=*ic+1;
 
1574
  *sval = p;
 
1575
  return OK;
 
1576
}
 
1577
 
 
1578
/** changes `\``n` --> `\n` idem for \t and \r  **/
 
1579
 
 
1580
static int StringConvert(str)
 
1581
     char *str;
 
1582
{
 
1583
  char *str1;
 
1584
  int count=0;
 
1585
  str1 = str;
 
1586
  
 
1587
  while ( *str != 0) 
 
1588
    {
 
1589
      if ( *str == '\\' ) 
 
1590
        {
 
1591
          switch ( *(str+1)) 
 
1592
            {
 
1593
            case 'n' : *str1 = '\n' ; str1++; str += 2;count++;break;
 
1594
            case 't' : *str1 = '\t' ; str1++; str += 2;break;
 
1595
            case 'r' : *str1 = '\r' ; str1++; str += 2;break;
 
1596
            default : *str1 = *str; str1++; str++;break;
 
1597
            }
 
1598
        }
 
1599
      else 
 
1600
        {
 
1601
          *str1 = *str; str1++; str++;
 
1602
        }
 
1603
    }
 
1604
  *str1 = '\0';
 
1605
  return count;
 
1606
}
 
1607
static int GetScalarInt(fname,previous_t,arg,narg,ic,ir,ival) 
 
1608
     char *fname;
 
1609
     int *previous_t,*arg,narg,*ic,ir,*ival;
 
1610
{
 
1611
  int mx,nx,lx;
 
1612
 
 
1613
  if (*previous_t != 1) {
 
1614
    *arg=*arg+1;*ic=1;
 
1615
    *previous_t = 1;
 
1616
  }
 
1617
 
 
1618
  if (! C2F(getrhsvar)(arg,"i",&mx,&nx,&lx,1L))
 
1619
    return RET_BUG;
 
1620
  else {
 
1621
    if ( (*ic>nx) || (*previous_t != 1)) {
 
1622
      *arg=*arg+1;
 
1623
      if (*arg > narg ) return NOT_ENOUGH_ARGS;
 
1624
      *ic=1;
 
1625
      if (! C2F(getrhsvar)(arg,"i",&mx,&nx,&lx,1L))
 
1626
        return RET_BUG;
 
1627
    }
 
1628
  }
 
1629
  if (ir>mx) return RET_END;
 
1630
  *ival =  *(istk(lx+ir-1+mx*(*ic-1)));
 
1631
   *ic=*ic+1;
 
1632
  return OK;
 
1633
}
 
1634
 
 
1635
static int GetScalarDouble(fname,previous_t,arg,narg,ic,ir,dval)
 
1636
     char *fname;
 
1637
     int *previous_t,*arg,narg,*ic,ir;
 
1638
     double *dval;
 
1639
{
 
1640
  int mx,nx,lx;
 
1641
 
 
1642
  if (*previous_t != 1) {
 
1643
    *arg = *arg+1;
 
1644
    *ic=1;
 
1645
    *previous_t = 1;
 
1646
  }
 
1647
  if (! C2F(getrhsvar)(arg,"d",&mx,&nx,&lx,1L))
 
1648
    return RET_BUG;
 
1649
  else {
 
1650
    if ( *ic>nx) {
 
1651
      *arg=*arg+1;
 
1652
      if (*arg > narg ) return NOT_ENOUGH_ARGS;
 
1653
      *ic=1;
 
1654
      if (! C2F(getrhsvar)(arg,"d",&mx,&nx,&lx,1L))
 
1655
        return RET_BUG;
 
1656
    }
 
1657
  }
 
1658
  if (ir>mx) return RET_END;
 
1659
  *dval =  *(stk(lx+ir-1+mx*(*ic-1)));
 
1660
  *ic=*ic+1;
 
1661
  return OK;
 
1662
}
 
1663
 
 
1664
static int Sci_Store(nrow,ncol,data,type,retval_s)
 
1665
     int nrow,ncol,retval_s;
 
1666
     entry *data;
 
1667
     sfdir  *type;
 
1668
{
 
1669
  int cur_i,i,j,i1,one=1,zero=0,k,l,iarg,colcount;
 
1670
  sfdir cur_type;
 
1671
  char ** temp;
 
1672
     
 
1673
  /* create Scilab variable with each column of data */
 
1674
  if (ncol+Rhs > intersiz ){
 
1675
    Scierror(998,"Error:\ttoo many directive in scanf\r\n");
 
1676
    return RET_BUG;
 
1677
  }
 
1678
  if (Lhs > 1) {
 
1679
    CreateVar(1, "d", &one, &one, &l);
 
1680
    *stk(l) = (double) retval_s;
 
1681
    iarg=2;
 
1682
    LhsVar(1)=1;
 
1683
    if (ncol==0) goto Complete;
 
1684
 
 
1685
    for ( i=0 ; i < ncol ; i++) { 
 
1686
      if ( (type[i] == SF_C) || (type[i] == SF_S) ) {
 
1687
        if( (temp = (char **) malloc(nrow*ncol*sizeof(char **)))==NULL) return MEM_LACK;
 
1688
        k=0;
 
1689
        for (j=0;j<nrow;j++) temp[k++]=data[i+ncol*j].s;
 
1690
        CreateVarFromPtr(iarg+i, "S", &nrow, &one, temp);
 
1691
        free(temp);
 
1692
        for (j=0;j<nrow;j++) free(data[i+ncol*j].s);
 
1693
      }
 
1694
      else {
 
1695
        CreateVar(iarg+i, "d", &nrow, &one, &l);
 
1696
        for ( j=0 ; j < nrow ; j++) 
 
1697
          *stk(l+j)= data[i+ncol*j].d;
 
1698
      }
 
1699
 
 
1700
      LhsVar(iarg+i)=iarg+i;
 
1701
    }
 
1702
    free(data);
 
1703
    /** we must complete the returned arguments up to Lhs **/
 
1704
  Complete:
 
1705
    for ( i = ncol+2; i <= Lhs ; i++) 
 
1706
      {
 
1707
        CreateVar(i,"d",&zero,&zero,&l);
 
1708
        LhsVar(i) = i;
 
1709
      }
 
1710
  }
 
1711
  else {/* Lhs==1 */
 
1712
    char *ltype="cblock";
 
1713
    int multi=0,endblk,ii;
 
1714
 
 
1715
    cur_type=type[0];
 
1716
    
 
1717
    for (i=0;i<ncol;i++)
 
1718
      if (type[i] != cur_type)  {
 
1719
        multi=1;
 
1720
        break;
 
1721
      }
 
1722
    if (multi) {
 
1723
      i=strlen(ltype);
 
1724
      CreateVarFromPtr(1, "c", &one, &i, &ltype);
 
1725
      iarg=1;
 
1726
      cur_type=type[0];
 
1727
      i=0;cur_i=i;
 
1728
      while (1) {
 
1729
        if (i < ncol)  
 
1730
          endblk=(type[i] != cur_type);
 
1731
        else
 
1732
          endblk=1;
 
1733
        if (endblk) {
 
1734
          colcount=i - cur_i;
 
1735
          if (nrow==0) {
 
1736
            CreateVar(++iarg, "d", &zero, &zero, &l);}
 
1737
          else if ( (cur_type == SF_C) || (cur_type == SF_S) ) {
 
1738
            if( (temp = (char **) malloc(nrow*colcount*sizeof(char **)))==NULL) return MEM_LACK;
 
1739
            k=0;
 
1740
            for (i1=cur_i;i1<i;i1++)
 
1741
              for (j=0;j<nrow;j++) temp[k++]=data[i1+ncol*j].s;
 
1742
            CreateVarFromPtr(++iarg, "S", &nrow, &colcount,temp);
 
1743
            free(temp);
 
1744
            for (i1=cur_i;i1<i;i1++)
 
1745
              for (j=0;j<nrow;j++) free(data[i1+ncol*j].s);
 
1746
          }
 
1747
          else {
 
1748
            CreateVar(++iarg, "d", &nrow, &colcount, &l);
 
1749
            ii=0;
 
1750
            for (i1=cur_i;i1<i;i1++) {
 
1751
              for ( j=0 ; j < nrow ; j++) 
 
1752
                *stk(l+j+nrow*ii)= data[i1+ncol*j].d;
 
1753
              ii++;
 
1754
            }
 
1755
          }
 
1756
          if (i>=ncol) break;
 
1757
          cur_i=i;
 
1758
          cur_type=type[i];
 
1759
 
 
1760
        }
 
1761
        i++;
 
1762
      }
 
1763
      i = 1;
 
1764
      C2F(mkmlistfromvars)(&i,&iarg);
 
1765
      LhsVar(1)=1;
 
1766
    }
 
1767
    else {
 
1768
      if (nrow==0) {
 
1769
        CreateVar(1, "d", &zero, &zero, &l);}
 
1770
      else if ( (cur_type == SF_C) || (cur_type == SF_S) ) {
 
1771
        if( (temp = (char **) malloc(nrow*ncol*sizeof(char **)))==NULL) return MEM_LACK;
 
1772
        k=0;
 
1773
        for (i1=0;i1<ncol;i1++)
 
1774
          for (j=0;j<nrow;j++) temp[k++]=data[i1+ncol*j].s;
 
1775
        CreateVarFromPtr(1, "S", &nrow, &ncol, temp);
 
1776
        free(temp);
 
1777
        for (i1=0;i1<ncol;i1++)
 
1778
          for (j=0;j<nrow;j++) free(data[i1+ncol*j].s);
 
1779
      }
 
1780
      else {
 
1781
        CreateVar(1, "d", &nrow, &ncol, &l);
 
1782
        ii=0;
 
1783
        for (i1=0;i1<ncol;i1++) {
 
1784
          for ( j=0 ; j < nrow ; j++) 
 
1785
            *stk(l+j+nrow*ii)= data[i1+ncol*j].d;
 
1786
          ii++;
 
1787
        }
 
1788
      }
 
1789
    }
 
1790
    LhsVar(1)=1;
 
1791
  }
 
1792
  PutLhsVar();
 
1793
  return 0;
 
1794
}
 
1795
 
 
1796
/* ************************************************************************
 
1797
 *   Store data scanned by a single call to do_scan in line rowcount of data 
 
1798
 *   table 
 
1799
 ************************************************************************/
 
1800
 
 
1801
static int Store_Scan(nrow,ncol,type_s,type,retval,retval_s,buf,data,rowcount,n)
 
1802
     int rowcount,n;
 
1803
     int *ncol, *nrow, *retval, *retval_s;
 
1804
     entry **data;
 
1805
     sfdir  *type_s,*type;
 
1806
     rec_entry *buf;
 
1807
     
 
1808
{ 
 
1809
  int i,j,nr,nc,err;
 
1810
  entry * Data;
 
1811
  int blk=20; /* block size for memory allocation */
 
1812
  nr=*nrow;
 
1813
  nc=*ncol;
 
1814
 
 
1815
  if (rowcount==0) {
 
1816
    for ( i=0 ; i < MAXSCAN ; i++) type_s[i]=SF_F; /* initialisation */
 
1817
    if (nr<0) nr=blk;
 
1818
    nc=n;
 
1819
    *ncol=nc;
 
1820
    *retval_s=*retval;
 
1821
    if (n==0) {
 
1822
      return 0;
 
1823
    }
 
1824
    if ( (*data = (entry *) malloc(nc*nr*sizeof(entry)))==NULL) {
 
1825
      err= MEM_LACK;
 
1826
      goto bad1;
 
1827
    }
 
1828
    for ( i=0 ; i < nc ; i++) type_s[i]=type[i];
 
1829
 
 
1830
  }
 
1831
  else {
 
1832
    /* check if number of data read match with previous number */
 
1833
    if ( (n !=nc ) || (*retval_s != *retval) ){
 
1834
      err=MISMATCH;
 
1835
      goto bad2;
 
1836
    }
 
1837
    /* check if types of data read match with previous types */
 
1838
    for ( i=0 ; i < nc ; i++)
 
1839
      if (type[i] != type_s[i]) {
 
1840
        err=MISMATCH;
 
1841
        goto bad2;
 
1842
      }
 
1843
 
 
1844
    /* check for memory and realloc if necessary*/
 
1845
    if (rowcount>= nr) {
 
1846
      nr=nr+blk;
 
1847
      *nrow=nr;
 
1848
      if ( (*data = (entry *) realloc(*data,nc*nr*sizeof(entry)))==NULL) {
 
1849
        err= MEM_LACK;
 
1850
        goto bad2;
 
1851
      }
 
1852
    }
 
1853
  } 
 
1854
  Data=*data;
 
1855
  /* store values scanned in a new row */
 
1856
  for ( i=0 ; i < nc ; i++) 
 
1857
    {
 
1858
      switch ( type_s[i] )
 
1859
        {
 
1860
        case SF_C:
 
1861
        case SF_S:
 
1862
          Data[i+nc*rowcount].s=buf[i].c;
 
1863
          break;
 
1864
        case SF_LUI:
 
1865
          Data[i+nc*rowcount].d=(double)buf[i].lui;
 
1866
          break;
 
1867
        case SF_SUI:
 
1868
          Data[i+nc*rowcount].d=(double)buf[i].sui;
 
1869
          break;
 
1870
        case SF_UI:
 
1871
          Data[i+nc*rowcount].d=(double)buf[i].ui;
 
1872
          break;
 
1873
        case SF_LI:
 
1874
          Data[i+nc*rowcount].d=(double)buf[i].li;
 
1875
          break;
 
1876
        case SF_SI:
 
1877
          Data[i+nc*rowcount].d=(double)buf[i].si;
 
1878
          break;
 
1879
        case SF_I:
 
1880
          Data[i+nc*rowcount].d=(double)buf[i].i;
 
1881
          break;
 
1882
        case SF_LF:
 
1883
          Data[i+nc*rowcount].d=buf[i].lf;
 
1884
          break;
 
1885
        case SF_F:
 
1886
          Data[i+nc*rowcount].d=(double)buf[i].f;
 
1887
          break;
 
1888
        }
 
1889
    } /* rowcount */
 
1890
  return 0;
 
1891
 bad1:
 
1892
  /* free allocated strings in scan buffer */
 
1893
  for ( j=0 ; j < MAXSCAN ; j++)
 
1894
    if ( (type_s[j] ==  SF_C) || (type_s[j] ==  SF_S))  free(buf[j].c);
 
1895
  
 
1896
 bad2: 
 
1897
  return err;
 
1898
}
 
1899
 
 
1900
 
 
1901
 
 
1902
static void Free_Scan(nrow,ncol,type_s,data)
 
1903
     int ncol, nrow;
 
1904
     entry **data;
 
1905
     sfdir  *type_s;
 
1906
{
 
1907
  int i,j;
 
1908
  entry * Data;
 
1909
  Data=*data;
 
1910
 
 
1911
  if (nrow != 0) {
 
1912
    for ( j=0 ; j < ncol ; j++)
 
1913
      if ( (type_s[j] ==  SF_C) || (type_s[j] ==  SF_S) ) 
 
1914
        /* free allocated strings in scan data area */
 
1915
        for ( i=0 ; i < nrow ; i++) {
 
1916
          free(Data[j+ncol*i].s);
 
1917
        }
 
1918
  }
 
1919
  /* free scaned data area */
 
1920
  if (ncol>0) free(Data);
 
1921
}
 
1922
 
 
1923
/********************************************************
 
1924
 * Converts a Scilab array of  String coded as integer array 
 
1925
 * into a regular string.
 
1926
 * entries of the original array are catenated, separated by 
 
1927
 * '\n'   char
 
1928
 ********************************************************/
 
1929
 
 
1930
int SciStrtoStr(Scistring,nstring,ptrstrings,strh)
 
1931
     int *Scistring,*nstring,*ptrstrings;
 
1932
     char **strh;
 
1933
{
 
1934
  char *s,*p;
 
1935
  int li,ni,*SciS,i,job=1;
 
1936
  
 
1937
  li=ptrstrings[0];
 
1938
  ni=ptrstrings[*nstring] - li + *nstring +1;
 
1939
  p=(char *) malloc(ni);
 
1940
  if (p ==NULL)  return MEM_LACK;
 
1941
  SciS= Scistring;
 
1942
  s=p;
 
1943
  for ( i=1 ; i<*nstring+1 ; i++) 
 
1944
    {
 
1945
      ni=ptrstrings[i]-li;
 
1946
      li=ptrstrings[i];
 
1947
      F2C(cvstr)(&ni,SciS,s,&job,(long int)ni);
 
1948
      SciS += ni;
 
1949
      s += ni;
 
1950
      if (i<*nstring) {
 
1951
        *s='\n';
 
1952
        s++;
 
1953
      }
 
1954
    }
 
1955
  *s='\0';
 
1956
  *strh=p;
 
1957
  return 0;
 
1958
}
 
1959
 
 
1960