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