52966c9f814f5e24bfd68dc3a760f4f545354abe
[scilab.git] / scilab / modules / intersci / src / exe / intersci.c
1 /*
2  * Scilab ( http://www.scilab.org/ ) - This file is part of Scilab
3  * Copyright (C) ????-2008 - INRIA
4  *
5  * This file must be used under the terms of the CeCILL.
6  * This source file is licensed as described in the file COPYING, which
7  * you should have received as part of this distribution.  The terms
8  * are also available at
9  * http://www.cecill.info/licences/Licence_CeCILL_V2-en.txt
10  *
11  */
12
13
14 #ifdef _MSC_VER
15 #include <windows.h>
16 #include <stdio.h>
17 #endif
18 #include <stdlib.h>
19
20 #include "intersci.h"
21 #include "PATH_MAX.h"
22 #include "stack-def.h"
23
24 static char buf[1024];
25
26 static int icre=1;     /* incremental counter for variable creation */
27 static int indent = 0; /* incremental counter for code indentation */
28 static int pass = 0 ;  /* flag for couting pass on code generation */
29
30 #ifdef _MSC_VER
31 static void SciEnv ();
32 #define putenv _putenv
33 #pragma comment(lib,"../../../../../bin/libintl.lib")
34 #endif
35
36 int main(argc,argv)
37      unsigned int argc;
38      char **argv;
39 {
40   int InterFace = 0 ;
41 #ifdef _MSC_VER
42   SciEnv();
43 #endif
44   switch (argc) {
45   case 2:
46     InterFace = 0; break;
47   case 3:
48     InterFace = atoi(argv[2]);break;
49   default:
50     printf("usage:  intersci <interface file> <interface number>\n");
51     exit(1);
52     break;
53   }
54   basfun = BasfunAlloc();
55   if (basfun == 0) {
56     printf("Running out of memory\n");
57     exit(1);
58   }
59   forsub = ForsubAlloc();
60   if (forsub == 0) {
61     printf("Running out of memory\n");
62     exit(1);
63   }
64   ISCIReadFile(argv[1]);
65   GenFundef(argv[1],InterFace);
66   return 0;
67 }
68
69 void ISCIReadFile(file)
70      char *file;
71 {
72   FILE *fin, *fout, *foutv;
73   char filout[MAXNAM];
74   char filin[MAXNAM];
75   sprintf(filin,"%s.desc",file);
76   fin = fopen(filin,"r");
77   if (fin == 0) {
78     printf("Interface file \"%s\" does not exist\n",filin);
79     exit(1);
80   }
81   Copyright();
82   strcpy(filout,file);
83   strcat(filout,".f");
84   fout = fopen(filout,"w");
85   strcpy(filout,file);
86   strcat(filout,".tmp");
87   foutv = fopen(filout,"w");
88   InitDeclare();
89   nFun = 0;
90   while(ReadFunction(fin)) {
91     nFun++;
92     if (nFun > MAXFUN) {
93       printf("Too many SCILAB functions. The maximum is %d\n",MAXFUN);
94       exit(1);
95     }
96     ResetDeclare();
97     /* first pass to collect declarations */
98     pass=0;
99     WriteFunctionCode(foutv);
100     /* cleaning added Fornames before pass 2 */
101     ForNameClean();
102     /* scond pass to produce code */
103     pass=1;
104     WriteFunctionCode(fout);
105     /** WriteInfoCode(fout); **/
106   }
107   WriteMain(fout,file);
108   printf("FORTRAN file \"%s.f\" has been created\n",file);
109   WriteAddInter(file) ;
110   printf("Scilab file \"%s.sce\" has been created\n",file);
111   fclose(fout);
112   fclose(fin);
113 }
114
115 void WriteMain(f,file)
116      FILE *f;
117      char* file;
118 {
119   int i;
120   FCprintf(f,"\nc  interface function\n");
121   FCprintf(f,"c   ********************\n");
122   WriteMainHeader(f,file);
123   Fprintf(f,indent,"goto (");
124   for (i = 1; i < nFun ; i++) {
125     Fprintf(f,indent,"%d,",i);
126   }
127   Fprintf(f,indent,"%d) fin\nreturn\n",nFun);
128   for (i = 0; i < nFun; i++) {
129     FCprintf(f,"%d      call ints%s('%s')\n",i+1,funNames[i],funNames[i]);
130     Fprintf(f,indent,"return\n");
131   }
132   Fprintf(f,indent,"end\n");
133 }
134
135 void WriteAddInter(file)
136      char *file;
137 {
138   FILE *fout;
139   int i;
140   char filout[MAXNAM];
141   strcpy(filout,file);
142   strcat(filout,".sce");
143   fout = fopen(filout,"w");
144   if ( fout != (FILE*) 0)
145     {
146  fprintf(fout,"// Addinter for file %s\n",file);
147  fprintf(fout,"// for hppa/sun-solaris/linux/dec\n");
148  fprintf(fout,"//--------------------------------\n");
149  fprintf(fout,"//Scilab functions\n");
150  fprintf(fout,"%s_funs=[...\n",file);
151  for (i = 0; i < nFun -1; i++)
152       fprintf(fout,"  '%s';\n",funNames[i]);
153       fprintf(fout,"  '%s']\n",funNames[nFun-1]);
154  fprintf(fout,"// interface file to link: ifile='%s.o'\n",file);
155  fprintf(fout,"// user's files to link: ufiles=['file1.o','file2.o',....]\n");
156  fprintf(fout,"// files = [ifile,ufiles]\n");
157  fprintf(fout,"addinter(files,'%s',%s_funs);\n",file,file);
158  fclose(fout);
159     }
160   else
161     fprintf(stderr,"Can't open file %s\n",file);
162 }
163
164
165
166
167 void Copyright()
168 {
169   printf("\nINTERSCI Version %s (%s)\n",VERSION,DATE);
170   printf("    Copyright (C) INRIA All rights reserved\n\n");
171 }
172
173 /**********************************************************
174  *Reading the intersci description file
175  **********************************************************/
176
177 int ReadFunction(f)
178      FILE *f;
179 {
180   int i, j, l, type, ftype;
181   char s[MAXLINE];
182   char str[MAXNAM];
183   char *words[MAXLINE];
184   char *optwords[MAXLINE];
185   IVAR ivar;
186   int nwords, line1, inbas, fline1, infor, nopt, out1;
187
188   nVariable = 0;
189   maxOpt = 0;
190   line1 = 1;
191   inbas = 0;
192   fline1 = 0;
193   infor = 0;
194   out1 = 0;
195   while (fgets(s,MAXLINE,f))
196     {
197       /* analysis of one line */
198       if (line1 != 1) nwords = ParseLine(s,words);
199       else nwords = ParseScilabLine(s,words);
200       /* end of description */
201       if (words[0][0] == '*') return(1);
202       if (line1 == 1)
203         {
204           /* SCILAB function description */
205           if ((int)strlen(words[0]) > nlgh)
206             {
207               printf("SCILAB function name too long: \"%s\"\n",words[0]);
208               exit(1);
209             }
210           basfun->name = (char *)malloc((unsigned)(strlen(words[0])+1));
211           strcpy(basfun->name,words[0]);
212           printf("**************************\n");
213           printf("processing SCILAB function \"%s\"\n",words[0]);
214           funNames[nFun] = basfun->name;
215           i = nwords - 1;
216           if (i > MAXARG)
217             {
218               printf("too may input arguments for SCILAB function\"%s\"\n",
219                      words[0]);
220               printf("  augment constant \"MAXARG\" and recompile intersci\n");
221               exit(1);
222             }
223           basfun->nin = i;
224           for (i = 0; i < nwords - 1; i++)
225             {
226               if (words[i+1][0] == '{')
227                 {
228                   maxOpt++;
229                   nopt = ParseLine(words[i+1]+1,optwords);
230                   if (nopt != 2) {
231                     printf("Bad syntax for optional argument. Two variables needed\n");
232                     exit(1);
233                   }
234                   ivar = GetVar(optwords[0],1);
235                   basfun->in[i] = ivar;
236                   variables[ivar-1]->opt_type = NAME;
237                   variables[ivar-1]->opt_name =
238                     (char *)malloc((unsigned)(strlen(optwords[1])+1));
239                   strcpy(variables[ivar-1]->opt_name,optwords[1]);
240                 }
241               else if (words[i+1][0] == '[')
242                 {
243                   maxOpt++;
244                   nopt = ParseLine(words[i+1]+1,optwords);
245                   if (nopt != 2)
246                     {
247                       printf("Bad syntax for optional argument. Two variables needed\n");
248                       exit(1);
249                     }
250                   ivar = GetVar(optwords[0],1);
251                   basfun->in[i] = ivar;
252                   variables[ivar-1]->opt_type = VALUE;
253                   variables[ivar-1]->opt_name =
254                     (char *)malloc((unsigned)(strlen(optwords[1])+1));
255                   strcpy(variables[ivar-1]->opt_name,optwords[1]);
256                 }
257               else basfun->in[i] = GetVar(words[i+1],1);
258             }
259           line1 = 0;
260           inbas = 1;
261         }
262       else if (inbas == 1)
263         {
264           if (nwords == 0)
265             {
266               /* end of SCILAB variable description */
267               inbas = 0;
268               fline1 = 1;
269             }
270           else
271             {
272               /* SCILAB variable description */
273               ivar = GetVar(words[0],1);
274               i = ivar - 1;
275               if (nwords == 1)
276                 {
277                   printf("type missing for variable \"%s\"\n",words[0]);
278                   exit(1);
279                 }
280               type = GetBasType(words[1]);
281               variables[i]->type = type;
282               switch (type)
283                 {
284                 case SCALAR:
285                 case ANY:
286                 case SCIMPOINTER:
287                 case SCISMPOINTER:
288                 case SCILPOINTER:
289                 case SCIBPOINTER:
290                 case SCIOPOINTER:
291                   break;
292                 case COLUMN:
293                 case ROW:
294                 case STRING:
295                 case WORK:
296                 case VECTOR:
297                   if (nwords != 3)
298                     {
299                       printf("bad type specification for variable \"%s\"\n", words[0]);
300                       printf("only %d argument given and %d are expected\n", nwords,3);
301                       exit(1);
302                     }
303                   variables[i]->el[0] = GetVar(words[2],1);
304                   break;
305                 case LIST:
306                 case TLIST:
307                   if (nwords != 3)
308                     {
309                       printf("bad type specification for variable \"%s\"\n", words[0]);
310                       printf("only %d argument given and %d are expected\n", nwords,3);
311                       exit(1);
312                     }
313                   ReadListFile(words[2],words[0],i);
314                   break;
315                 case POLYNOM:
316                 case MATRIX:
317                 case BMATRIX:
318                 case STRINGMAT:
319                   if (nwords != 4)
320                     {
321                       printf("bad type specification for variable \"%s\"\n",words[0]);
322                       printf("%d argument given and %d are expected\n", nwords,4);
323                       exit(1);
324                     }
325                   variables[i]->el[0] = GetVar(words[2],1);
326                   variables[i]->el[1] = GetVar(words[3],1);
327                   break;
328                 case IMATRIX:
329                   if (nwords != 5)
330                     {
331                       printf("bad type specification for variable \"%s\"\n",words[0]);
332                       printf("%d argument given and %d are expected\n", nwords,5);
333                       exit(1);
334                     }
335                   variables[i]->el[0] = GetVar(words[2],1);
336                   variables[i]->el[1] = GetVar(words[3],1);
337                   variables[i]->el[2] = GetVar(words[4],1);
338                   break;
339                 case SPARSE:
340                   if (nwords != 6)
341                     {
342                       printf("bad type specification for variable \"%s\"\n",words[0]);
343                       printf("%d argument given and %d are expected\n", nwords,6);
344                       printf("name sparse m n nel it\n");
345                       exit(1);
346                     }
347                   variables[i]->el[0] = GetVar(words[2],1);
348                   variables[i]->el[1] = GetVar(words[3],1);
349                   variables[i]->el[2] = GetVar(words[4],1);
350                   variables[i]->el[3] = GetVar(words[5],1);
351                   break;
352                 case SEQUENCE:
353                   printf("variable \"%s\" cannot have type \"SEQUENCE\"\n",
354                          words[0]);
355                   exit(1);
356                   break;
357                 case EMPTY:
358                   printf("variable \"%s\" cannot have type \"EMPTY\"\n",
359                          words[0]);
360                   exit(1);
361                   break;
362                 }
363             }
364         }
365       else if (fline1 == 1)
366         {
367           /* FORTRAN subroutine description */
368           forsub->name = (char *)malloc((unsigned)(strlen(words[0])+1));
369           strcpy(forsub->name,words[0]);
370           i = nwords - 1;
371           if (i > MAXARG)
372             {
373               printf("too many argument for FORTRAN subroutine \"%s\"\n",
374                      words[0]);
375               printf("  augment constant \"MAXARG\" and recompile intersci\n");
376               exit(1);
377             }
378           forsub->narg = i;
379           for (i = 0; i < nwords - 1; i++)
380             {
381               forsub->arg[i] = GetExistVar(words[i+1]);
382             }
383           fline1 = 0;
384           infor = 1;
385         }
386       else if (infor == 1)
387         {
388           if (nwords == 0)
389             {
390               /* end of FORTRAN subroutine description */
391               infor = 0;
392               out1 = 1;
393             }
394           else
395             {
396               /* FORTRAN variable description */
397               if (nwords == 1)
398                 {
399                   printf("type missing for FORTRAN argument \"%s\"\n",
400                          words[0]);
401                   exit(1);
402                 }
403               ivar = GetExistVar(words[0]);
404               ftype = GetForType(words[1]);
405               variables[ivar-1]->for_type = ftype;
406               if (ftype == EXTERNAL)
407                 {
408                   strcpy((char *)(variables[ivar-1]->fexternal),words[1]);
409                   switch (variables[ivar-1]->type)
410                     {
411                     case COLUMN:
412                     case POLYNOM:
413                     case ROW:
414                     case STRING:
415                     case VECTOR:
416                       sprintf(str,"ne%d",ivar);
417                       AddForName(variables[ivar-1]->el[0],str);
418                       break;
419                     case SPARSE:
420                       sprintf(str,"me%d",ivar);
421                       AddForName(variables[ivar-1]->el[0],str);
422                       sprintf(str,"ne%d",ivar);
423                       AddForName(variables[ivar-1]->el[1],str);
424                       sprintf(str,"nel%d",ivar);
425                       AddForName(variables[ivar-1]->el[2],str);
426                       sprintf(str,"it%d",ivar);
427                       AddForName(variables[ivar-1]->el[3],str);
428                       break;
429                     case IMATRIX:
430                       sprintf(str,"me%d",ivar);
431                       AddForName(variables[ivar-1]->el[0],str);
432                       sprintf(str,"ne%d",ivar);
433                       AddForName(variables[ivar-1]->el[1],str);
434                       sprintf(str,"it%d",ivar);
435                       AddForName(variables[ivar-1]->el[2],str);
436                       break;
437                     case MATRIX:
438                     case BMATRIX:
439                     case STRINGMAT:
440                       sprintf(str,"me%d",ivar);
441                       AddForName(variables[ivar-1]->el[0],str);
442                       sprintf(str,"ne%d",ivar);
443                       AddForName(variables[ivar-1]->el[1],str);
444                       break;
445                     default:
446                       printf("FORTRAN argument \"%s\" with external type \"%s\"\n",
447                              variables[ivar-1]->name,words[1]);
448                       printf("  cannot have a variable type of \"%s\"\n",SGetSciType(variables[ivar-1]->type));
449                       exit(1);
450                       break;
451                     }
452                 }
453             }
454         }
455       else if (out1 == 1)
456         {
457           /* output variable description */
458           i = ivar - 1;
459           if (nwords == 1)
460             {
461               printf("type missing for output variable \"out\"\n");
462               exit(1);
463             }
464           ivar = GetOutVar(words[0]);
465           basfun->out = ivar;
466           i = ivar - 1;
467           type = GetBasType(words[1]);
468           variables[i]->type = type;
469           switch (type)
470             {
471             case LIST:
472             case TLIST:
473             case SEQUENCE:
474               l = nwords - 2;
475               if (l > MAXEL)
476                 {
477                   printf("list or sequence too long for output variable \"out\"\n");
478                   printf("  augment constant \"MAXEL\" and recompile intersci\n");
479                   exit(1);
480                 }
481               for (j = 0; j < l; j++)
482                 variables[i]->el[j] = GetExistVar(words[j+2]);
483               variables[i]->length = l;
484               break;
485             case EMPTY:
486               break;
487             default:
488               printf("output variable \"out\" of SCILAB function\n");
489               printf("  must have type \"LIST\", \"TLIST\", \"SEQUENCE\" or\n");
490               printf("  \"EMPTY\"\n");
491               exit(1);
492               break;
493             }
494           out1 = 0;
495         }
496       else
497         {
498           /* possibly equal variables */
499           ivar = GetExistVar(words[0]);
500           i = ivar -1 ;
501           variables[i]->equal = GetExistVar(words[1]);
502         }
503     }
504   /* end of description file */
505   return(0);
506 }
507
508 /*
509   put the words of SCILAB function description line "s" in "words" and
510   return the number of words with checking syntax of optional variables:
511   "{g  the_g }" => 1 word "{g  the_g\n"
512   "[f v]" => 1 word "[f v\n"
513   */
514
515 int ParseScilabLine(char *s,char *words[])
516 {
517   char w[MAXNAM];
518   int nwords = 0;
519   int inword = 1;
520   int inopt1 = 0; /* {  } */
521   int inopt2 = 0; /* [  ] */
522   int i = 0;
523   if (*s == ' ' || *s == '\t') inword = 0;
524   if (*s == '{') inopt1 = 1;
525   if (*s == '[') inopt2 = 1;
526   while (*s) {
527     if (inopt1) {
528       w[i++] = *s++;
529       if (*s == '{' || *s == '[' || *s == ']' || *s == '\n') {
530         printf("Bad syntax for optional argument. No matching \"}\"\n");
531         exit(1);
532       }
533       else if (*s == '}') {
534         w[i++] = '\n';
535         w[i] = '\0';
536         words[nwords] = (char *)malloc((unsigned)(i+1));
537         strcpy(words[nwords],w);
538         nwords++;
539         inopt1 = 0;
540         inword = 0;
541       }
542     }
543     else if (inopt2) {
544       w[i++] = *s++;
545       if (*s == '[' || *s == '{' || *s == '}' || *s == '\n') {
546         printf("Bad syntax for optional argument. No matching \"]\"\n");
547         exit(1);
548       }
549       else if (*s == ']') {
550         w[i++] = '\n';
551         w[i] = '\0';
552         words[nwords] = (char *)malloc((unsigned)(i+1));
553         strcpy(words[nwords],w);
554         nwords++;
555         inopt2 = 0;
556         inword = 0;
557       }
558     }
559     else if (inword) {
560       w[i++] = *s++;
561       if (*s == ' ' || *s == '\t' || *s == '\n') {
562         w[i] = '\0';
563         words[nwords] = (char *)malloc((unsigned)(i+1));
564         strcpy(words[nwords],w);
565         nwords++;
566         inword = 0;
567       }
568     }
569     else {
570       s++; /* *s++; */
571       if (*s != ' ' && *s != '\t') {
572         /* beginning of a word */
573         i = 0;
574         inword = 1;
575         if (*s == '{') inopt1 = 1;
576         if (*s == '[') inopt2 = 1;
577       }
578     }
579   }
580   return(nwords);
581 }
582
583 /* put the words of line "s" in "words" and return the number of words */
584
585 int ParseLine(s,words)
586      char *s, *words[];
587 {
588   char w[MAXNAM];
589   int nwords = 0;
590   int inword = 1;
591   int i = 0;
592   if(*s == ' ' || *s == '\t') inword = 0;
593   while (*s) {
594     if (inword) {
595       w[i++] = *s++;
596       if (*s == ' ' || *s == '\t' || *s == '\n') {
597         w[i] = '\0';
598         words[nwords] = (char *)malloc((unsigned)(i+1));
599         strcpy(words[nwords],w);
600         nwords++;
601         inword = 0;
602       }
603     }
604     else {
605       s++; /* *s++; */
606       if (*s != ' ' && *s != '\t') {
607         i = 0;
608         inword = 1;
609       }
610     }
611   }
612   return(nwords);
613 }
614
615
616
617 void ReadListFile(listname,varlistname,ivar)
618      char *listname;
619      char *varlistname;
620      IVAR ivar;
621 {
622   FILE *fin;
623   char filin[MAXNAM];
624   int nel;
625
626   sprintf(filin,"%s.list",listname);
627   fin = fopen(filin,"r");
628   if (fin == 0)
629     {
630       printf("description file for list or tlist \"%s\" does not exist\n",
631              filin);
632       exit(1);
633     }
634   printf("reading description file for list or tlist \"%s\"\n", listname);
635
636   nel = 0;
637   while(ReadListElement(fin,varlistname,ivar,nel))
638     {
639       nel++;
640     }
641
642   fclose(fin);
643 }
644
645 int ReadListElement(f,varlistname,iivar,nel)
646      FILE *f;
647      char *varlistname;
648      int nel;
649      IVAR iivar;
650 {
651   char s[MAXLINE];
652   char *words[MAXLINE];
653   int i, nline, nwords, type;
654   IVAR ivar;
655   char str[MAXNAM];
656   nline = 0;
657   while (fgets(s,MAXLINE,f) != NULL)
658     {
659       /* analyse of one line */
660       nline++;
661       switch (nline)
662         {
663         case 1:
664           break;
665         case 2:
666           /* SCILAB variable description */
667           nwords = ParseLine(s,words);
668           sprintf(str,"%s(%s)",words[0],varlistname);
669           ivar = GetVar(str,0);
670           i = ivar - 1;
671           if (nwords == 1)
672             {
673               printf("type missing for variable \"%s\"\n",words[0]);
674               exit(1);
675             }
676           type = GetBasType(words[1]);
677           variables[i]->type = type;
678           variables[i]->list_name = (char *)malloc((unsigned)(strlen(varlistname)+1));
679           strcpy(variables[i]->list_name,varlistname);
680           variables[i]->list_el = nel+1;
681           sprintf(str,"stk(l%de%d)",iivar+1,nel+1);
682           AddForName(ivar,str);
683           switch (type)
684             {
685             case SCALAR:
686             case ANY:
687               break;
688             case COLUMN:
689             case ROW:
690             case STRING:
691             case VECTOR:
692               if (nwords != 3)
693                 {
694                   printf("bad type for variable \"%s\"\n",
695                          words[0]);
696                   exit(1);
697                 }
698               if (isdigit(words[2][0]))
699                 {
700                   variables[i]->el[0] = GetVar(words[2],0);
701                 }
702               else
703                 {
704                   sprintf(str,"%s(%s)",words[2],varlistname);
705                   variables[i]->el[0] = GetVar(str,0);
706                 }
707               break;
708             case POLYNOM:
709             case MATRIX:
710             case BMATRIX:
711             case STRINGMAT:
712               if (nwords != 4)
713                 {
714                   printf("bad type for variable \"%s\"\n",
715                          words[0]);
716                   exit(1);
717                 }
718               if (isdigit(words[2][0]))
719                 {
720                   variables[i]->el[0] = GetVar(words[2],0);
721                 }
722               else
723                 {
724                   sprintf(str,"%s(%s)",words[2],varlistname);
725                   variables[i]->el[0] = GetVar(str,0);
726                 }
727               if (isdigit(words[3][0]))
728                 {
729                   variables[i]->el[1] = GetVar(words[3],0);
730                 }
731               else
732                 {
733                   sprintf(str,"%s(%s)",words[3],varlistname);
734                   variables[i]->el[1] = GetVar(str,0);
735                 }
736               break;
737             case IMATRIX:
738               if (nwords != 6)
739                 {
740                   printf("bad type for variable \"%s\"\n",
741                          words[0]);
742                   exit(1);
743                 }
744               if (isdigit(words[2][0]))
745                 {
746                   variables[i]->el[0] = GetVar(words[2],0);
747                 }
748               else
749                 {
750                   sprintf(str,"%s(%s)",words[2],varlistname);
751                   variables[i]->el[0] = GetVar(str,0);
752                 }
753               if (isdigit(words[3][0]))
754                 {
755                   variables[i]->el[1] = GetVar(words[3],0);
756                 }
757               else
758                 {
759                   sprintf(str,"%s(%s)",words[3],varlistname);
760                   variables[i]->el[1] = GetVar(str,0);
761                 }
762               sprintf(str,"%s(%s)",words[4],varlistname);
763               variables[i]->el[2] = GetVar(str,0);
764               break;
765             case SPARSE:
766               if (nwords != 6)
767                 {
768                   printf("bad type for variable \"%s\"\n",
769                          words[0]);
770                   exit(1);
771                 }
772               if (isdigit(words[2][0]))
773                 {
774                   variables[i]->el[0] = GetVar(words[2],0);
775                 }
776               else
777                 {
778                   sprintf(str,"%s(%s)",words[2],varlistname);
779                   variables[i]->el[0] = GetVar(str,0);
780                 }
781               if (isdigit(words[3][0]))
782                 {
783                   variables[i]->el[1] = GetVar(words[3],0);
784                 }
785               else
786                 {
787                   sprintf(str,"%s(%s)",words[3],varlistname);
788                   variables[i]->el[1] = GetVar(str,0);
789                 }
790               if (isdigit(words[4][0]))
791                 {
792                   variables[i]->el[2] = GetVar(words[4],0);
793                 }
794               else
795                 {
796                   sprintf(str,"%s(%s)",words[4],varlistname);
797                   variables[i]->el[2] = GetVar(str,0);
798                 }
799               sprintf(str,"%s(%s)",words[5],varlistname);
800               variables[i]->el[3] = GetVar(str,0);
801               break;
802             case WORK:
803             case SEQUENCE:
804             case EMPTY:
805             case LIST:
806             case TLIST:
807               printf("variable \"%s\" cannot have type \"%s\"\n",
808                      words[0],SGetSciType(type));
809               exit(1);
810             default:
811               printf("variable \"%s\" has unknown type \"%s\"\n",
812                      words[0],SGetSciType(type));
813             }
814           break;
815         default:
816           /* end of description */
817           if (s[0] == '*')
818             {
819               return(1);
820             }
821           else
822             {
823               printf("bad description file for list or tlist \"%s\"\n",
824                      varlistname);
825               exit(1);
826             }
827           break;
828         }
829     }
830   return(0);
831 }
832
833 /*********************************************************************
834   Dealing with the set of variables
835 *********************************************************************/
836
837
838 /* return the variable number of variable name. if it does not already exist,
839    it is created and "nVariable" is incremented
840    p corresponds to the present slot of var structure:
841    - if the variable does not exist it is created with p value
842    - if the variable exists it is created with (p or 0) value
843    */
844
845 IVAR GetVar(name,p)
846      char *name;
847      int p;
848 {
849   int i;
850   VARPTR var;
851   if (strcmp(name,"out") == 0) {
852     printf("the name of a variable which is not the output variable\n");
853     printf("  of SCILAB function cannot be \"out\"\n");
854     exit(1);
855   }
856   for (i = 0; i < nVariable; i++) {
857     var = variables[i];
858     if (strcmp(var->name,name) == 0) {
859       var->present = var->present || p;
860       return(i+1);
861     }
862   }
863   if (nVariable == MAXVAR) {
864     printf("too many variables\n");
865     printf("  augment constant \"MAXVAR\" and recompile intersci\n");
866     exit(1);
867   }
868   var = VarAlloc();
869   if (var == 0) {
870     printf("Running out of memory\n");
871     exit(1);
872   }
873   var->name = (char *)malloc((unsigned)(strlen(name) + 1));
874   strcpy(var->name,name);
875   var->type = 0;
876   var->length = 0;
877   var->for_type = 0;
878   var->equal = 0;
879   var->nfor_name = 0;
880   var->kp_state = -1;
881   var->list_el = 0;
882   var->opt_type = 0;
883   var->present = p;
884   variables[nVariable++] = var;
885   return(nVariable);
886 }
887
888 /* return the variable number of variable name which must already  exist */
889
890 IVAR GetExistVar(char *name)
891 {
892   int i;
893   VARPTR var;
894   if (strcmp(name,"out") == 0) {
895     printf("the name of a variable which is not the output variable\n");
896     printf("  of SCILAB function cannot be \"out\"\n");
897     exit(1);
898   }
899   for (i = 0; i < nVariable; i++) {
900     var = variables[i];
901     if (strcmp(var->name,name) == 0) {
902       /* always present */
903       var->present = 1;
904       return(i+1);
905     }
906   }
907   i=CreatePredefVar(name);
908   if ( i != -1) return(i);
909   printf("variable \"%s\" must exist\n",name);
910   exit(1);
911 }
912
913 /* fname,rhs,lhs,err are predefined variables
914    if someone want to add them in the Fortran or C Calling sequence
915    it's done without aby checks
916 */
917
918 int CreatePredefVar(name)
919      char *name;
920 {
921   VARPTR var;
922   if (strcmp(name,"err")  == 0
923       || strcmp(name,"rhs") == 0
924       || strcmp(name,"lhs") == 0
925       || strcmp(name,"fname") == 0)
926     {
927       int num ;
928       num=GetVar(name,1);
929       var = variables[num-1];
930       var->for_type = PREDEF;
931       return(num);
932     }
933   return(-1);
934 }
935
936 /* return the variable number of variable "out"
937    which is created and "nVariable" is incremented */
938
939 IVAR GetOutVar(name)
940      char *name;
941 {
942   VARPTR var;
943   if (strcmp(name,"out") != 0) {
944     printf("the name of output variable of SCILAB function\n");
945     printf("  must be \"out\"\n");
946     exit(1);
947   }
948   if (nVariable == MAXVAR) {
949     printf("too many variables\n");
950     printf("  augmente constant \"MAXVAR\" and recompile intersci\n");
951     exit(1);
952   }
953   var = VarAlloc();
954   if (var == 0) {
955     printf("Running out of memory\n");
956     exit(1);
957   }
958   var->name = (char *)malloc((unsigned)(strlen(name) + 1));
959   strcpy(var->name,name);
960   var->type = 0;
961   var->length = 0;
962   var->for_type = 0;
963   var->equal = 0;
964   var->nfor_name = 0;
965   var->kp_state = -1;
966   var->list_el = 0;
967   var->opt_type = 0;
968   var->present = 0;
969   variables[nVariable++] = var;
970   return(nVariable);
971 }
972
973 /* return the variable number of variable "out"
974    which must exist */
975
976 IVAR GetExistOutVar()
977 {
978   int i;
979   char str[4];
980   strcpy(str,"out");
981   for (i = 0; i < nVariable; i++) {
982     if (strcmp(variables[i]->name,str) == 0)
983       return(i+1);
984   }
985   printf("variable \"out\" must exist\n");
986   exit(1);
987 }
988
989 /***************************
990  * add name in the for_name array
991  * field of variable ivar
992  ***************************/
993
994 void AddForName(ivar,name)
995      IVAR ivar;
996      char* name;
997 {
998   VARPTR var;
999   int l;
1000   var = variables[ivar-1];
1001   l = var->nfor_name;
1002   if (l == MAXARG) {
1003     printf("too many \"for_name\" for variable \"%s\"\n",var->name);
1004     printf("  augment constant \"MAXARG\" and recompile intersci\n");
1005     exit(1);
1006   }
1007   var->for_name[l] = (char *)malloc((unsigned)(strlen(name) + 1));
1008   strcpy(var->for_name[l],name);
1009   var->nfor_name = l + 1;
1010 }
1011
1012 void AddForName1(ivar,name)
1013      IVAR ivar;
1014      char* name;
1015 {
1016   VARPTR var;
1017   int l;
1018   var = variables[ivar-1];
1019   l = var->nfor_name;
1020   if ( pass == 0 && var->kp_state == -1 )
1021     {
1022       var->kp_state = var->nfor_name ;
1023     }
1024   if (l == MAXARG) {
1025     printf("too many \"for_name\" for variable \"%s\"\n",var->name);
1026     printf("  augment constant \"MAXARG\" and recompile intersci\n");
1027     exit(1);
1028   }
1029   var->for_name[l] = (char *)malloc((unsigned)(strlen(name) + 1));
1030   strcpy(var->for_name[l],name);
1031   var->nfor_name = l + 1;
1032 }
1033
1034 void ForNameClean()
1035 {
1036   VARPTR var;
1037   int i;
1038   for (i = 0; i < nVariable; i++) {
1039     var = variables[i];
1040     if ( var->kp_state != -1 )
1041       {
1042         var->nfor_name = var->kp_state ;
1043       }
1044   }
1045 }
1046
1047 void ChangeForName(ivar,name)
1048      IVAR ivar;
1049      char* name;
1050 {
1051   VARPTR var;
1052   int l;
1053   var = variables[ivar-1];
1054   l = var->nfor_name;
1055   var->for_name[0] = (char *)malloc((unsigned)(strlen(name) + 1));
1056   strcpy(var->for_name[0],name);
1057   /* useful ??? */
1058   if (l == 0) var->nfor_name = 1;
1059 }
1060
1061 /***********************************************************
1062   Convertions de type entre codage entier
1063   et description par chaine de caracteres
1064   pour les types Scilab et les types Fortran
1065 ************************************************************/
1066
1067 /* Attention tableau en ordre alphabetique */
1068
1069 static struct btype { char *sname ;
1070                       int  code ;}
1071 SType[] = {
1072   {"any",       ANY},
1073   {"bmatrix",    BMATRIX},
1074   {"bpointer",   SCIBPOINTER},
1075   {"column",    COLUMN},
1076   {"empty",     EMPTY},
1077   {"imatrix",    IMATRIX},
1078   {"list",      LIST},
1079   {"lpointer",  SCILPOINTER},
1080   {"matrix",    MATRIX},
1081   {"mpointer",  SCIMPOINTER},
1082   {"opointer",  SCIOPOINTER},
1083   {"polynom",   POLYNOM},
1084   {"row",       ROW},
1085   {"scalar",    SCALAR},
1086   {"sequence",  SEQUENCE},
1087   {"smpointer",  SCISMPOINTER},
1088   {"sparse",    SPARSE},
1089   {"string",    STRING},
1090   {"stringmat", STRINGMAT},
1091   {"tlist",     TLIST},
1092   {"vector",    VECTOR},
1093   {"work",      WORK},
1094   {(char *) 0 ,  -1}
1095   };
1096
1097 /* Type Scilab:  renvoit un codage du type en nombre entier etant donne une chaine */
1098
1099 int GetBasType(sname)
1100      char *sname;
1101 {
1102   int i=0;
1103   while ( SType[i].sname != (char *) NULL)
1104      {
1105        int j ;
1106        j = strcmp(sname,SType[i].sname);
1107        if ( j == 0 )
1108          {
1109            return(SType[i].code);
1110          }
1111        else
1112          {
1113            if ( j <= 0)
1114              break;
1115            else i++;
1116          }
1117      }
1118   printf("the type of variable \"%s\" is unknown\n",sname);
1119   exit(1);
1120 }
1121
1122 /* Type Scilab :  Renvoit la description (string) d'un type a partir de son code */
1123
1124 char *SGetSciType(type)
1125      int type;
1126 {
1127   int i=0;
1128   while ( SType[i].code  != -1 )
1129      {
1130        if ( SType[i].code == type )
1131          return(SType[i].sname);
1132        else
1133          i++;
1134      }
1135   return("unknown");
1136 }
1137
1138 /* Attention tableau en ordre alphabetique */
1139
1140 static struct ftype { char *fname ;
1141                       int  code ;}
1142 FType[] = {
1143   {"Cstringv",CSTRINGV},
1144   {"bpointer",BPOINTER},
1145   {"char",CHAR},
1146   {"double", DOUBLE},
1147   {"int",INT},
1148   {"integer",INT},
1149   {"lpointer",LPOINTER},
1150   {"mpointer",MPOINTER},
1151   {"opointer",OPOINTER},
1152   {"predef",PREDEF},
1153   {"real",REAL},
1154   {"smpointer",SMPOINTER},
1155   {(char *) 0 ,  -1}
1156   };
1157
1158 /* Type Fortran:  renvoit un codage du type en nombre entier etant donne une chaine */
1159 /* convert string to int FORTRAN type */
1160
1161 int GetForType(char *type)
1162 {
1163   int i=0;
1164   while ( FType[i].fname != (char *) NULL)
1165      {
1166        int j;
1167        j = strcmp(type,FType[i].fname);
1168        if ( j == 0 )
1169          {
1170            return(FType[i].code);
1171          }
1172        else
1173          {
1174            if ( j <= 0)
1175              break;
1176            else i++;
1177          }
1178      }
1179   return(EXTERNAL);
1180 }
1181
1182 /* Type Scilab :  Renvoit la description (string) d'un type a partir de son code */
1183
1184 char *SGetForType(int type)
1185 {
1186   int i=0;
1187   while ( FType[i].code  != -1 )
1188      {
1189        if ( FType[i].code == type )
1190          return(FType[i].fname);
1191        else
1192          i++;
1193      }
1194   return("External");
1195 }
1196
1197 /***************************************************************
1198   Code generation
1199 ***************************************************************/
1200
1201
1202 void WriteMainHeader(FILE *f,char *fname)
1203 {
1204   char *scidir;
1205   Fprintf(f,indent,"subroutine %s\n",fname);
1206   scidir = getenv("SCI");
1207   if ( scidir != NULL)
1208     Fprintf(f,indent,"include '%s/modules/core/includes/stack.h'\n",scidir);
1209   else
1210     Fprintf(f,indent,"include 'SCIDIR/modules/core/includes/stack.h'\n");
1211   Fprintf(f,indent,"rhs = max(0,rhs)\n");
1212   FCprintf(f,"c\n");
1213 }
1214
1215
1216 void WriteHeader(FILE *f,char *fname0,char *fname)
1217 {
1218   Fprintf(f,indent,"subroutine %s%s(fname)\n",fname0,fname);
1219   FCprintf(f,"c\n");
1220   Fprintf(f,indent,"character*(*) fname\n");
1221   Fprintf(f,indent,"include 'stack.h'\n");
1222   FCprintf(f,"c\n");
1223   Fprintf(f,indent,"int iadr, sadr\n");
1224   WriteDeclaration(f);
1225   Fprintf(f,indent,"iadr(l)=l+l-1\n");
1226   Fprintf(f,indent,"sadr(l)=(l/2)+1\n");
1227   Fprintf(f,indent,"rhs = max(0,rhs)\n");
1228   FCprintf(f,"c\n");
1229 }
1230
1231 void WriteFunctionCode(FILE *f)
1232 {
1233   int i;
1234   IVAR ivar;
1235   icre=1;
1236   if ( pass == 1)
1237     {
1238       printf("  generating  code for SCILAB function\"%s\"\n",
1239              basfun->name);
1240       printf("    and FORTRAN subroutine\"%s\"\n",forsub->name);
1241     }
1242   FCprintf(f,"c SCILAB function : %s, fin = %d\n",basfun->name,nFun);
1243   WriteHeader(f,"ints",basfun->name);
1244
1245   /* possibly init for string flag */
1246   for (i = 0; i < forsub->narg; i++)
1247     {
1248       if (variables[forsub->arg[i]-1]->for_type == CHAR)
1249         {
1250           Fprintf(f,indent,"lbuf = 1\n");
1251           break;
1252         }
1253     }
1254
1255   /* init for work space */
1256
1257   AddDeclare(DEC_INT,"topk");
1258   AddDeclare(DEC_INT,"rhsk");
1259   Fprintf(f,indent,"topk = top\n");
1260   Fprintf(f,indent,"rhsk = rhs\n");
1261
1262   /* rhs argument number checking */
1263   AddDeclare(DEC_LOGICAL,"checkrhs");
1264   Fprintf(f,indent,"if(.not.checkrhs(fname,%d,%d)) return\n",basfun->nin - maxOpt,basfun->nin);
1265
1266   /* lhs argument number checking */
1267   ivar = basfun->out;
1268   if ((variables[ivar-1]->length == 0) || (variables[ivar-1]->type == LIST)
1269       || (variables[ivar-1]->type == TLIST))
1270     {
1271       AddDeclare(DEC_LOGICAL,"checklhs");
1272       Fprintf(f,indent,"if(.not.checklhs(fname,1,1)) return\n");
1273     }
1274   else
1275     {
1276       AddDeclare(DEC_LOGICAL,"checklhs");
1277       Fprintf(f,indent,"if(.not.checklhs(fname,1,%d)) return\n",variables[ivar-1]->length);
1278     }
1279
1280   /* SCILAB argument checking */
1281   for (i = 0; i < basfun->nin; i++)
1282     {
1283       switch ( variables[i]->type )
1284         {
1285         case LIST :
1286         case TLIST:
1287           WriteListAnalysis(f,i);
1288           break;
1289         default:
1290           WriteArgCheck(f,i);
1291           break;
1292         }
1293     }
1294
1295   /* SCILAB cross checking */
1296
1297   WriteCrossCheck(f);
1298
1299   /* SCILAB equal output variable checking */
1300   WriteEqualCheck(f);
1301
1302   /* FORTRAN call */
1303   WriteFortranCall(f);
1304
1305   /* FORTRAN output to SCILAB */
1306   WriteOutput(f);
1307 }
1308
1309
1310 void WriteInfoCode(f)
1311      FILE* f;
1312 {
1313   int i,iout;
1314   IVAR ivar;
1315   VARPTR var,vout;
1316
1317   iout = GetExistOutVar();
1318   vout = variables[iout -1];
1319
1320   switch (vout->type) {
1321   case LIST:
1322   case TLIST:
1323     /* loop on output variables */
1324     printf("list(");
1325     for (i = 0; i < vout->length; i++)
1326       {
1327         ivar = vout->el[i];
1328         var = variables[ivar-1];
1329         printf("%s",var->name);
1330         if ( i != vout->length -1 )
1331           printf(",");
1332         else
1333           printf(")");
1334       }
1335     break ;
1336   case SEQUENCE:
1337     /* loop on output variables */
1338     printf("[");
1339     for (i = 0; i < vout->length; i++)
1340       {
1341         ivar = vout->el[i];
1342         var = variables[ivar-1];
1343         printf("%s",var->name);
1344         if ( i != vout->length -1 )
1345           printf(",");
1346         else
1347           printf("]");
1348       }
1349     break;
1350   case EMPTY:
1351     printf("[]\n");
1352     break;
1353   }
1354
1355   printf("=%s(",basfun->name);
1356   for (i = 0; i < basfun->nin; i++)
1357     {
1358       printf("%s(%s)",variables[i]->name,SGetSciType(variables[i]->type));
1359       if ( i != basfun->nin -1 )
1360         printf(",");
1361     }
1362   printf(")\n");
1363
1364 }
1365
1366 /* Ckecking and getting infos for datas coming from scilab calling
1367    sequence ( datas on the stack )
1368 */
1369
1370 void WriteArgCheck(f,i)
1371      FILE *f;
1372      int i;
1373 {
1374   int i1;
1375   char str[MAXNAM];
1376   char str1[MAXNAM];
1377   char size[MAXNAM];
1378   char data[MAXNAM];
1379
1380   VARPTR var = variables[basfun->in[i]-1];
1381   i1 = i + 1;
1382
1383   FCprintf(f,"c       checking variable %s (number %d)\n",var->name,i1);
1384   FCprintf(f,"c      \n");
1385
1386   /* Optional Argument consideration */
1387   if (var->opt_type != 0)
1388     {
1389       /** if (i1 < basfun->nin) {
1390         printf("Optional arguments must be at the end of the calling sequence\n");
1391         exit(1);
1392         }
1393         **/
1394       Fprintf(f,indent++,"if(rhs .le. %d) then\n", i1-1 );
1395       switch (var->opt_type) {
1396       case NAME:
1397         AddDeclare(DEC_LOGICAL,"optvarget");
1398         Fprintf(f,indent,"if (.not.optvarget(fname,topk,%d,'%s       ')) return\n",i1,var->opt_name);
1399         break;
1400       case VALUE:
1401         switch (var->type) {
1402         case SCALAR:
1403           AddDeclare(DEC_LOGICAL,"cremat");
1404           Fprintf(f,indent,"top = top+1\n");
1405           Fprintf(f,indent,"rhs = rhs+1\n");
1406           Fprintf(f,indent,"if(.not.cremat(fname,top,0,1,1,lr%d,lc%d)) return\n",i1,i1);
1407           Fprintf(f,indent,"stk(lr%d)= %s\n",i1,var->opt_name);
1408           break;
1409         case SCISMPOINTER:
1410         case SCILPOINTER:
1411         case SCIBPOINTER:
1412         case SCIOPOINTER:
1413         case SCIMPOINTER:
1414           sprintf(buf,"cre%s", SGetSciType(var->type));
1415           AddDeclare(DEC_LOGICAL,buf);
1416           Fprintf(f,indent,"top = top+1\n");
1417           Fprintf(f,indent,"rhs = rhs+1\n");
1418           Fprintf(f,indent,"if(.not.cre%s(fname,top,lwv)) return\n", SGetSciType(var->type));
1419           break;
1420         case MATRIX:
1421           OptvarGetSize(var->opt_name,size,data);
1422           AddDeclare(DEC_LOGICAL,"cremat");
1423           Fprintf(f,indent,"top = top+1\n");
1424           Fprintf(f,indent,"rhs = rhs+1\n");
1425           sprintf(str,"dat%d %s",i1,data);
1426           AddDeclare(DEC_DATA,str);
1427           sprintf(str,"dat%d(%s)",i1,size);
1428           AddDeclare(DEC_DOUBLE,str);
1429           Fprintf(f,indent,"m%d = 1\n",i1);
1430           Fprintf(f,indent,"n%d = %s\n",i1,size);
1431           Fprintf(f,indent,"if(.not.cremat(fname,top,0,m%d,n%d,lr%d,lc%d)) return\n",i1,i1,i1,i1);
1432           Fprintf(f,indent,"call dcopy(%s,dat%d,1,stk(lr%d),1)\n",size,i1,i1);
1433           break;
1434         case STRING:
1435           AddDeclare(DEC_LOGICAL,"cresmat2");
1436           Fprintf(f,indent,"top = top+1\n");
1437           Fprintf(f,indent,"rhs = rhs+1\n");
1438           Fprintf(f,indent,"nlr%d = %d\n",i1,strlen(var->opt_name));
1439           Fprintf(f,indent,"if(.not.cresmat2(fname,top,nlr%d,lr%d)) return\n",i1,i1,i1);
1440           Fprintf(f,indent,"call cvstr(nlr%d,istk(lr%d),'%s',0)\n",i1,i1,var->opt_name);
1441           break;
1442         default:
1443           printf("Optional variable with value must be \"SCALAR\" or \"STRING\"\n");
1444           exit(1);
1445           break;
1446         }
1447         break;
1448       }
1449       Fprintf(f,--indent,"endif\n");
1450     }
1451
1452   /* size checking */
1453   switch(var->type)
1454     {
1455     case BMATRIX:
1456       AddDeclare(DEC_LOGICAL,"getbmat");
1457       Fprintf(f,indent,"if(.not.getbmat(fname,top,top-rhs+%d,m%d,n%d,lr%d)) return\n",i1,i1,i1,i1);
1458       /* square matrix */
1459       if (var->el[0] == var->el[1]) {
1460         /* square matrix */
1461         AddDeclare(DEC_LOGICAL,"checkval");
1462         Fprintf(f,indent,"if(.not.checkval(fname,m%d,n%d)) return\n",i1,i1);
1463       }
1464       sprintf(str,"m%d",i1);
1465       Check(f,str,var,i1,0);
1466       sprintf(str,"n%d",i1);
1467       Check(f,str,var,i1,1);
1468       break;
1469     case MATRIX:
1470     case IMATRIX:
1471       AddDeclare(DEC_LOGICAL,"getmat");
1472       Fprintf(f,indent,"if(.not.getmat(fname,top,top-rhs+%d,it%d,m%d,n%d,lr%d,lc%d)) return\n",i1,i1,i1,i1,i1,i1);
1473       /* square matrix */
1474       if (var->el[0] == var->el[1]) {
1475         /* square matrix */
1476         AddDeclare(DEC_LOGICAL,"checkval");
1477         Fprintf(f,indent,"if(.not.checkval(fname,m%d,n%d)) return\n",i1,i1);
1478       }
1479       sprintf(str,"m%d",i1);
1480       Check(f,str,var,i1,0);
1481       sprintf(str,"n%d",i1);
1482       Check(f,str,var,i1,1);
1483       sprintf(str,"it%d",i1);
1484       if (var->type == IMATRIX ) AddForName1(var->el[2],str);
1485       break;
1486     case SPARSE:
1487       AddDeclare(DEC_LOGICAL,"getsparse");
1488       Fprintf(f,indent,"if(.not.getsparse(fname,top,top-rhs+%d,it%d,m%d,n%d,nel%d,mnel%d,icol%d,lr%d,lc%d)) return\n",i1,i1,i1,i1,i1,i1,i1,i1,i1);
1489       /* square matrix */
1490       if (var->el[0] == var->el[1]) {
1491         /* square matrix */
1492         AddDeclare(DEC_LOGICAL,"checkval");
1493         Fprintf(f,indent,"if(.not.checkval(fname,m%d,n%d)) return\n",i1,i1);
1494       }
1495       sprintf(str,"m%d",i1);
1496       Check(f,str,var,i1,0);
1497       sprintf(str,"n%d",i1);
1498       Check(f,str,var,i1,1);
1499       sprintf(str,"nel%d",i1);
1500       AddForName1(var->el[2],str);
1501       sprintf(str,"it%d",i1);
1502       AddForName1(var->el[3],str);
1503       break;
1504     case STRINGMAT:
1505       AddDeclare(DEC_LOGICAL,"getsmat");
1506       Fprintf(f,indent,"if(.not.getsmat(fname,top,top-rhs+%d,m%d,n%d,1,1,lr%d,nlr%d)) return\n",
1507               i1,i1,i1,i1,i1);
1508       /* square matrix */
1509       if (var->el[0] == var->el[1]) {
1510         /* square matrix */
1511         AddDeclare(DEC_LOGICAL,"checkval");
1512         Fprintf(f,indent,"if(.not.checkval(fname,m%d,n%d)) return\n",i1,i1);
1513       }
1514       sprintf(str,"m%d",i1);
1515       Check(f,str,var,i1,0);
1516       strcpy(str1,variables[var->el[0]-1]->name);
1517       sprintf(str,"n%d",i1);
1518       Check(f,str,var,i1,1);
1519       break;
1520     case ROW:
1521       AddDeclare(DEC_LOGICAL,"getvectrow");
1522       Fprintf(f,indent,"if(.not.getvectrow(fname,top,top-rhs+%d,it%d,m%d,n%d,lr%d,lc%d)) return\n",i1,i1,i1,i1,i1,i1);
1523       sprintf(str,"n%d",i1);
1524       Check(f,str,var,i1,0);
1525       break;
1526     case COLUMN:
1527       AddDeclare(DEC_LOGICAL,"getvectcol");
1528       Fprintf(f,indent,"if(.not.getvectcol(fname,top,top-rhs+%d,it%d,m%d,n%d,lr%d,lc%d)) return\n",i1,i1,i1,i1,i1,i1);
1529       sprintf(str,"m%d",i1);
1530       Check(f,str,var,i1,0);
1531       break;
1532     case VECTOR:
1533       AddDeclare(DEC_LOGICAL,"getvect");
1534       Fprintf(f,indent,"if(.not.getvect(fname,top,top-rhs+%d,it%d,m%d,n%d,lr%d,lc%d)) return\n",i1,i1,i1,i1,i1,i1);
1535       sprintf(str,"n%d*m%d",i1,i1);
1536       Check(f,str,var,i1,0);
1537       AddForName1(var->el[0],str);
1538       break;
1539     case POLYNOM:
1540       AddDeclare(DEC_LOGICAL,"getonepoly");
1541       sprintf(str,"namelr%d*4",i1);
1542       AddDeclare(DEC_CHAR,str);
1543       Fprintf(f,indent,"if(.not.getonepoly(fname,top,top-rhs+%d,it%d,m%d,namelr%d,namellr%d,lr%d,lc%d)\n",i1,i1,i1,i1,i1,i1,i1);
1544       AddDeclare(DEC_LOGICAL,"checkval");
1545       sprintf(str,"m%d",i1);
1546       Check(f,str,var,i1,0);
1547       AddForName(var->el[0],str);
1548       break;
1549     case SCALAR:
1550       AddDeclare(DEC_LOGICAL,"getscalar");
1551       Fprintf(f,indent,"if(.not.getscalar(fname,top,top-rhs+%d,lr%d)) return\n",i1,i1);
1552       break;
1553     case SCIMPOINTER:
1554     case SCISMPOINTER:
1555     case SCILPOINTER:
1556     case SCIBPOINTER:
1557     case SCIOPOINTER:
1558       sprintf(buf,"get%s", SGetSciType(var->type));
1559       AddDeclare(DEC_LOGICAL,buf);
1560       Fprintf(f,indent,"if(.not.get%s(fname,top,top-rhs+%d,lr%d)) return\n", SGetSciType(var->type),i1,i1);
1561       break;
1562     case STRING:
1563       AddDeclare(DEC_LOGICAL,"getsmat");
1564       Fprintf(f,indent,"if(.not.getsmat(fname,top,top-rhs+%d,m%d,n%d,1,1,lr%d,nlr%d)) return\n",i1,i1,i1,i1,i1,i1,11);
1565       AddDeclare(DEC_LOGICAL,"checkval");
1566       Fprintf(f,indent,"if(.not.checkval(fname,m%d*n%d,1)) return\n",i1,i1);
1567       sprintf(str,"nlr%d",i1);
1568       Check(f,str,var,i1,0);
1569       break;
1570     case ANY:
1571     case LIST:
1572     case TLIST:
1573       break;
1574     default:
1575       printf("unknown variable type %d\n",var->type);
1576     }
1577 }
1578
1579 void OptvarGetSize(optvar,size,data)
1580      char *optvar,*size,*data;
1581 {
1582   int i,j=0,ok=0;
1583   for ( i = 0 ; i < (int) strlen(optvar) ; i++ )
1584        {
1585          if ( optvar[i] == ')' )
1586            {
1587              size[j++] = '\0'; break;
1588            }
1589          if ( ok ==1 ) size[j++]= optvar[i];
1590          if ( optvar[i] == '(' ) ok =1 ;
1591        }
1592   if ( i < (int) strlen(optvar)) strcpy(data,optvar+i+1);
1593 }
1594
1595 /*
1596   Utility function for WriteArgCheck
1597   Check for fixed sized dimensions
1598 */
1599
1600 void Check(f,str,var,i1,nel)
1601      FILE *f;
1602      char *str;
1603      int i1, nel;
1604      VARPTR var;
1605 {
1606   char str1[MAXNAM];
1607   strcpy(str1,variables[var->el[nel]-1]->name);
1608   if (isdigit(str1[0]) != 0)
1609     {
1610       /* the dimension of the variable is a constant int */
1611       if ( strcmp(str,str1) != 0)
1612         {
1613           AddDeclare(DEC_LOGICAL,"checkval");
1614           Fprintf(f,indent,"if(.not.checkval(fname,%s,%s)) return\n",str,str1);
1615         }
1616     }
1617   AddForName1(var->el[nel],str);
1618 }
1619
1620
1621 void WriteCrossCheck(f)
1622      FILE *f;
1623 {
1624   int i, j;
1625   char *n1, *n2;
1626   VARPTR var;
1627   FCprintf(f,"c    \n");
1628   FCprintf(f,"c       cross variable size checking\n");
1629   FCprintf(f,"c    \n");
1630   for (i = 0; i < nVariable; i++) {
1631     var = variables[i];
1632     /* does not check list elements */
1633     if (var->nfor_name != 0 && var->list_el == 0) {
1634       if (strncmp(var->for_name[0],"ne",2) != 0 &&
1635           strncmp(var->for_name[0],"me",2) != 0) {
1636         n1 = Forname2Int(var->for_name[0]);
1637         for (j = 1; j < var->nfor_name; j++) {
1638           n2 = Forname2Int(var->for_name[j]);
1639           if ( strcmp(n1,n2) != 0)
1640             {
1641               AddDeclare(DEC_LOGICAL,"checkval");
1642               Fprintf(f,indent,"if(.not.checkval(fname,%s,%s)) return\n",n1,n2);
1643             }
1644         }
1645       }
1646     }
1647   }
1648   /*  FCprintf(f,"c    \n");
1649   FCprintf(f,"c       cross formal parameter checking\n");
1650   FCprintf(f,"c       not implemented yet\n");  */
1651 }
1652
1653 void WriteEqualCheck(f)
1654      FILE *f;
1655 {
1656   /* FCprintf(f,"c    \n");
1657   FCprintf(f,"c       cross equal output variable checking\n");
1658   FCprintf(f,"c       not implemented yet\n"); */
1659 }
1660
1661 void WriteFortranCall(f)
1662      FILE *f;
1663 {
1664   int i, j, ind;
1665   IVAR ivar, iivar;
1666   char call[MAXCALL];
1667   char str1[8],str2[8];
1668   sprintf(call,"call %s(",forsub->name);
1669   /* loop on FORTRAN arguments */
1670   for (i = 0; i < forsub->narg; i++)
1671     {
1672       ivar = forsub->arg[i];
1673       ind = 0;
1674       if (variables[ivar-1]->list_el != 0)
1675         {
1676           /* FORTRAN argument is a list element */
1677           iivar = GetExistVar(variables[ivar-1]->list_name);
1678           for (j = 0; j < basfun->nin; j++)
1679             {
1680               if (iivar == basfun->in[j])
1681                 {
1682                   /* it must be a SCILAB argument */
1683                   sprintf(str1,"%de%d",iivar,variables[ivar-1]->list_el);
1684                   sprintf(str2,"%de%d",iivar,variables[ivar-1]->list_el);
1685                   WriteCallConvertion(f,ivar,str2,str1,call);
1686                   ind = 1;
1687                   break;
1688                 }
1689             }
1690           if (ind == 0)
1691             {
1692               printf("list or tlist \"%s\" must be an argument of SCILAB function\n",
1693                      variables[ivar-1]->list_name);
1694               exit(1);
1695             }
1696         }
1697       else
1698         {
1699           for (j = 0; j < basfun->nin; j++)
1700             {
1701               if (ivar == basfun->in[j])
1702                 {
1703                   /* FORTRAN argument is a SCILAB argument */
1704                   sprintf(str1,"%d",j+1);
1705                   sprintf(str2,"%d",i+1);
1706                   WriteCallConvertion(f,ivar,str2,str1,call);
1707                   ind = 1;
1708                   break;
1709                 }
1710             }
1711         }
1712       if (ind == 0)
1713         {
1714           /* FORTRAN argument is not a SCILAB argument */
1715           WriteCallRest(f,ivar,i+1,call);
1716         }
1717     }
1718   if  (forsub->narg == 0)
1719     strcat(call,")");
1720   else
1721     call[strlen(call)-1] = ')';
1722   Fprintf(f,indent,call);
1723   Fprintf(f,indent,"\n");
1724   /*
1725       Fprintf(f,indent++,"if(err .gt. 0) then\n");
1726       Fprintf(f,indent,"buf = fname // ' Internal Error'\n");
1727       Fprintf(f,indent,"call error(999)\n");
1728       Fprintf(f,indent,"return\n");
1729       Fprintf(f,--indent,"endif\n");
1730   */
1731   Fprintf(f,indent,"if(err .gt. 0 .or. err1 .gt. 0) return\n");
1732
1733   FCprintf(f,"c\n");
1734 }
1735
1736 /*
1737   Convertion to a Fortran type before caling sequence
1738   for arguments coming from the scilab stack
1739   the part of the caing sequence is adde to the buffer call
1740 */
1741
1742 void WriteCallConvertion(f,ivar,farg,barg,call)
1743      FILE *f;
1744      IVAR ivar;
1745      char *farg;
1746      char *barg;
1747      char *call;
1748 {
1749   VARPTR var = variables[ivar-1];
1750   char str[MAXNAM];
1751   char str1[MAXNAM];
1752   switch (var->type)
1753     {
1754     case POLYNOM:
1755     case ROW:
1756     case VECTOR:
1757     case SCALAR:
1758     case COLUMN:
1759     case IMATRIX:
1760     case MATRIX:
1761     case SPARSE:
1762       switch ( var->type )
1763         {
1764         case POLYNOM: sprintf(str1,"n%s",barg); break;
1765         case COLUMN: sprintf(str1,"m%s",barg); break ;
1766         case VECTOR:  sprintf(str1,"m%s*n%s",barg,barg); break ;
1767         case SCALAR:  sprintf(str1,"1"); break ;
1768         case ROW:  sprintf(str1,"n%s",barg); break;
1769         case SPARSE: sprintf(str1,"nel%s",barg);break;
1770         case IMATRIX:
1771         case MATRIX:  sprintf(str1,"n%s*m%s",barg,barg); break;
1772         }
1773       switch (var->for_type)
1774         {
1775         case CHAR:
1776         case CSTRINGV:
1777           printf("incompatibility between the variable type and the FORTRAN type for variable \"%s\"\n",var->name);
1778           exit(1);
1779         case INT:
1780           Fprintf(f,indent,"call entier(%s,stk(lr%s),istk(iadr(lr%s)))\n",str1,barg,barg);
1781           if (var->type == IMATRIX || var->type == SPARSE)
1782             {
1783               Fprintf(f,indent++,"if (it%s.eq.1) then\n",barg);
1784               Fprintf(f,indent,"call entier(%s,stk(lc%s),istk(iadr(lc%s)))\n",str1,barg,barg);
1785               Fprintf(f,--indent,"endif\n");
1786               if ( var->type == SPARSE)
1787                 sprintf(str,"it%s,m%s,n%s,nel%s,istk(mnel%s),istk(icol%s),istk(iadr(lr%s)),istk(iadr(lc%s))"
1788                         ,barg,barg,barg,barg,barg,barg,barg,barg);
1789               else
1790                 sprintf(str,"istk(iadr(lr%s)),istk(iadr(lc%s)),it%s",barg,barg,barg);
1791               ChangeForName(ivar,str);
1792               strcat(call,str);
1793               strcat(call,",");
1794             }
1795           else
1796             {
1797               sprintf(str,"istk(iadr(lr%s))",barg);
1798               ChangeForName(ivar,str);
1799               strcat(call,str);
1800               strcat(call,",");
1801             }
1802           break;
1803         case REAL:
1804           Fprintf(f,indent,"call simple(%s,stk(lr%s),stk(lr%s))\n",str1,barg,barg,barg);
1805           if (var->type == IMATRIX || var->type == SPARSE)
1806             {
1807               Fprintf(f,indent++,"if (it%s.eq.1) then\n",barg);
1808               Fprintf(f,indent,"call simple(%s,stk(lc%s),stk(lc%s))\n",str1,barg,barg);
1809               Fprintf(f,--indent,"endif\n");
1810               if ( var->type == SPARSE)
1811                 sprintf(str,"it%s,m%s,n%s,nel%s,istk(mnel%s),istk(icol%s),stk(lr%s),stk(lc%s),"
1812                         ,barg,barg,barg,barg,barg,barg,barg,barg);
1813               else
1814                 sprintf(str,"stk(lr%s),stk(lc%s),it%s,",barg,barg,barg);
1815               strcat(call,str);
1816             }
1817           else
1818             {
1819               sprintf(str,"stk(lr%s),",barg);
1820               strcat(call,str);
1821             }
1822           break;
1823         case DOUBLE:
1824           if (var->type == IMATRIX)
1825             {
1826               sprintf(str,"stk(lr%s),stk(lc%s),it%s,",barg,barg,barg);
1827               strcat(call,str);
1828             }
1829           else if (var->type == SPARSE)
1830             {
1831               sprintf(str,"it%s,m%s,n%s,nel%s,istk(mnel%s),istk(icol%s),stk(lr%s),stk(lc%s),"
1832                       ,barg,barg,barg,barg,barg,barg,barg,barg);
1833               strcat(call,str);
1834             }
1835           else
1836             {
1837               sprintf(str,"stk(lr%s),",barg);
1838               strcat(call,str);
1839             }
1840           break;
1841         }
1842       break;
1843     case BMATRIX:
1844       sprintf(str1,"n%s*m%s",barg,barg);
1845       if (var->for_type != INT)
1846         {
1847           printf("incompatibility between the type %s and FORTRAN type %s for variable \"%s\"\n",
1848                  SGetSciType(var->type),SGetForType(var->for_type),var->name);
1849           exit(1);
1850         }
1851       sprintf(str,"istk(lr%s)",barg);
1852       ChangeForName(ivar,str);
1853       strcat(call,str);
1854       strcat(call,",");
1855       break;
1856     case SCIMPOINTER:
1857       if (var->for_type != MPOINTER)
1858         {
1859           printf("incompatibility between the type %s and FORTRAN type %s for variable \"%s\"\n",
1860                  SGetSciType(var->type),SGetForType(var->for_type),var->name);
1861           exit(1);
1862         }
1863       sprintf(str,"stk(lr%s),",barg);
1864       strcat(call,str);
1865       break;
1866     case SCISMPOINTER:
1867       if (var->for_type != SMPOINTER)
1868         {
1869           printf("incompatibility between the type %s and FORTRAN type %s for variable \"%s\"\n",
1870                  SGetSciType(var->type),SGetForType(var->for_type),var->name);
1871           exit(1);
1872         }
1873       sprintf(str,"stk(lr%s),",barg);
1874       strcat(call,str);
1875       break;
1876     case SCILPOINTER:
1877       if (var->for_type != LPOINTER)
1878         {
1879           printf("incompatibility between the type %s and FORTRAN type %s for variable \"%s\"\n",
1880                  SGetSciType(var->type),SGetForType(var->for_type),var->name);
1881           exit(1);
1882         }
1883       sprintf(str,"stk(lr%s),",barg);
1884       strcat(call,str);
1885       break;
1886     case SCIBPOINTER:
1887       if (var->for_type != BPOINTER)
1888         {
1889           printf("incompatibility between the type %s and FORTRAN type %s for variable \"%s\"\n",
1890                  SGetSciType(var->type),SGetForType(var->for_type),var->name);
1891           exit(1);
1892         }
1893       sprintf(str,"stk(lr%s),",barg);
1894       strcat(call,str);
1895       break;
1896     case SCIOPOINTER:
1897       if (var->for_type != OPOINTER)
1898         {
1899           printf("incompatibility between the type %s and FORTRAN type %s for variable \"%s\"\n",
1900                  SGetSciType(var->type),SGetForType(var->for_type),var->name);
1901           exit(1);
1902         }
1903       sprintf(str,"stk(lr%s),",barg);
1904       strcat(call,str);
1905       break;
1906     case STRINGMAT:
1907       if (var->for_type != CSTRINGV)
1908         {
1909           printf("incompatibility between the type %s and FORTRAN type %s for variable \"%s\"\n",
1910                  SGetSciType(STRINGMAT),SGetForType(var->for_type),var->name);
1911           exit(1);
1912         }
1913       AddDeclare(DEC_LOGICAL,"crestringv");
1914       Fprintf(f,indent,"if(.not.crestringv(fname,top+%d,lr%s-5-m%s*n%s,lw%s)) return\n",icre++,barg,barg,barg,farg);
1915       sprintf(str,"stk(lw%s),",farg);
1916       strcat(call,str);
1917       break;
1918     case LIST:
1919     case TLIST:
1920     case SEQUENCE:
1921       printf("a FORTRAN argument cannot have a variable type of \"LIST\"\n");
1922       printf("  \"TLIST\" or \"SEQUENCE\"\n");
1923       exit(1);
1924       break;
1925     case STRING:
1926       if (var->for_type != CHAR)
1927         {
1928           printf("incompatibility between the type %s and FORTRAN type %s for variable \"%s\"\n",
1929                  SGetSciType(STRING),SGetForType(var->for_type),var->name);
1930           exit(1);
1931         }
1932       AddDeclare(DEC_LOGICAL,"bufstore");
1933       Fprintf(f,indent,"if(.not.bufstore(fname,lbuf,lbufi%s,lbuff%s,lr%s,nlr%s)) return\n",farg,farg,barg,barg);
1934       sprintf(str,"buf(lbufi%s:lbuff%s),",farg,farg);
1935       strcat(call,str);
1936       break;
1937     case ANY:
1938       sprintf(str,"istk(il%s),",barg);
1939       strcat(call,str);
1940       break;
1941     }
1942 }
1943
1944 /*
1945   Calling sequence for variables not coming from the
1946   scilab calling sequence
1947   working or output variables
1948 */
1949
1950 void WriteCallRest(f,ivar,farg,call)
1951      FILE *f;
1952      IVAR ivar;
1953      int farg;
1954      char *call;
1955 {
1956   VARPTR var = variables[ivar-1];
1957   char str[MAXNAM];
1958   char str1[MAXNAM];
1959   char str2[MAXNAM];
1960   char str3[MAXNAM];
1961   char str4[MAXNAM];
1962   switch (var->type)
1963     {
1964     case 0:
1965       /* FORTRAN argument is the dimension of an output variable with EXTERNAL type */
1966       if (var->nfor_name == 0 && var->for_type != PREDEF)
1967         {
1968           printf("dimension variable \"%s\" is not defined\n",var->name);
1969           exit(1);
1970         }
1971       switch (var->for_type)
1972         {
1973         case PREDEF:
1974           if ( strcmp(var->name,"rhs") == 0)
1975             sprintf(str,"rhsk");
1976           else
1977             sprintf(str,"%s",var->name);
1978           strcat(call,str);
1979           strcat(call,",");
1980           break;
1981         case 0:
1982         case INT:
1983           sprintf(str,"%s",var->for_name[0]);
1984           if ( ~isdigit(str[0]))
1985             {
1986               strcat(call,str);
1987               strcat(call,",");
1988             }
1989           else
1990             {
1991               Fprintf(f,indent,"locd%d= int(%s)\n",farg,var->for_name[0]);
1992               sprintf(str,"locd%d,",farg);
1993               strcat(call,str);
1994               sprintf(str,"locd%d",farg);
1995               AddDeclare(DEC_INT,str);
1996             }
1997           break;
1998         case DOUBLE:
1999           Fprintf(f,indent,"locd%d= dble(%s)\n",farg,var->for_name[0]);
2000           sprintf(str,"locd%d,",farg);
2001           strcat(call,str);
2002           sprintf(str,"locd%d",farg);
2003           AddDeclare(DEC_DOUBLE,str);
2004           break;
2005         case REAL:
2006           Fprintf(f,indent,"locr%d=real(%s)\n",farg,var->for_name[0]);
2007           sprintf(str,"locr%d,",farg);
2008           strcat(call,str);
2009           sprintf(str,"locr%d",farg);
2010           AddDeclare(DEC_REAL,str);
2011           break;
2012         case CHAR:
2013         case CSTRINGV:
2014           printf("a dimension variable cannot have FORTRAN type \"%s\"\n",SGetForType(var->for_type));
2015           exit(1);
2016           break;
2017         }
2018       break;
2019     /* working or output argument (always double reservation!) */
2020     case COLUMN:
2021     case ROW:
2022     case WORK:
2023     case POLYNOM:
2024     case VECTOR:
2025       WriteCallRestCheck(f,var,farg,"nn",0,0) ;
2026       if (var->for_type == EXTERNAL)
2027         strcpy(str1,"1");
2028       else
2029         strcpy(str1,Forname2Int(variables[var->el[0]-1]->for_name[0]));
2030       AddDeclare(DEC_LOGICAL,"cremat");
2031       Fprintf(f,indent,"if(.not.cremat(fname,top+%d,0,%s,1,lw%d,loc%d)) return\n",icre++,str1,farg,farg);
2032       sprintf(str,"stk(lw%d),",farg);
2033       strcat(call,str);
2034       break;
2035     case SPARSE :
2036       WriteCallRestCheck(f,var,farg,"nn",0,0) ;
2037       WriteCallRestCheck(f,var,farg,"mm",1,0) ;
2038       if (var->for_type == EXTERNAL)
2039         {
2040           strcpy(str1,"1");
2041           strcpy(str2,"1");
2042           Fprintf(f,indent,"if(.not.cremat(fname,top+%d,0,%s,%s,lw%d,lwc%d)) return\n",icre++,str1,str2,farg,farg);
2043           AddDeclare(DEC_LOGICAL,"cremat");
2044           sprintf(str,"stk(lw%d),",farg);
2045           strcat(call,str);
2046         }
2047       else
2048         {
2049           sprintf(str1,"%s",Forname2Int(variables[var->el[0]-1]->for_name[0]));
2050           sprintf(str2,"%s",Forname2Int(variables[var->el[1]-1]->for_name[0]));
2051           sprintf(str3,"%s",Forname2Int(variables[var->el[2]-1]->for_name[0]));
2052           sprintf(str4,"%s",Forname2Int(variables[var->el[3]-1]->for_name[0]));
2053           AddDeclare(DEC_LOGICAL,"cresparse");
2054           Fprintf(f,indent,"if(.not.cresparse(fname,top+%d,%s,%s,%s,%s,mnel%d,icol%d,lw%d,lwc%d)) return\n",icre++,str4,str1,str2,str3,farg,farg,farg,farg);
2055           sprintf(str,"%s,%s,%s,%s,istk(mnel%d),istk(icol%d),stk(lw%d),stk(lwc%d),",
2056                   str4,str1,str2,str3,farg,farg,farg,farg);
2057           strcat(call,str);
2058         }
2059       break;
2060     case IMATRIX:
2061       WriteCallRestCheck(f,var,farg,"nn",0,0) ;
2062       WriteCallRestCheck(f,var,farg,"mm",1,0) ;
2063       if (var->for_type == EXTERNAL)
2064         {
2065           strcpy(str1,"1");
2066           strcpy(str2,"1");
2067           strcpy(str3,"1");
2068         }
2069       else
2070         {
2071           sprintf(str1,"%s",Forname2Int(variables[var->el[0]-1]->for_name[0]));
2072           sprintf(str2,"%s",Forname2Int(variables[var->el[1]-1]->for_name[0]));
2073           sprintf(str3,"%s",Forname2Int(variables[var->el[2]-1]->for_name[0]));
2074         };
2075       AddDeclare(DEC_LOGICAL,"cremat");
2076       Fprintf(f,indent,"if(.not.cremat(fname,top+%d,%s,%s,%s,lw%d,lwc%d)) return\n",icre++,str3,str1,str2,farg,farg);
2077       sprintf(str3,"%s",Forname2Int(variables[var->el[2]-1]->for_name[0]));
2078       sprintf(str,"stk(lw%d),stk(lwc%d),%s,",farg,farg,str3);
2079       strcat(call,str);
2080       break;
2081     case MATRIX:
2082       WriteCallRestCheck(f,var,farg,"nn",0,0) ;
2083       WriteCallRestCheck(f,var,farg,"mm",1,0) ;
2084       if (var->for_type == EXTERNAL)
2085         {
2086           strcpy(str1,"1");
2087           strcpy(str2,"1");
2088         }
2089       else
2090         {
2091           sprintf(str1,"%s",Forname2Int(variables[var->el[0]-1]->for_name[0]));
2092           sprintf(str2,"%s",Forname2Int(variables[var->el[1]-1]->for_name[0]));
2093         };
2094       AddDeclare(DEC_LOGICAL,"cremat");
2095       Fprintf(f,indent,"if(.not.cremat(fname,top+%d,0,%s,%s,lw%d,lwc%d)) return\n",icre++,str1,str2,farg,farg);
2096       sprintf(str,"stk(lw%d),",farg);
2097       strcat(call,str);
2098       break;
2099     case BMATRIX:
2100       WriteCallRestCheck(f,var,farg,"nn",0,0) ;
2101       WriteCallRestCheck(f,var,farg,"mm",1,0) ;
2102       if (var->for_type == EXTERNAL)
2103         {
2104           strcpy(str1,"1");
2105           strcpy(str2,"1");
2106         }
2107       else
2108         {
2109           sprintf(str1,"%s",Forname2Int(variables[var->el[0]-1]->for_name[0]));
2110           sprintf(str2,"%s",Forname2Int(variables[var->el[1]-1]->for_name[0]));
2111         };
2112       AddDeclare(DEC_LOGICAL,"crebmat");
2113       Fprintf(f,indent,"if(.not.crebmat(fname,top+%d,%s,%s,lw%d)) return\n",icre++,str1,str2,farg);
2114       sprintf(str,"istk(lw%d),",farg);
2115       strcat(call,str);
2116       break;
2117     case SCIMPOINTER:
2118     case SCISMPOINTER:
2119     case SCILPOINTER:
2120     case SCIBPOINTER:
2121     case SCIOPOINTER:
2122       sprintf(buf,"cre%s", SGetSciType(var->type));
2123       AddDeclare(DEC_LOGICAL,buf);
2124       Fprintf(f,indent,"if(.not.cre%s(fname,top+%d,lw%d)) return\n", SGetSciType(var->type),icre++,farg);
2125       sprintf(str,"stk(lw%d),",farg);
2126       strcat(call,str);
2127       break;
2128     case STRINGMAT:
2129       if (var->for_type == EXTERNAL || var->for_type == CSTRINGV )
2130         {
2131           /* for external or cstringv parameters, unknown formal dimensions
2132              can be used */
2133           WriteCallRestCheck(f,var,farg,"mm",0,1) ;
2134           WriteCallRestCheck(f,var,farg,"nn",1,1) ;
2135           sprintf(str,"mm%d",farg);
2136           AddForName1(var->el[0],str);
2137           sprintf(str,"nn%d",farg);
2138           AddForName1(var->el[1],str);
2139           AddDeclare(DEC_LOGICAL,"crepointer");
2140           Fprintf(f,indent,"if(.not.crepointer(fname,top+%d,lw%d)) return\n",icre++,farg);
2141           sprintf(str,"stk(lw%d),",farg);
2142           strcat(call,str);
2143         }
2144       else
2145         {
2146           /** XXXX dimensions should be specifief **/
2147           fprintf(stderr,"WARNING : your code contains a specification\n");
2148           fprintf(stderr," not fully implemented in intersci\n");
2149           WriteCallRestCheck(f,var,farg,"mm",0,0) ;
2150           WriteCallRestCheck(f,var,farg,"nn",1,0) ;
2151           AddDeclare(DEC_LOGICAL,"cresmatafaire");
2152           Fprintf(f,indent,"if(.not.cresmatafaire(fname,top+%d,lw%d)) return\n",icre++,farg);
2153           sprintf(str,"stk(lw%d),",farg);
2154           strcat(call,str);
2155         }
2156       break;
2157     case SCALAR:
2158       AddDeclare(DEC_LOGICAL,"cremat");
2159       Fprintf(f,indent,"if(.not.cremat(fname,top+%d,0,1,1,lw%d,loc%d)) return\n",icre++,farg,farg);
2160       sprintf(str,"stk(lw%d),",farg);
2161       strcat(call,str);
2162       break;
2163     case STRING:
2164       WriteCallRestCheck(f,var,farg,"nn",0,0) ;
2165       if (var->for_type == EXTERNAL)
2166         {
2167           AddDeclare(DEC_LOGICAL,"crepointer");
2168           Fprintf(f,indent,"if(.not.crepointer(fname,top+%d,lw%d)) return\n",icre++,farg);
2169           sprintf(str,"stk(lw%d),",farg);
2170           strcat(call,str);
2171         }
2172       else
2173         {
2174           strcpy(str1,Forname2Int(variables[var->el[0]-1]->for_name[0]));
2175           AddDeclare(DEC_LOGICAL,"cresmat2");
2176           Fprintf(f,indent,"if(.not.cresmat2(fname,top+%d,%s,lr%d)) return\n",icre++,str1,farg);
2177           AddDeclare(DEC_LOGICAL,"bufstore");
2178           Fprintf(f,indent,"if(.not.bufstore(fname,lbuf,lbufi%d,lbuff%d,lr%d,%s)) return\n",farg,farg,farg,str1);
2179           sprintf(str,"buf(lbufi%d:lbuff%d),",farg,farg);
2180           strcat(call,str);
2181         }
2182       break;
2183     case LIST:
2184     case TLIST:
2185     case SEQUENCE:
2186     case ANY:
2187       printf("work or output FORTRAN argument cannot have\n");
2188       printf("  type \"ANY\", \"LIST\", \"TLIST\" or \"SEQUENCE\"\n");
2189       exit(1);
2190       break;
2191     }
2192 }
2193
2194 /* Utility function for WriteCallRest
2195    when flag==1 we acccept undefined dimensions
2196    this is used with stringmat/Cstringv
2197    where dimensions and space are allocated inside
2198    the interfaced function and returned
2199    to the interface */
2200
2201 void WriteCallRestCheck(f,var,farg,name,iel,flag)
2202      VARPTR var ;
2203      FILE *f;
2204      char *name;
2205      int iel,farg,flag;
2206 {
2207   char sdim[MAXNAM];
2208   char str[MAXNAM];
2209   int ind,j;
2210   if (variables[var->el[iel]-1]->nfor_name == 0)
2211     {
2212       strcpy(str,variables[var->el[iel]-1]->name);
2213       if (isdigit(str[0]) == 0)
2214         {
2215           ind = 0;
2216           for (j = 0; j < basfun->nin; j++)
2217             {
2218               if (strcmp(variables[var->el[iel]-1]->name,
2219                          variables[basfun->in[j]-1]->name) == 0)
2220                 {
2221                   /* dimension of FORTRAN argument is a SCILAB argument */
2222                   sprintf(sdim,"%s%d",name,farg);
2223                   Fprintf(f,indent,"%s= int(stk(lr%d))\n",sdim,j+1);
2224                   AddForName1(var->el[iel],sdim);
2225                   ind = 1;
2226                   break;
2227                 }
2228             }
2229           if (ind == 0 && flag != 1 )
2230             {
2231               /**
2232               printf("dimension variable \"%s\" is not defined\n",
2233                      variables[var->el[iel]-1]->name);
2234               exit(1);
2235               **/
2236             }
2237         }
2238       else
2239         {
2240           sprintf(sdim,"%s%d",name,farg);
2241           Fprintf(f,indent,"%s=%s\n",sdim,str);
2242           AddForName1(var->el[iel],sdim);
2243         }
2244     }
2245 }
2246
2247 void WriteOutput(f)
2248      FILE *f;
2249 {
2250   IVAR iout,ivar;
2251   VARPTR var,vout;
2252   int i;
2253
2254   Fprintf(f,indent,"topk=top-rhs\n");
2255   AddDeclare(DEC_INT,"topl");
2256   Fprintf(f,indent,"topl=top+%d\n",icre-1);
2257
2258   iout = GetExistOutVar();
2259   vout = variables[iout -1];
2260
2261   switch (vout->type) {
2262   case LIST:
2263   case TLIST:
2264     FCprintf(f,"c       Creation of output %s\n",SGetSciType(vout->type));
2265     Fprintf(f,indent,"top=topl+1\n");
2266     Fprintf(f,indent,"call cre%s(top,%d,lw)\n",SGetSciType(vout->type),vout->length);
2267     /* loop on output variables */
2268     for (i = 0; i < vout->length; i++)
2269       {
2270         ivar = vout->el[i];
2271         var = variables[ivar-1];
2272         FCprintf(f,"c    \n");
2273         FCprintf(f,"c       Element %d: %s\n",i+1,var->name);
2274         WriteVariable(f,var,ivar,1,i+1);
2275       }
2276     FCprintf(f,"c    \n");
2277     FCprintf(f,"c     Putting in order the stack\n");
2278     Fprintf(f,indent,"call copyobj(fname,topl+1,topk+1)\n");
2279     Fprintf(f,indent,"top=topk+1\n");
2280     Fprintf(f,indent,"return\n");
2281     break;
2282   case SEQUENCE:
2283     /* loop on output variables */
2284     for (i = 0; i < vout->length; i++)
2285       {
2286         ivar = vout->el[i];
2287         var = variables[ivar-1];
2288         FCprintf(f,"c    \n");
2289         Fprintf(f,indent++,"if(lhs .ge. %d) then\n",i+1);
2290         FCprintf(f,"c       --------------output variable: %s\n",var->name);
2291         Fprintf(f,indent,"top=topl+%d\n",i+1);
2292         WriteVariable(f,var,ivar,0,0);
2293         Fprintf(f,--indent,"endif\n");
2294       }
2295     FCprintf(f,"c     Putting in order the stack\n");
2296     for (i = 0; i < vout->length; i++)
2297       {
2298         Fprintf(f,indent++,"if(lhs .ge. %d) then\n",i+1);
2299         Fprintf(f,indent,"call copyobj(fname,topl+%d,topk+%d)\n",i+1,i+1);
2300         Fprintf(f,--indent,"endif\n");
2301       }
2302     Fprintf(f,indent,"top=topk+lhs\n");
2303     Fprintf(f,indent,"return\n");
2304     break;
2305   case EMPTY:
2306     FCprintf(f,"c       no output variable\n");
2307     Fprintf(f,indent,"top=topk+1\n");
2308     Fprintf(f,indent,"call objvide(fname,top)\n");
2309     Fprintf(f,indent,"return\n");
2310     break;
2311   }
2312   Fprintf(f,indent,"end\n");
2313   FCprintf(f,"c\n");
2314 }
2315
2316 void WriteVariableOutput(f,var,barg,farg,convert,insidelist,nel)
2317      FILE *f;
2318      VARPTR var;
2319      int barg, farg, insidelist,convert,nel;
2320 {
2321   char strR[MAXNAM];
2322   char str[MAXNAM];
2323   char strc[MAXNAM];
2324   char strit[MAXNAM];
2325   char str1[MAXNAM];
2326   char str2[MAXNAM];
2327   char str3[MAXNAM];
2328   char str4[MAXNAM];
2329   if (convert == 1) {
2330     /* seams to give a bug with ex13fi.desc
2331     barg = 0;
2332     */
2333   }
2334   /* farg and barg depends on the list or not list case */
2335
2336   /* if ( insidelist != 0 && var->list_name != (char *) 0 ) */
2337   /* jpc sept 1997 : was the var inside a list or not */
2338
2339   /* bug here on Windows (intersci example ext11c) */
2340   /* var->list_name!= (char *) 0 OK but not with a valid pointer */
2341
2342   if ( var->list_name != (char *) 0 )
2343     {
2344       int ivart,fargt,bargt,nel1;
2345       ivart=GetExistVar(var->list_name);
2346       bargt=GetNumberInScilabCall(ivart);
2347       fargt=GetNumberInFortranCall(ivart);
2348       nel1= var->list_el;
2349       if (convert == 1)
2350         {
2351           /* tricky, isn'it ? */
2352           bargt = 0;
2353         }
2354       if (bargt == 0)
2355         {
2356           sprintf(strR,"%de%d",fargt,nel1);
2357           sprintf(str,"lw%de%d",fargt,nel1);
2358           sprintf(strc,"lwc%de%d",fargt,nel1);
2359           sprintf(strit,"itr%de%d",fargt,nel1);
2360         }
2361       else
2362         {
2363           sprintf(strR,"%de%d",bargt,nel1);
2364           sprintf(str,"lr%de%d",bargt,nel1);
2365           sprintf(strc,"lc%de%d",bargt,nel1);
2366           sprintf(strit,"it%de%d",bargt,nel1); /** sept97 itr->it **/
2367         }
2368     }
2369   else
2370     {
2371       if (barg == 0)
2372         {
2373           sprintf(strR,"%d",farg);
2374           sprintf(str,"lw%d",farg);
2375           sprintf(strc,"lwc%d",farg);
2376           sprintf(strit,"itr%d",farg);
2377         }
2378       else
2379         {
2380           sprintf(strR,"%d",barg);
2381           sprintf(str,"lr%d",barg);
2382           sprintf(strc,"lc%d",barg);
2383           sprintf(strit,"it%d",farg); /** Mars 1997 itr -> it **/
2384         }
2385     }
2386   switch (var->type)
2387     {
2388     case COLUMN:
2389     case ROW:
2390     case VECTOR:
2391     case MATRIX:
2392     case SCALAR:
2393       switch ( var->type  )
2394         {
2395         case COLUMN:
2396           strcpy(str2,"1");
2397           strcpy(str1,Forname2Int(variables[var->el[0]-1]->for_name[0]));
2398           break;
2399         case ROW:
2400         case VECTOR:
2401           strcpy(str1,"1");
2402           strcpy(str2,Forname2Int(variables[var->el[0]-1]->for_name[0]));
2403           break;
2404         case MATRIX:
2405           strcpy(str1,Forname2Int(variables[var->el[0]-1]->for_name[0]));
2406           strcpy(str2,Forname2Int(variables[var->el[1]-1]->for_name[0]));
2407           break;
2408         case SCALAR:
2409           strcpy(str1,"1");
2410           strcpy(str2,"1");
2411           break;
2412         }
2413       if ( insidelist != 0)
2414         {
2415           AddDeclare(DEC_LOGICAL,"listcremat");
2416           Fprintf(f,indent,"if(.not.listcremat(fname,top,%d,lw,0,%s,%s,lrs,lcs)) return\n",nel,str1,str2);
2417         }
2418       else
2419         {
2420           AddDeclare(DEC_LOGICAL,"cremat");
2421           Fprintf(f,indent,"if(.not.cremat(fname,top,0,%s,%s,lrs,lcs)) return\n",str1,str2);
2422         }
2423       if (barg != 0 &&  var->type != SCALAR)
2424         {
2425           sprintf(str1,"n%d",barg);
2426           sprintf(str2,"m%d",barg);
2427         }
2428       switch (var->for_type)
2429         {
2430         case INT:
2431            Fprintf(f,indent,"call int2db(%s*%s,istk(iadr(%s)),-1,stk(lrs),-1)\n", str1,str2,str);
2432           break;
2433         case DOUBLE:
2434           Fprintf(f,indent,"call dcopy(%s*%s,stk(%s),1,stk(lrs),1)\n", str1,str2,str);
2435           break;
2436         case REAL:
2437           Fprintf(f,indent,"call rea2db(%s*%s,stk(%s),-1,stk(lrs),-1)\n", str1,str2,str);
2438           break;
2439         }
2440       break;
2441     case BMATRIX:
2442       strcpy(str1,Forname2Int(variables[var->el[0]-1]->for_name[0]));
2443       strcpy(str2,Forname2Int(variables[var->el[1]-1]->for_name[0]));
2444       if ( insidelist != 0)
2445         {
2446           AddDeclare(DEC_LOGICAL,"listcrebmat");
2447           Fprintf(f,indent,"if(.not.listcrebmat(fname,top,%d,lw,%s,%s,lrs)) return\n",nel,str1,str2);
2448         }
2449       else
2450         {
2451           AddDeclare(DEC_LOGICAL,"crebmat");
2452           Fprintf(f,indent,"if(.not.crebmat(fname,top,%s,%s,lrs)) return\n",str1,str2);
2453         }
2454       if (barg != 0 &&  var->type != SCALAR)
2455         {
2456           sprintf(str1,"n%d",barg);
2457           sprintf(str2,"m%d",barg);
2458         }
2459       Fprintf(f,indent,"call icopy(%s*%s,istk(%s),1,istk(lrs),1)\n", str1,str2,str);
2460       break;
2461     case SPARSE:
2462       /* Sparse matrix */
2463       strcpy(str1,Forname2Int(variables[var->el[0]-1]->for_name[0]));
2464       strcpy(str2,Forname2Int(variables[var->el[1]-1]->for_name[0]));
2465       strcpy(str3,Forname2Int(variables[var->el[2]-1]->for_name[0]));
2466       strcpy(str4,Forname2Int(variables[var->el[3]-1]->for_name[0]));
2467       if ( insidelist != 0)
2468         {
2469           AddDeclare(DEC_LOGICAL,"listcresparse");
2470           Fprintf(f,indent,"if(.not.listcresparse(fname,top,%d,lw,%s,%s,%s,%s,mnels,icols,lrs,lcs)) return\n"
2471                   ,nel,str4,str1,str2,str3);
2472         }
2473       else
2474         {
2475           AddDeclare(DEC_LOGICAL,"cresparse");
2476           Fprintf(f,indent,"if(.not.cresparse(fname,top,%s,%s,%s,%s,mnels,icols,lrs,lcs)) return\n"
2477                   ,str4,str1,str2,str3);
2478         }
2479       if (barg != 0 &&  var->type != SCALAR)
2480         {
2481           sprintf(str1,"m%d",barg);
2482           sprintf(str2,"n%d",barg);
2483           sprintf(str3,"nel%d",barg);
2484           sprintf(str4,"it%d",barg);
2485         }
2486
2487       Fprintf(f,indent,"call icopy(%s,istk(mnel%s),1,istk(mnels),1)\n",
2488               str1,strR);
2489       Fprintf(f,indent,"call icopy(%s,istk(icol%s),1,istk(icols),1)\n",
2490               str3,strR);
2491       switch (var->for_type)
2492         {
2493         case INT:
2494           Fprintf(f,indent,"call int2db(%s,istk(iadr(%s)),-1,stk(lrs),-1)\n", str3,str);
2495           Fprintf(f,indent++,"if (%s.eq.1) then\n",str4);
2496           Fprintf(f,indent,"call int2db(%s,istk(iadr(%s)),-1,stk(lcs),-1)\n", str3,strc);
2497           Fprintf(f,indent--,"endif\n");
2498           break;
2499         case DOUBLE:
2500           Fprintf(f,indent,"call dcopy(%s,stk(%s),1,stk(lrs),1)\n", str3,str);
2501           Fprintf(f,indent++,"if (%s.eq.1) then\n",str4);
2502           Fprintf(f,indent,"call dcopy(%s,stk(%s),1,stk(lcs),1)\n", str3,strc);
2503           Fprintf(f,indent--,"endif\n");
2504           break;
2505         case REAL:
2506           Fprintf(f,indent,"call rea2db(%s,stk(%s),-1,stk(lrs),-1)\n", str3,str);
2507           Fprintf(f,indent++,"if (%s.eq.1) then\n",str4);
2508           Fprintf(f,indent,"call rea2db(%s,stk(%s),-1,stk(lcs),-1)\n", str3,strc);
2509           Fprintf(f,indent--,"endif\n");
2510           break;
2511         }
2512       break ;
2513     case IMATRIX:
2514       /* Imaginary matrix */
2515       strcpy(str1,Forname2Int(variables[var->el[0]-1]->for_name[0]));
2516       strcpy(str2,Forname2Int(variables[var->el[1]-1]->for_name[0]));
2517       strcpy(str3,Forname2Int(variables[var->el[2]-1]->for_name[0]));
2518       if ( insidelist != 0)
2519         {
2520           AddDeclare(DEC_LOGICAL,"listcremat");
2521           Fprintf(f,indent,"if(.not.listcremat(fname,top,%d,lw,%s,%s,%s,lrs,lcs)) return\n"
2522                   ,nel,str3,str1,str2);
2523         }
2524       else
2525         {
2526           AddDeclare(DEC_LOGICAL,"cremat");
2527           Fprintf(f,indent,"if(.not.cremat(fname,top,%s,%s,%s,lrs,lcs)) return\n",
2528                   str3,str1,str2);
2529         }
2530       if (barg != 0 &&  var->type != SCALAR)
2531         {
2532           sprintf(str1,"m%d",barg);
2533           sprintf(str2,"n%d",barg);
2534           sprintf(str3,"it%d",barg);
2535         }
2536       switch (var->for_type)
2537         {
2538         case INT:
2539           Fprintf(f,indent,"call int2db(%s*%s,istk(iadr(%s)),-1,stk(lrs),-1)\n", str1,str2,str);
2540           Fprintf(f,indent++,"if (%s.eq.1) then\n",str3);
2541           Fprintf(f,indent,"call int2db(%s*%s,istk(iadr(%s)),-1,stk(lcs),-1)\n", str1,str2,strc);
2542           Fprintf(f,indent--,"endif\n");
2543           break;
2544         case DOUBLE:
2545           Fprintf(f,indent,"call dcopy(%s*%s,stk(%s),1,stk(lrs),1)\n", str1,str2,str);
2546           Fprintf(f,indent++,"if (%s.eq.1) then\n",str3);
2547           Fprintf(f,indent,"call dcopy(%s*%s,stk(%s),1,stk(lcs),1)\n", str1,str2,strc);
2548           Fprintf(f,indent--,"endif\n");
2549           break;
2550         case REAL:
2551           Fprintf(f,indent,"call rea2db(%s*%s,stk(%s),-1,stk(lrs),-1)\n", str1,str2,str);
2552           Fprintf(f,indent++,"if (%s.eq.1) then\n",str3);
2553           Fprintf(f,indent,"call rea2db(%s*%s,stk(%s),-1,stk(lcs),-1)\n", str1,str2,strc);
2554           Fprintf(f,indent--,"endif\n");
2555           break;
2556         }
2557       break ;
2558    case POLYNOM:
2559       strcpy(str1,Forname2Int(variables[var->el[0]-1]->for_name[0]));
2560       if ( insidelist != 0)
2561         {
2562           AddDeclare(DEC_LOGICAL,"listcreopoly");
2563           Fprintf(f,indent,"if(.not.listcreopoly(fname,top,%d,lw,0,%s,name%s,namel%s,lrs,lcs)) return\n",nel,str1,str,str);
2564         }
2565       else
2566         {
2567           AddDeclare(DEC_LOGICAL,"creonepoly");
2568           Fprintf(f,indent,"if(.not.creonepoly(fname,top,0,%s,name%s,namel%s,lrs,lcs)) return\n",str1,str,str);
2569         }
2570       switch (var->for_type) {
2571       case INT:
2572         Fprintf(f,indent,"call int2db(%s,stk(%s),-1,stk(lrs),-1)\n",
2573                 str1,str);
2574         break;
2575       case DOUBLE:
2576         Fprintf(f,indent,"call dcopy(%s,stk(%s),1,stk(lrs),1)\n",
2577                 str1,str);
2578         break;
2579       case REAL:
2580         Fprintf(f,indent,"call rea2db(%s,stk(%s),-1,stk(lrs),-1)\n",
2581                 str1,str);
2582         break;
2583       }
2584       break;
2585     case STRING:
2586       strcpy(str1,Forname2Int(variables[var->el[0]-1]->for_name[0]));
2587       if (barg != 0)
2588         {
2589           sprintf(str1,"nlr%d",barg);
2590         }
2591
2592       if ( insidelist != 0)
2593         {
2594           AddDeclare(DEC_LOGICAL,"listcrestring");
2595           Fprintf(f,indent,"if(.not.listcrestring(fname,top,%d,lw,%s,ilrs)) return\n",
2596                   nel,str1);
2597         }
2598       else
2599         {
2600           AddDeclare(DEC_LOGICAL,"cresmat2");
2601           Fprintf(f,indent,"if(.not.cresmat2(fname,top,%s,ilrs)) return\n",str1);
2602         }
2603       Fprintf(f,indent,"call cvstr(%s,istk(ilrs),buf(lbufi%d:lbuff%d),0)\n",
2604               str1,farg,farg);
2605       break;
2606     case SCISMPOINTER:
2607     case SCIMPOINTER:
2608     case SCILPOINTER:
2609     case SCIBPOINTER:
2610     case SCIOPOINTER:
2611       if ( insidelist != 0)
2612         {
2613           printf(" %s in output list : not implemented ;",SGetSciType(var->type));
2614         }
2615       else
2616         {
2617           sprintf(buf,"cre%s", SGetSciType(var->type));
2618           AddDeclare(DEC_LOGICAL,buf);
2619           Fprintf(f,indent,"if(.not.cre%s(fname,top,lrs)) return\n", SGetSciType(var->type));
2620           Fprintf(f,indent,"stk(lrs)=stk(%s)\n",str);
2621         }
2622       break;
2623     case STRINGMAT:
2624       strcpy(str1,Forname2Int(variables[var->el[0]-1]->for_name[0]));
2625       strcpy(str2,Forname2Int(variables[var->el[1]-1]->for_name[0]));
2626       sprintf(str,"lw%d",farg);
2627       if ( insidelist != 0)
2628         {
2629           AddDeclare(DEC_LOGICAL,"lcrestringmatfromC");
2630           Fprintf(f,indent,"if(.not.lcrestringmatfromC(fname,top,%d,lw,%s,%s,%s)) return\n",
2631                   nel,str,str1,str2);
2632         }
2633       else
2634         {
2635           AddDeclare(DEC_LOGICAL,"crestringmatfromC");
2636           Fprintf(f,indent,"if(.not.crestringmatfromC(fname,top,%s,%s,%s)) return\n",
2637                   str,str1,str2);
2638         }
2639       break;
2640     case WORK:
2641     case LIST:
2642     case TLIST:
2643     case SEQUENCE:
2644     case ANY:
2645       printf("output variable \"%s\" cannot have type\n",
2646              var->name);
2647       printf("  \"WORK\", \"LIST\", \"TLIST\", \"SEQUENCE\" or \"ANY\"\n");
2648       exit(1);
2649       break;
2650     }
2651 }
2652
2653 void WriteExternalVariableOutput(f,var,farg,insidelist,nel)
2654      FILE *f;
2655      VARPTR var;
2656      int farg;
2657      int insidelist,nel;
2658 {
2659   char str[MAXNAM];
2660   char str1[MAXNAM];
2661   char str2[MAXNAM];
2662   char str3[MAXNAM];
2663   char str4[MAXNAM];
2664   switch (var->type) {
2665   case COLUMN:
2666   case ROW:
2667   case VECTOR:
2668   case MATRIX:
2669   case SCALAR:
2670     switch ( var->type  )
2671       {
2672       case COLUMN:
2673         strcpy(str2,"1");
2674         strcpy(str1,Forname2Int(variables[var->el[0]-1]->for_name[0]));
2675         break;
2676       case ROW:
2677       case VECTOR:
2678         strcpy(str1,"1");
2679         strcpy(str2,Forname2Int(variables[var->el[0]-1]->for_name[0]));
2680         break;
2681       case MATRIX:
2682         strcpy(str1,Forname2Int(variables[var->el[0]-1]->for_name[0]));
2683         strcpy(str2,Forname2Int(variables[var->el[1]-1]->for_name[0]));
2684         break;
2685       case SCALAR:
2686         strcpy(str1,"1");
2687         strcpy(str2,"1");
2688         break;
2689       }
2690     if ( insidelist != 0)
2691       {
2692         AddDeclare(DEC_LOGICAL,"listcremat");
2693         Fprintf(f,indent,"if(.not.listcremat(fname,top,%d,lw,0,%s,%s,lrs,lcs)) return\n",nel,
2694                 str1,str2);
2695       }
2696     else
2697       {
2698         AddDeclare(DEC_LOGICAL,"cremat");
2699         Fprintf(f,indent,"if(.not.cremat(fname,top,0,%s,%s,lrs,lcs)) return\n",str1,str2);
2700       }
2701     sprintf(str,"lw%d",farg);
2702     Fprintf(f,indent,"call %s(%s*%s,stk(%s),stk(lrs))\n",  var->fexternal,str1,str2,str);
2703     break;
2704   case IMATRIX:
2705     strcpy(str1,Forname2Int(variables[var->el[0]-1]->for_name[0]));
2706     strcpy(str2,Forname2Int(variables[var->el[1]-1]->for_name[0]));
2707     strcpy(str3,Forname2Int(variables[var->el[2]-1]->for_name[0]));
2708     if ( insidelist != 0)
2709       {
2710         AddDeclare(DEC_LOGICAL,"listcremat");
2711         Fprintf(f,indent,"if(.not.listcremat(fname,top,%d,lw,%s,%s,%s,lrs,lcs)) return\n",
2712                 nel,str3,str1,str2);
2713       }
2714     else
2715       {
2716         AddDeclare(DEC_LOGICAL,"cremat");
2717         Fprintf(f,indent,"if(.not.cremat(fname,top,%s,%s,%s,lrs,lcs)) return\n",str3,str1,str2);
2718       }
2719     sprintf(str,"lw%d",farg);
2720     Fprintf(f,indent,"call %s(%s*%s,stk(%s),stk(lrs))\n",  var->fexternal,str1,str2,str);
2721     sprintf(str,"lwc%d",farg);
2722     Fprintf(f,indent++,"if  (%s.eq.1) then\n",str3);
2723     Fprintf(f,indent,"call %s(%s*%s,stk(%s),stk(lcs))\n",  var->fexternal,str1,str2,str);
2724     Fprintf(f,--indent,"endif\n");
2725     break;
2726   case SPARSE:
2727     strcpy(str1,Forname2Int(variables[var->el[0]-1]->for_name[0]));
2728     strcpy(str2,Forname2Int(variables[var->el[1]-1]->for_name[0]));
2729     strcpy(str3,Forname2Int(variables[var->el[2]-1]->for_name[0]));
2730     strcpy(str4,Forname2Int(variables[var->el[3]-1]->for_name[0]));
2731     if ( insidelist != 0)
2732       {
2733         AddDeclare(DEC_LOGICAL,"listcresparse");
2734         Fprintf(f,indent,"if(.not.listcresparse(fname,top,%d,lw,%s,%s,%s,%s,mnels,icols,lrs,lcs)) return\n"
2735                 ,nel,str4,str1,str2,str3);
2736       }
2737     else
2738       {
2739         AddDeclare(DEC_LOGICAL,"cresparse");
2740         Fprintf(f,indent,"if(.not.cresparse(fname,top,%s,%s,%s,%s,mnels,icols,lrs,lcs)) return\n"
2741                 ,str4,str1,str2,str3);
2742       }
2743     sprintf(str,"lw%d",farg);
2744     Fprintf(f,indent,"call %s(stk(%s),istk(mnels),istk(icols),stk(lrs),stk(lcs))\n",var->fexternal,str);
2745     break;
2746   case BMATRIX:
2747     strcpy(str1,Forname2Int(variables[var->el[0]-1]->for_name[0]));
2748     strcpy(str2,Forname2Int(variables[var->el[1]-1]->for_name[0]));
2749     if ( insidelist != 0)
2750       {
2751         AddDeclare(DEC_LOGICAL,"listcrebmat");
2752         Fprintf(f,indent,"if(.not.listcrebmat(fname,top,%d,lw,%s,%s,lrs)) return\n",
2753                 nel,str1,str2);
2754       }
2755     else
2756       {
2757         AddDeclare(DEC_LOGICAL,"crebmat");
2758         Fprintf(f,indent,"if(.not.crebmat(fname,top,%s,%s,lrs)) return\n",str1,str2);
2759       }
2760     sprintf(str,"lw%d",farg);
2761     Fprintf(f,indent,"call %s(%s*%s,istk(%s),istk(lrs))\n",var->fexternal,str1,str2,str);
2762     break;
2763   case POLYNOM:
2764     strcpy(str1,Forname2Int(variables[var->el[0]-1]->for_name[0]));
2765     strcpy(str2,variables[var->el[1]-1]->name);
2766     Fprintf(f,indent,"err=sadr(ilw+10)+%s-lstk(bot)\n",str1);
2767     Fprintf(f,indent,"if(err .gt. 0) then\n");
2768     Fprintf(f,indent,"call error(17)\n");
2769     Fprintf(f,indent,"return\n");
2770     Fprintf(f,indent,"endif\n");
2771     Fprintf(f,indent,"istk(ilw)=1\n");
2772     Fprintf(f,indent,"istk(ilw+1)=1\n");
2773     Fprintf(f,indent,"istk(ilw+2)=1\n");
2774     Fprintf(f,indent,"istk(ilw+3)=0\n");
2775     Fprintf(f,indent,"call cvstr(4,'%s    ',istk(ilw+4),0)\n",str2);
2776     /* str2 comes from SCILAB input ??? */
2777     Fprintf(f,indent,"istk(ilw+8)=1\n");
2778     Fprintf(f,indent,"istk(ilw+9)=1+%s\n",str1);
2779     sprintf(str,"lw%d",farg);
2780     Fprintf(f,indent,"lw=sadr(ilw+10)\n");
2781     Fprintf(f,indent,"call %s(%s,stk(%s),stk(lw))\n",
2782             var->fexternal,str1,str);
2783     Fprintf(f,indent,"lw=lw+%s\n",str1);
2784     break;
2785   case STRING:
2786     strcpy(str1,Forname2Int(variables[var->el[0]-1]->for_name[0]));
2787     if ( insidelist != 0)
2788       {
2789         AddDeclare(DEC_LOGICAL,"listcrestring");
2790         Fprintf(f,indent,"if(.not.listcrestring(fname,top,%d,lw,%s,ilrs)) return\n",nel,str1,str2);
2791       }
2792     else
2793       {
2794         AddDeclare(DEC_LOGICAL,"crestring");
2795         Fprintf(f,indent,"if(.not.crestring(fname,top,%s,ilrs)) return\n",str1);
2796       }
2797     sprintf(str,"lw%d",farg);
2798     Fprintf(f,indent,"call %s(%s,stk(%s),istk(ilrs))\n", var->fexternal,str1,str);
2799     break;
2800   case STRINGMAT:
2801     strcpy(str1,Forname2Int(variables[var->el[0]-1]->for_name[0]));
2802     strcpy(str2,Forname2Int(variables[var->el[1]-1]->for_name[0]));
2803     sprintf(str,"lw%d",farg);
2804     Fprintf(f,indent,"call %s(stk(%s),istk(ilw),%s,%s,lstk(bot)-sadr(ilw),ierr)\n",
2805             var->fexternal,str,str1,str2);
2806     Fprintf(f,indent,"if(ierr .gt. 0) then\n");
2807     Fprintf(f,indent,"buf='not enough memory'\n");
2808     Fprintf(f,indent,"call error(1000)\n");
2809     Fprintf(f,indent,"return\n");
2810     Fprintf(f,indent,"endif\n");
2811     sprintf(str,"istk(ilw+4+%s*%s)-1",str1,str2);
2812     Fprintf(f,indent,"lw=sadr(ilw+5+%s*%s+%s)\n",str1,str2,str);
2813     break;
2814   }
2815 }
2816
2817 void WriteListAnalysis(f,i)
2818      /* is nearly a copy of WriteArgCheck */
2819      FILE *f;
2820      int i;
2821 {
2822   int k,i1,iel;
2823   char str1[MAXNAM],str[MAXNAM];
2824   VARPTR var;
2825   i1=i+1;
2826   AddDeclare(DEC_LOGICAL,"getilist");
2827   Fprintf(f,indent,"if(.not.getilist(fname,topk,top-rhs+%d,n%d,1,il%d)) return\n",i1,i1,i1);
2828   for (k = 0; k < nVariable ; k++)
2829     {
2830       var = variables[k];
2831       if ((var->list_el != 0) &&
2832           (strcmp(var->list_name,variables[i]->name) == 0) &&
2833           var->present)
2834         {
2835           iel=var->list_el;
2836           FCprintf(f,"c     \n");
2837           FCprintf(f,"c       --   list element number %d %s --\n",iel,var->name);
2838           sprintf(str1,"%de%d",i1,iel);
2839           AddDeclare(DEC_LOGICAL,"getilist");
2840           switch (var->type)
2841             {
2842             case SPARSE:
2843               AddDeclare(DEC_LOGICAL,"getlistsparse");
2844               Fprintf(f,indent,"if(.not.getlistsparse(fname,topk,top-rhs+%d,%d,it%s,m%s,n%s,nel%s,mnel%s,icol%s,lr%s,lc%s)) return\n",
2845                       i1,iel,str1,str1,str1,str1,str1,str1,str1,str1);
2846               if (var->el[0] == var->el[1]) {
2847                 /* square matrix */
2848                 AddDeclare(DEC_LOGICAL,"checkval");
2849                 Fprintf(f,indent,"if(.not.checkval(fname,m%s,n%s)) return\n",str1,str1);
2850               }
2851               sprintf(str,"m%s",str1);
2852               AddForName1(var->el[0],str);
2853               sprintf(str,"n%s",str1);
2854               AddForName1(var->el[1],str);
2855               sprintf(str,"nel%s",str1);
2856               AddForName1(var->el[2],str);
2857               sprintf(str,"it%s",str1);
2858               AddForName1(var->el[3],str);
2859               break;
2860             case IMATRIX:
2861               AddDeclare(DEC_LOGICAL,"getlistmat");
2862               Fprintf(f,indent,"if(.not.getlistmat(fname,topk,top-rhs+%d,%d,it%s,m%s,n%s,lr%s,lc%s)) return\n",
2863                       i1,iel,str1,str1,str1,str1,str1);
2864               if (var->el[0] == var->el[1]) {
2865                 /* square matrix */
2866                 AddDeclare(DEC_LOGICAL,"checkval");
2867                 Fprintf(f,indent,"if(.not.checkval(fname,m%s,n%s)) return\n",str1,str1);
2868               }
2869               sprintf(str,"m%s",str1);
2870               AddForName1(var->el[0],str);
2871               sprintf(str,"n%s",str1);
2872               AddForName1(var->el[1],str);
2873               sprintf(str,"it%s",str1);
2874               AddForName1(var->el[2],str);
2875               break;
2876             case MATRIX:
2877               AddDeclare(DEC_LOGICAL,"getlistmat");
2878               Fprintf(f,indent,"if(.not.getlistmat(fname,topk,top-rhs+%d,%d,it%s,m%s,n%s,lr%s,lc%s)) return\n",
2879                       i1,iel,str1,str1,str1,str1,str1);
2880               if (var->el[0] == var->el[1]) {
2881                 /* square matrix */
2882                 AddDeclare(DEC_LOGICAL,"checkval");
2883                 Fprintf(f,indent,"if(.not.checkval(fname,m%s,n%s)) return\n",str1,str1);
2884               }
2885               sprintf(str,"m%s",str1);
2886               AddForName1(var->el[0],str);
2887               sprintf(str,"n%s",str1);
2888               AddForName1(var->el[1],str);
2889               break;
2890             case BMATRIX:
2891               AddDeclare(DEC_LOGICAL,"getlistbmat");
2892               Fprintf(f,indent,"if(.not.getlistbmat(fname,topk,top-rhs+%d,%d,m%s,n%s,lr%s)) return\n",
2893                       i1,iel,str1,str1,str1,str1,str1);
2894               if (var->el[0] == var->el[1]) {
2895                 /* square matrix */
2896                 AddDeclare(DEC_LOGICAL,"checkval");
2897                 Fprintf(f,indent,"if(.not.checkval(fname,m%s,n%s)) return\n",str1,str1);
2898               }
2899               sprintf(str,"m%s",str1);
2900               AddForName1(var->el[0],str);
2901               sprintf(str,"n%s",str1);
2902               AddForName1(var->el[1],str);
2903               break;
2904             case STRINGMAT:
2905               AddDeclare(DEC_LOGICAL,"getlistsimat");
2906               Fprintf(f,indent,"if(.not.getlistsimat(fname,topk,top-rhs+%d,%d,m%s,n%s,1,1,lr%s,nlr%s)) return\n",
2907                       i1,iel,str1,str1,str1,str1);
2908               /* square matrix */
2909               if (var->el[0] == var->el[1]) {
2910                 /* square matrix */
2911                 AddDeclare(DEC_LOGICAL,"checkval");
2912                 Fprintf(f,indent,"if(.not.checkval(fname,m%s,n%s)) return\n",str1,str1);
2913               }
2914               sprintf(str,"m%s",str1);
2915               AddForName1(var->el[0],str);
2916               sprintf(str,"n%s",str1);
2917               AddForName1(var->el[1],str);
2918               break;
2919             case ROW:
2920               AddDeclare(DEC_LOGICAL,"getlistvectrow");
2921               Fprintf(f,indent,"if(.not.getlistvectrow(fname,topk,top-rhs+%d,%d,it%s,m%s,n%s,lr%s,lc%s)) return\n",
2922                       i1,iel,str1,str1,str1,str1,str1);
2923               sprintf(str,"n%s",str1);
2924               AddForName1(var->el[0],str);
2925               break;
2926             case COLUMN :
2927               AddDeclare(DEC_LOGICAL,"getlistvectcol");
2928               Fprintf(f,indent,"if(.not.getlistvectcol(fname,topk,top-rhs+%d,%d,it%s,m%s,n%s,lr%s,lc%s)) return\n",
2929                       i1,iel,str1,str1,str1,str1,str1);
2930               sprintf(str,"n%s",str1);
2931               AddForName1(var->el[0],str);
2932               break;
2933             case VECTOR:
2934               AddDeclare(DEC_LOGICAL,"getlistvect");
2935               Fprintf(f,indent,"if(.not.getlistvect(fname,top,top-rhs+%d,%d,it%s,m%s,n%s,lr%s,lc%s)) return\n",
2936                       i1,iel,str1,str1,str1,str1,str1);
2937               sprintf(str,"n%s*m%s",str1,str1);
2938               AddForName1(var->el[0],str);
2939               break;
2940             case POLYNOM:
2941               AddDeclare(DEC_LOGICAL,"getlistpoly");
2942               Fprintf(f,indent,"if(.not.getlistpoly(fname,topk,top-rhs+%d,%d,it%s,m%s,n%s,name%s,\n",
2943                       i1,iel,str1,str1,str1,str1);
2944               Fprintf(f,indent,"$     namel%s,ilp%s,lr%s,lc%s)\n",str1,str1,str1,str1);
2945               AddDeclare(DEC_LOGICAL,"checkval");
2946               Fprintf(f,indent,"if(.not.checkval(fname,m%s,n%s)) return\n",str1,str1);
2947               break;
2948             case SCALAR:
2949               AddDeclare(DEC_LOGICAL,"getlistscalar");
2950               Fprintf(f,indent,"if(.not.getlistscalar(fname,topk,top-rhs+%d,%d,lr%s)) return\n",i1,iel,str1);
2951               break;
2952             case STRING:
2953               AddDeclare(DEC_LOGICAL,"getlistsmat");
2954               Fprintf(f,indent,"if(.not.getlistsmat(fname,topk,top-rhs+%d,%d,m%s,n%s,1,1,lr%s,nlr%s)) return\n",
2955                       i1,iel,str1,str1,str1,str1);
2956               AddDeclare(DEC_LOGICAL,"checkval");
2957               Fprintf(f,indent,"if(.not.checkval(fname,m%s*n%s,1)) return\n",str1,str1);
2958               sprintf(str,"n%s",str1);
2959               strcpy(str1,variables[var->el[0]-1]->name);
2960               AddForName1(var->el[0],str);
2961               break;
2962             case ANY:
2963               break;
2964             }
2965         }
2966     }
2967 }
2968
2969 /***********************************************
2970  * Output of variable var
2971  *   if variable is outputed inside a list
2972  *   insidelist is set to true and nel is the number
2973  *   of the variable in the list
2974  ***********************************************/
2975
2976 void WriteVariable(f,var,ivar,insidelist,nel)
2977      FILE *f;
2978      VARPTR var;
2979      IVAR ivar;
2980      int insidelist;
2981 {
2982   IVAR ivar2, barg, farg;
2983   VARPTR var2;
2984   int j;
2985
2986   /* get number of variable in SCILAB calling list */
2987
2988   barg = GetNumberInScilabCall(ivar);
2989
2990   /* get number of variable in FORTRAN calling list */
2991
2992   farg = GetNumberInFortranCall(ivar);
2993
2994   if (var->for_type == EXTERNAL)
2995     {
2996       /* external type */
2997       if (barg != 0)
2998         {
2999           printf("output variable with external type \"%s\"\n",var->name);
3000           printf("  cannot be an input argument of SCILAB function\n");
3001           exit(1);
3002         }
3003       if (var->equal != 0)
3004         {
3005           printf("output variable with external type \"%s\"\n", var->name);
3006           printf("  cannot have a convertion\n");
3007           exit(1);
3008         }
3009     if (farg == 0)
3010       {
3011         printf("output variable with external type \"%s\" must be\n", var->name);
3012         printf("  an argument of FORTRAN subroutine");
3013         exit(1);
3014       }
3015       WriteExternalVariableOutput(f,var,farg,insidelist,nel);
3016     }
3017   else
3018     {
3019       if (var->equal != 0)
3020         {
3021           /* SCILAB type convertion */
3022           if (barg !=0 || farg!= 0)
3023             {
3024               printf("output variable with convertion \"%s\" must not be\n",var->name);
3025               printf("  an input variable of SCILAB function or an argument\n");
3026               printf("  of FORTRAN subroutine\n");
3027               exit(1);
3028             }
3029           ivar2 = var->equal;
3030           var2 = variables[ivar2-1];
3031           /* get number of equal variable in SCILAB calling list */
3032           barg = 0;
3033           for (j = 0; j < basfun->nin; j++)
3034             {
3035               if (ivar2 == basfun->in[j])
3036                 {
3037                   barg = j + 1;
3038                   break;
3039                 }
3040             }
3041           if (barg == 0)
3042             {
3043               printf("output variable with convertion \"%s\" must be\n",
3044                      var->name);
3045               printf("  an input variable of SCILAB function\n");
3046               exit(1);
3047             }
3048           /* get number of equal variable in FORTRAN calling list */
3049           farg = 0;
3050           for (j = 0; j < forsub->narg; j++) {
3051             if (ivar2 == forsub->arg[j]) {
3052               farg = j + 1;
3053               break;
3054             }
3055           }
3056           if (farg == 0)
3057             {
3058               printf("output variable with convertion \"%s\" must be\n",
3059                      var->name);
3060               printf("  an argument FORTRAN subroutine");
3061               exit(1);
3062             }
3063           var->for_type = var2->for_type;
3064           WriteVariableOutput(f,var,barg,farg,1,insidelist,nel);
3065         }
3066       else
3067         {
3068           /* no SCILAB type convertion */
3069           if (farg == 0) {
3070             printf("variable without convertion \"%s\" must be an argument\n",
3071                    var->name);
3072             printf("  of FORTRAN subroutine\n");
3073             exit(1);
3074           }
3075           WriteVariableOutput(f,var,barg,farg,0,insidelist,nel);
3076         }
3077     }
3078 }
3079
3080
3081 int GetNumberInScilabCall(ivar)
3082      int ivar;
3083 {
3084   int j;
3085   for (j = 0; j < basfun->nin; j++)
3086     {
3087       if (ivar == basfun->in[j]) {
3088         return(j+1);
3089         break;
3090       }
3091     }
3092   return(0);
3093 }
3094
3095 int GetNumberInFortranCall(ivar)
3096           int ivar;
3097 {
3098   int j;
3099   for (j = 0; j < forsub->narg; j++)
3100     {
3101       if (ivar == forsub->arg[j])
3102         {
3103           return( j + 1);
3104           break;
3105         }
3106     }
3107   return(0);
3108 }
3109
3110 char unknown[]="ukn";
3111
3112 char *Forname2Int(str)
3113      char *str;
3114 {
3115   int l;
3116   char *p;
3117   if (str == (char *) 0)
3118     {
3119       printf("Error in Forname2Int \n");
3120       printf("Maybe an internal variable has a dimension\n");
3121       printf("which can't be evaluated\n");
3122       abort();
3123       return(unknown);
3124     }
3125   if (strncmp(str,"stk",3) == 0) {
3126     l = (int)strlen(str);
3127     p = (char *)malloc((unsigned)(l + 6));
3128     sprintf(p,"int(%s)",str);
3129     return p;
3130   }
3131   else return str;
3132 }
3133
3134
3135
3136 void GenFundef(file,interf)
3137      char *file;
3138      int interf;
3139 {
3140   FILE *fout;
3141   char filout[MAXNAM];
3142   int i,j;
3143   if (interf != 0 )
3144     {
3145       strcpy(filout,file);
3146       strcat(filout,".fundef");
3147       fout = fopen(filout,"w");
3148       fprintf(fout,"#define IN_%s %.2d\n",file,interf);
3149       for (i = 0; i < nFun; i++) {
3150         fprintf(fout,"{\"%s\",",funNames[i]);
3151         for (j = 0; j < 25 - (int)strlen(funNames[i]); j++) fprintf(fout," ");
3152         fprintf(fout,"\t\tIN_%s,\t%d,\t3},\n",file,i+1);
3153       }
3154       printf("\nfile \"%s\" has been created\n",filout);
3155       fclose(fout);
3156     }
3157 }
3158
3159 /**********************************************************
3160   Function to add decaration during the first pass
3161   and to print them during code generation pass 2
3162 **********************************************************/
3163
3164
3165 static struct Declare {
3166   int type;
3167   char *name;
3168   char **decls ; /* declaration de logical */
3169   int  ndecls;
3170 } Init[] = {
3171   { DEC_CHAR,"char",(char **) 0,0},
3172   { DEC_INT ,"integer",(char **) 0,0},
3173   { DEC_DOUBLE,"double precision",(char **) 0,0},
3174   { DEC_REAL,"real",(char **) 0,0},
3175   { DEC_LOGICAL,"logical",(char **) 0,0},
3176   { DEC_DATA,"data",(char **) 0,0},
3177   { -1 ,"void",(char **) 0,0}
3178   };
3179
3180 void InitDeclare()
3181 {
3182   int i = 0;
3183   while ( Init[i].type != -1)
3184     {
3185       Init[i].decls = (char **) 0;
3186       Init[i].ndecls =0 ;
3187       i++;
3188     }
3189 }
3190
3191 void ResetDeclare()
3192 {
3193   int j = 0;
3194   while ( Init[j].type != -1)
3195     {
3196       if ( Init[j].decls != (char **) 0)
3197         {
3198           int i;
3199           for ( i = 0 ; i < Init[j].ndecls ; i++ )
3200             free((char *) Init[j].decls[i]);
3201           free (( char *) Init[j].decls );
3202         }
3203       Init[j].decls=(char **) 0;
3204       Init[j].ndecls=0;
3205       j++;
3206     }
3207 }
3208
3209 int  CheckDeclare(type,declaration)
3210      int type;
3211      char *declaration;
3212 {
3213   int j = 0;
3214   while ( Init[j].type != -1)
3215     {
3216       if ( Init[j].type == type )
3217         {
3218           int i;
3219           for ( i = 0 ; i < Init[j].ndecls ; i++ )
3220             {
3221               if ( strcmp(declaration,Init[j].decls[i])==0)
3222                 return(1);
3223             }
3224           return(0);
3225         }
3226       j++;
3227     }
3228   return(0);
3229 }
3230
3231 void AddDeclare(type,declaration)
3232      int type;
3233      char *declaration;
3234 {
3235   int j = 0;
3236   if ( CheckDeclare(type,declaration)== 1) return ;
3237   while ( Init[j].type != -1)
3238     {
3239       if ( Init[j].type == type )
3240         {
3241           if ( Init[j].decls != (char **) 0)
3242             {
3243               (Init[j].ndecls)++;
3244               Init[j].decls =  (char **) realloc((char *) Init[j].decls, (unsigned) (Init[j].ndecls ) *sizeof(char *));
3245             }
3246           else
3247             {
3248               (Init[j].ndecls)++;
3249               Init[j].decls = (char **) malloc ( (unsigned) (Init[j].ndecls ) *sizeof(char *));
3250             }
3251           if ( Init[j].decls == ( char **) 0)
3252             {
3253               fprintf(stderr,"No more space\n");
3254               exit(1);
3255             }
3256           Init[j].decls[Init[j].ndecls-1]=(char*) malloc((unsigned) (strlen(declaration)+1)*sizeof(char));
3257           if (    Init[j].decls[Init[j].ndecls-1] == ( char *) 0)
3258             {
3259               fprintf(stderr,"No more space\n");
3260               exit(1);
3261             }
3262           strcpy(   Init[j].decls[Init[j].ndecls-1], declaration );
3263         }
3264       j++;
3265     }
3266 }
3267
3268 void WriteDeclaration(f)
3269      FILE *f;
3270 {
3271   int j = 0;
3272   int i;
3273   while ( Init[j].type != -1)
3274     {
3275       if ( Init[j].ndecls != 0)
3276         Fprintf(f,indent,"%s ",Init[j].name);
3277       for (i= 0 ; i < Init[j].ndecls ; i++)
3278         {
3279           Fprintf(f,indent,"%s",Init[j].decls[i]);
3280           if ( i != Init[j].ndecls -1 ) Fprintf(f,indent,",");
3281           else Fprintf(f,indent,"\n");
3282         }
3283       j++;
3284     }
3285 }
3286
3287 /**********************************************************
3288   Dealing With Fortran OutPut
3289   taking into account indentation and line breaks after column 72
3290 ***********************************************************/
3291 #include <stdarg.h>
3292
3293 #define MAXBUF 4096
3294 char sbuf[MAXBUF];
3295
3296 void Fprintf(FILE *f,int indent,char *format,...)
3297 {
3298   int i;
3299   static int count=0;
3300   va_list ap;
3301   va_start(ap,format);
3302
3303   vsprintf(sbuf,format,ap);
3304   for ( i = 0 ; i < (int) strlen(sbuf); i++)
3305     {
3306       if ( count == 0)
3307         {
3308           white(f,7+indent);
3309           count = 7+indent;
3310         }
3311       if ( count == 72 && sbuf[i] != '\n' ) { fprintf(f,"\n     $ ");count=7;}
3312       if ( sbuf[i] == '\n') count = -1 ;
3313       fprintf(f,"%c",sbuf[i]);
3314       count++;
3315     }
3316   va_end(ap);
3317 }
3318
3319 void white(f,ind)
3320      FILE *f;
3321      int ind;
3322 {
3323   int i ;
3324   for (i =0 ; i < ind ; i++) fprintf(f," ");
3325 }
3326
3327
3328
3329 void  FCprintf(FILE *f,char *format,...)
3330 {
3331   va_list ap;
3332   va_start(ap,format);
3333
3334   vfprintf(f,format,ap);
3335   va_end(ap);
3336 }
3337
3338
3339
3340 /********************************
3341  * Set up environment variables if
3342  * necessary for SCIDIR
3343  ********************************/
3344
3345 #ifdef _MSC_VER
3346 static void SciEnv ()
3347 {
3348   char *p,*p1;
3349   char modname[PATH_MAX+1];
3350   char env[PATH_MAX+1+10];
3351   if (!GetModuleFileName (NULL, modname+1, PATH_MAX))
3352     return;
3353   if ((p = strrchr (modname+1, '\\')) == NULL)
3354     return;
3355   *p = 0;
3356
3357   /* Set SCI variable */
3358   if ((p = strrchr (modname+1, '\\')))
3359     {
3360       *p = 0;
3361       for (p = modname+1; *p; p++)
3362         {
3363           if (*p == '\\') *p = '/';
3364         }
3365     p = modname + 1;
3366
3367       if ( ( p1 = getenv("SCI"))  == (char *) 0 )
3368         {
3369           sprintf(env,"SCI=%s",p);
3370           putenv(env);
3371         }
3372     }
3373 }
3374 #endif /** _MSC_VER **/