summaryrefslogtreecommitdiffstats
path: root/scilab/modules/intersci
diff options
context:
space:
mode:
authorPierre MARECHAL <pierre.marechal@scilab.org>2010-08-16 11:55:55 +0200
committerPierre MARECHAL <pierre.marechal@scilab.org>2010-08-16 13:30:28 +0200
commitbfff64868ca4e62326592f1e6459eec14694ec65 (patch)
tree7760cf65a095912a74c5d0ed157b38a71b82ad0d /scilab/modules/intersci
parent92bb939754196dc29dd492733c900a074b185f2e (diff)
downloadscilab-bfff64868ca4e62326592f1e6459eec14694ec65.zip
scilab-bfff64868ca4e62326592f1e6459eec14694ec65.tar.gz
* bug 7599 fixed - Intersci-n and intersci did not create code from a .desc file if it was not ended by a empty line.
Change-Id: I7c9304dcca1f27591dda1cd6e105a1df1ee5e48c
Diffstat (limited to 'scilab/modules/intersci')
-rw-r--r--scilab/modules/intersci/src/exe/intersci.c5581
-rw-r--r--scilab/modules/intersci/src/exe/read.c25
-rw-r--r--scilab/modules/intersci/tests/nonreg_tests/bug_7599.c25
-rw-r--r--scilab/modules/intersci/tests/nonreg_tests/bug_7599.desc13
-rw-r--r--scilab/modules/intersci/tests/nonreg_tests/bug_7599.dia.ref26
-rw-r--r--scilab/modules/intersci/tests/nonreg_tests/bug_7599.tst27
6 files changed, 2909 insertions, 2788 deletions
diff --git a/scilab/modules/intersci/src/exe/intersci.c b/scilab/modules/intersci/src/exe/intersci.c
index 52966c9..5aa1c5b 100644
--- a/scilab/modules/intersci/src/exe/intersci.c
+++ b/scilab/modules/intersci/src/exe/intersci.c
@@ -1,14 +1,14 @@
1/* 1/*
2 * Scilab ( http://www.scilab.org/ ) - This file is part of Scilab 2* Scilab ( http://www.scilab.org/ ) - This file is part of Scilab
3 * Copyright (C) ????-2008 - INRIA 3* Copyright (C) ????-2008 - INRIA
4 * 4*
5 * This file must be used under the terms of the CeCILL. 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 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 7* you should have received as part of this distribution. The terms
8 * are also available at 8* are also available at
9 * http://www.cecill.info/licences/Licence_CeCILL_V2-en.txt 9* http://www.cecill.info/licences/Licence_CeCILL_V2-en.txt
10 * 10*
11 */ 11*/
12 12
13 13
14#ifdef _MSC_VER 14#ifdef _MSC_VER
@@ -34,131 +34,131 @@ static void SciEnv ();
34#endif 34#endif
35 35
36int main(argc,argv) 36int main(argc,argv)
37 unsigned int argc; 37unsigned int argc;
38 char **argv; 38char **argv;
39{ 39{
40 int InterFace = 0 ; 40 int InterFace = 0 ;
41#ifdef _MSC_VER 41#ifdef _MSC_VER
42 SciEnv(); 42 SciEnv();
43#endif 43#endif
44 switch (argc) { 44 switch (argc) {
45 case 2: 45 case 2:
46 InterFace = 0; break; 46 InterFace = 0; break;
47 case 3: 47 case 3:
48 InterFace = atoi(argv[2]);break; 48 InterFace = atoi(argv[2]);break;
49 default: 49 default:
50 printf("usage: intersci <interface file> <interface number>\n"); 50 printf("usage: intersci <interface file> <interface number>\n");
51 exit(1); 51 exit(1);
52 break; 52 break;
53 } 53 }
54 basfun = BasfunAlloc(); 54 basfun = BasfunAlloc();
55 if (basfun == 0) { 55 if (basfun == 0) {
56 printf("Running out of memory\n"); 56 printf("Running out of memory\n");
57 exit(1); 57 exit(1);
58 } 58 }
59 forsub = ForsubAlloc(); 59 forsub = ForsubAlloc();
60 if (forsub == 0) { 60 if (forsub == 0) {
61 printf("Running out of memory\n"); 61 printf("Running out of memory\n");
62 exit(1); 62 exit(1);
63 } 63 }
64 ISCIReadFile(argv[1]); 64 ISCIReadFile(argv[1]);
65 GenFundef(argv[1],InterFace); 65 GenFundef(argv[1],InterFace);
66 return 0; 66 return 0;
67} 67}
68 68
69void ISCIReadFile(file) 69void ISCIReadFile(file)
70 char *file; 70char *file;
71{ 71{
72 FILE *fin, *fout, *foutv; 72 FILE *fin, *fout, *foutv;
73 char filout[MAXNAM]; 73 char filout[MAXNAM];
74 char filin[MAXNAM]; 74 char filin[MAXNAM];
75 sprintf(filin,"%s.desc",file); 75 sprintf(filin,"%s.desc",file);
76 fin = fopen(filin,"r"); 76 fin = fopen(filin,"r");
77 if (fin == 0) { 77 if (fin == 0) {
78 printf("Interface file \"%s\" does not exist\n",filin); 78 printf("Interface file \"%s\" does not exist\n",filin);
79 exit(1); 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 } 80 }
96 ResetDeclare(); 81 Copyright();
97 /* first pass to collect declarations */ 82 strcpy(filout,file);
98 pass=0; 83 strcat(filout,".f");
99 WriteFunctionCode(foutv); 84 fout = fopen(filout,"w");
100 /* cleaning added Fornames before pass 2 */ 85 strcpy(filout,file);
101 ForNameClean(); 86 strcat(filout,".tmp");
102 /* scond pass to produce code */ 87 foutv = fopen(filout,"w");
103 pass=1; 88 InitDeclare();
104 WriteFunctionCode(fout); 89 nFun = 0;
105 /** WriteInfoCode(fout); **/ 90 while(ReadFunction(fin)) {
106 } 91 nFun++;
107 WriteMain(fout,file); 92 if (nFun > MAXFUN) {
108 printf("FORTRAN file \"%s.f\" has been created\n",file); 93 printf("Too many SCILAB functions. The maximum is %d\n",MAXFUN);
109 WriteAddInter(file) ; 94 exit(1);
110 printf("Scilab file \"%s.sce\" has been created\n",file); 95 }
111 fclose(fout); 96 ResetDeclare();
112 fclose(fin); 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} 113}
114 114
115void WriteMain(f,file) 115void WriteMain(f,file)
116 FILE *f; 116FILE *f;
117 char* file; 117char* file;
118{ 118{
119 int i; 119 int i;
120 FCprintf(f,"\nc interface function\n"); 120 FCprintf(f,"\nc interface function\n");
121 FCprintf(f,"c ********************\n"); 121 FCprintf(f,"c ********************\n");
122 WriteMainHeader(f,file); 122 WriteMainHeader(f,file);
123 Fprintf(f,indent,"goto ("); 123 Fprintf(f,indent,"goto (");
124 for (i = 1; i < nFun ; i++) { 124 for (i = 1; i < nFun ; i++) {
125 Fprintf(f,indent,"%d,",i); 125 Fprintf(f,indent,"%d,",i);
126 } 126 }
127 Fprintf(f,indent,"%d) fin\nreturn\n",nFun); 127 Fprintf(f,indent,"%d) fin\nreturn\n",nFun);
128 for (i = 0; i < nFun; i++) { 128 for (i = 0; i < nFun; i++) {
129 FCprintf(f,"%d call ints%s('%s')\n",i+1,funNames[i],funNames[i]); 129 FCprintf(f,"%d call ints%s('%s')\n",i+1,funNames[i],funNames[i]);
130 Fprintf(f,indent,"return\n"); 130 Fprintf(f,indent,"return\n");
131 } 131 }
132 Fprintf(f,indent,"end\n"); 132 Fprintf(f,indent,"end\n");
133} 133}
134 134
135void WriteAddInter(file) 135void WriteAddInter(file)
136 char *file; 136char *file;
137{ 137{
138 FILE *fout; 138 FILE *fout;
139 int i; 139 int i;
140 char filout[MAXNAM]; 140 char filout[MAXNAM];
141 strcpy(filout,file); 141 strcpy(filout,file);
142 strcat(filout,".sce"); 142 strcat(filout,".sce");
143 fout = fopen(filout,"w"); 143 fout = fopen(filout,"w");
144 if ( fout != (FILE*) 0) 144 if ( fout != (FILE*) 0)
145 { 145 {
146 fprintf(fout,"// Addinter for file %s\n",file); 146 fprintf(fout,"// Addinter for file %s\n",file);
147 fprintf(fout,"// for hppa/sun-solaris/linux/dec\n"); 147 fprintf(fout,"// for hppa/sun-solaris/linux/dec\n");
148 fprintf(fout,"//--------------------------------\n"); 148 fprintf(fout,"//--------------------------------\n");
149 fprintf(fout,"//Scilab functions\n"); 149 fprintf(fout,"//Scilab functions\n");
150 fprintf(fout,"%s_funs=[...\n",file); 150 fprintf(fout,"%s_funs=[...\n",file);
151 for (i = 0; i < nFun -1; i++) 151 for (i = 0; i < nFun -1; i++)
152 fprintf(fout," '%s';\n",funNames[i]); 152 fprintf(fout," '%s';\n",funNames[i]);
153 fprintf(fout," '%s']\n",funNames[nFun-1]); 153 fprintf(fout," '%s']\n",funNames[nFun-1]);
154 fprintf(fout,"// interface file to link: ifile='%s.o'\n",file); 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"); 155 fprintf(fout,"// user's files to link: ufiles=['file1.o','file2.o',....]\n");
156 fprintf(fout,"// files = [ifile,ufiles]\n"); 156 fprintf(fout,"// files = [ifile,ufiles]\n");
157 fprintf(fout,"addinter(files,'%s',%s_funs);\n",file,file); 157 fprintf(fout,"addinter(files,'%s',%s_funs);\n",file,file);
158 fclose(fout); 158 fclose(fout);
159 } 159 }
160 else 160 else
161 fprintf(stderr,"Can't open file %s\n",file); 161 fprintf(stderr,"Can't open file %s\n",file);
162} 162}
163 163
164 164
@@ -166,1590 +166,1605 @@ void WriteAddInter(file)
166 166
167void Copyright() 167void Copyright()
168{ 168{
169 printf("\nINTERSCI Version %s (%s)\n",VERSION,DATE); 169 printf("\nINTERSCI Version %s (%s)\n",VERSION,DATE);
170 printf(" Copyright (C) INRIA All rights reserved\n\n"); 170 printf(" Copyright (C) INRIA All rights reserved\n\n");
171} 171}
172 172
173/********************************************************** 173/**********************************************************
174 *Reading the intersci description file 174*Reading the intersci description file
175 **********************************************************/ 175**********************************************************/
176 176
177int ReadFunction(f) 177int ReadFunction(f)
178 FILE *f; 178FILE *f;
179{ 179{
180 int i, j, l, type, ftype; 180 int i, j, l, type, ftype;
181 char s[MAXLINE]; 181 char s[MAXLINE];
182 char str[MAXNAM]; 182 char str[MAXNAM];
183 char *words[MAXLINE]; 183 char *words[MAXLINE];
184 char *optwords[MAXLINE]; 184 char *optwords[MAXLINE];
185 IVAR ivar; 185 IVAR ivar;
186 int nwords, line1, inbas, fline1, infor, nopt, out1; 186 int nwords, line1, inbas, fline1, infor, nopt, out1;
187 187
188 nVariable = 0; 188 nVariable = 0;
189 maxOpt = 0; 189 maxOpt = 0;
190 line1 = 1; 190 line1 = 1;
191 inbas = 0; 191 inbas = 0;
192 fline1 = 0; 192 fline1 = 0;
193 infor = 0; 193 infor = 0;
194 out1 = 0; 194 out1 = 0;
195 while (fgets(s,MAXLINE,f)) 195 while (fgets(s,MAXLINE,f))
196 { 196 {
197 /* analysis of one line */ 197 /* analysis of one line */
198 if (line1 != 1) nwords = ParseLine(s,words); 198 if (line1 != 1) nwords = ParseLine(s,words);
199 else nwords = ParseScilabLine(s,words); 199 else nwords = ParseScilabLine(s,words);
200 /* end of description */ 200 /* end of description */
201 if (words[0][0] == '*') return(1); 201 if (words[0][0] == '*') return(1);
202 if (line1 == 1) 202 if (line1 == 1)
203 { 203 {
204 /* SCILAB function description */ 204 /* SCILAB function description */
205 if ((int)strlen(words[0]) > nlgh) 205 if ((int)strlen(words[0]) > nlgh)
206 { 206 {
207 printf("SCILAB function name too long: \"%s\"\n",words[0]); 207 printf("SCILAB function name too long: \"%s\"\n",words[0]);
208 exit(1); 208 exit(1);
209 } 209 }
210 basfun->name = (char *)malloc((unsigned)(strlen(words[0])+1)); 210 basfun->name = (char *)malloc((unsigned)(strlen(words[0])+1));
211 strcpy(basfun->name,words[0]); 211 strcpy(basfun->name,words[0]);
212 printf("**************************\n"); 212 printf("**************************\n");
213 printf("processing SCILAB function \"%s\"\n",words[0]); 213 printf("processing SCILAB function \"%s\"\n",words[0]);
214 funNames[nFun] = basfun->name; 214 funNames[nFun] = basfun->name;
215 i = nwords - 1; 215 i = nwords - 1;
216 if (i > MAXARG) 216 if (i > MAXARG)
217 { 217 {
218 printf("too may input arguments for SCILAB function\"%s\"\n", 218 printf("too may input arguments for SCILAB function\"%s\"\n",
219 words[0]); 219 words[0]);
220 printf(" augment constant \"MAXARG\" and recompile intersci\n"); 220 printf(" augment constant \"MAXARG\" and recompile intersci\n");
221 exit(1); 221 exit(1);
222 } 222 }
223 basfun->nin = i; 223 basfun->nin = i;
224 for (i = 0; i < nwords - 1; i++) 224 for (i = 0; i < nwords - 1; i++)
225 { 225 {
226 if (words[i+1][0] == '{') 226 if (words[i+1][0] == '{')
227 { 227 {
228 maxOpt++; 228 maxOpt++;
229 nopt = ParseLine(words[i+1]+1,optwords); 229 nopt = ParseLine(words[i+1]+1,optwords);
230 if (nopt != 2) { 230 if (nopt != 2) {
231 printf("Bad syntax for optional argument. Two variables needed\n"); 231 printf("Bad syntax for optional argument. Two variables needed\n");
232 exit(1); 232 exit(1);
233 } 233 }
234 ivar = GetVar(optwords[0],1); 234 ivar = GetVar(optwords[0],1);
235 basfun->in[i] = ivar; 235 basfun->in[i] = ivar;
236 variables[ivar-1]->opt_type = NAME; 236 variables[ivar-1]->opt_type = NAME;
237 variables[ivar-1]->opt_name = 237 variables[ivar-1]->opt_name =
238 (char *)malloc((unsigned)(strlen(optwords[1])+1)); 238 (char *)malloc((unsigned)(strlen(optwords[1])+1));
239 strcpy(variables[ivar-1]->opt_name,optwords[1]); 239 strcpy(variables[ivar-1]->opt_name,optwords[1]);
240 } 240 }
241 else if (words[i+1][0] == '[') 241 else if (words[i+1][0] == '[')
242 { 242 {
243 maxOpt++; 243 maxOpt++;
244 nopt = ParseLine(words[i+1]+1,optwords); 244 nopt = ParseLine(words[i+1]+1,optwords);
245 if (nopt != 2) 245 if (nopt != 2)
246 { 246 {
247 printf("Bad syntax for optional argument. Two variables needed\n"); 247 printf("Bad syntax for optional argument. Two variables needed\n");
248 exit(1); 248 exit(1);
249 } 249 }
250 ivar = GetVar(optwords[0],1); 250 ivar = GetVar(optwords[0],1);
251 basfun->in[i] = ivar; 251 basfun->in[i] = ivar;
252 variables[ivar-1]->opt_type = VALUE; 252 variables[ivar-1]->opt_type = VALUE;
253 variables[ivar-1]->opt_name = 253 variables[ivar-1]->opt_name =
254 (char *)malloc((unsigned)(strlen(optwords[1])+1)); 254 (char *)malloc((unsigned)(strlen(optwords[1])+1));
255 strcpy(variables[ivar-1]->opt_name,optwords[1]); 255 strcpy(variables[ivar-1]->opt_name,optwords[1]);
256 } 256 }
257 else basfun->in[i] = GetVar(words[i+1],1); 257 else basfun->in[i] = GetVar(words[i+1],1);
258 } 258 }
259 line1 = 0; 259 line1 = 0;
260 inbas = 1; 260 inbas = 1;
261 } 261 }
262 else if (inbas == 1) 262 else if (inbas == 1)
263 { 263 {
264 if (nwords == 0) 264 if (nwords == 0)
265 { 265 {
266 /* end of SCILAB variable description */ 266 /* end of SCILAB variable description */
267 inbas = 0; 267 inbas = 0;
268 fline1 = 1; 268 fline1 = 1;
269 } 269 }
270 else 270 else
271 { 271 {
272 /* SCILAB variable description */ 272 /* SCILAB variable description */
273 ivar = GetVar(words[0],1); 273 ivar = GetVar(words[0],1);
274 i = ivar - 1; 274 i = ivar - 1;
275 if (nwords == 1) 275 if (nwords == 1)
276 { 276 {
277 printf("type missing for variable \"%s\"\n",words[0]); 277 printf("type missing for variable \"%s\"\n",words[0]);
278 exit(1); 278 exit(1);
279 } 279 }
280 type = GetBasType(words[1]); 280 type = GetBasType(words[1]);
281 variables[i]->type = type; 281 variables[i]->type = type;
282 switch (type) 282 switch (type)
283 { 283 {
284 case SCALAR: 284 case SCALAR:
285 case ANY: 285 case ANY:
286 case SCIMPOINTER: 286 case SCIMPOINTER:
287 case SCISMPOINTER: 287 case SCISMPOINTER:
288 case SCILPOINTER: 288 case SCILPOINTER:
289 case SCIBPOINTER: 289 case SCIBPOINTER:
290 case SCIOPOINTER: 290 case SCIOPOINTER:
291 break; 291 break;
292 case COLUMN: 292 case COLUMN:
293 case ROW: 293 case ROW:
294 case STRING: 294 case STRING:
295 case WORK: 295 case WORK:
296 case VECTOR: 296 case VECTOR:
297 if (nwords != 3) 297 if (nwords != 3)
298 { 298 {
299 printf("bad type specification for variable \"%s\"\n", words[0]); 299 printf("bad type specification for variable \"%s\"\n", words[0]);
300 printf("only %d argument given and %d are expected\n", nwords,3); 300 printf("only %d argument given and %d are expected\n", nwords,3);
301 exit(1); 301 exit(1);
302 } 302 }
303 variables[i]->el[0] = GetVar(words[2],1); 303 variables[i]->el[0] = GetVar(words[2],1);
304 break; 304 break;
305 case LIST: 305 case LIST:
306 case TLIST: 306 case TLIST:
307 if (nwords != 3) 307 if (nwords != 3)
308 { 308 {
309 printf("bad type specification for variable \"%s\"\n", words[0]); 309 printf("bad type specification for variable \"%s\"\n", words[0]);
310 printf("only %d argument given and %d are expected\n", nwords,3); 310 printf("only %d argument given and %d are expected\n", nwords,3);
311 exit(1); 311 exit(1);
312 } 312 }
313 ReadListFile(words[2],words[0],i); 313 ReadListFile(words[2],words[0],i);
314 break; 314 break;
315 case POLYNOM: 315 case POLYNOM:
316 case MATRIX: 316 case MATRIX:
317 case BMATRIX: 317 case BMATRIX:
318 case STRINGMAT: 318 case STRINGMAT:
319 if (nwords != 4) 319 if (nwords != 4)
320 { 320 {
321 printf("bad type specification for variable \"%s\"\n",words[0]); 321 printf("bad type specification for variable \"%s\"\n",words[0]);
322 printf("%d argument given and %d are expected\n", nwords,4); 322 printf("%d argument given and %d are expected\n", nwords,4);
323 exit(1); 323 exit(1);
324 } 324 }
325 variables[i]->el[0] = GetVar(words[2],1); 325 variables[i]->el[0] = GetVar(words[2],1);
326 variables[i]->el[1] = GetVar(words[3],1); 326 variables[i]->el[1] = GetVar(words[3],1);
327 break; 327 break;
328 case IMATRIX: 328 case IMATRIX:
329 if (nwords != 5) 329 if (nwords != 5)
330 { 330 {
331 printf("bad type specification for variable \"%s\"\n",words[0]); 331 printf("bad type specification for variable \"%s\"\n",words[0]);
332 printf("%d argument given and %d are expected\n", nwords,5); 332 printf("%d argument given and %d are expected\n", nwords,5);
333 exit(1); 333 exit(1);
334 } 334 }
335 variables[i]->el[0] = GetVar(words[2],1); 335 variables[i]->el[0] = GetVar(words[2],1);
336 variables[i]->el[1] = GetVar(words[3],1); 336 variables[i]->el[1] = GetVar(words[3],1);
337 variables[i]->el[2] = GetVar(words[4],1); 337 variables[i]->el[2] = GetVar(words[4],1);
338 break; 338 break;
339 case SPARSE: 339 case SPARSE:
340 if (nwords != 6) 340 if (nwords != 6)
341 { 341 {
342 printf("bad type specification for variable \"%s\"\n",words[0]); 342 printf("bad type specification for variable \"%s\"\n",words[0]);
343 printf("%d argument given and %d are expected\n", nwords,6); 343 printf("%d argument given and %d are expected\n", nwords,6);
344 printf("name sparse m n nel it\n"); 344 printf("name sparse m n nel it\n");
345 exit(1); 345 exit(1);
346 } 346 }
347 variables[i]->el[0] = GetVar(words[2],1); 347 variables[i]->el[0] = GetVar(words[2],1);
348 variables[i]->el[1] = GetVar(words[3],1); 348 variables[i]->el[1] = GetVar(words[3],1);
349 variables[i]->el[2] = GetVar(words[4],1); 349 variables[i]->el[2] = GetVar(words[4],1);
350 variables[i]->el[3] = GetVar(words[5],1); 350 variables[i]->el[3] = GetVar(words[5],1);
351 break; 351 break;
352 case SEQUENCE: 352 case SEQUENCE:
353 printf("variable \"%s\" cannot have type \"SEQUENCE\"\n", 353 printf("variable \"%s\" cannot have type \"SEQUENCE\"\n",
354 words[0]); 354 words[0]);
355 exit(1); 355 exit(1);
356 break; 356 break;
357 case EMPTY: 357 case EMPTY:
358 printf("variable \"%s\" cannot have type \"EMPTY\"\n", 358 printf("variable \"%s\" cannot have type \"EMPTY\"\n",
359 words[0]); 359 words[0]);
360 exit(1); 360 exit(1);
361 break; 361 break;
362 } 362 }
363 } 363 }
364 } 364 }
365 else if (fline1 == 1) 365 else if (fline1 == 1)
366 { 366 {
367 /* FORTRAN subroutine description */ 367 /* FORTRAN subroutine description */
368 forsub->name = (char *)malloc((unsigned)(strlen(words[0])+1)); 368 forsub->name = (char *)malloc((unsigned)(strlen(words[0])+1));
369 strcpy(forsub->name,words[0]); 369 strcpy(forsub->name,words[0]);
370 i = nwords - 1; 370 i = nwords - 1;
371 if (i > MAXARG) 371 if (i > MAXARG)
372 { 372 {
373 printf("too many argument for FORTRAN subroutine \"%s\"\n", 373 printf("too many argument for FORTRAN subroutine \"%s\"\n",
374 words[0]); 374 words[0]);
375 printf(" augment constant \"MAXARG\" and recompile intersci\n"); 375 printf(" augment constant \"MAXARG\" and recompile intersci\n");
376 exit(1); 376 exit(1);
377 } 377 }
378 forsub->narg = i; 378 forsub->narg = i;
379 for (i = 0; i < nwords - 1; i++) 379 for (i = 0; i < nwords - 1; i++)
380 { 380 {
381 forsub->arg[i] = GetExistVar(words[i+1]); 381 forsub->arg[i] = GetExistVar(words[i+1]);
382 } 382 }
383 fline1 = 0; 383 fline1 = 0;
384 infor = 1; 384 infor = 1;
385 } 385 }
386 else if (infor == 1) 386 else if (infor == 1)
387 { 387 {
388 if (nwords == 0) 388 if (nwords == 0)
389 { 389 {
390 /* end of FORTRAN subroutine description */ 390 /* end of FORTRAN subroutine description */
391 infor = 0; 391 infor = 0;
392 out1 = 1; 392 out1 = 1;
393 } 393 }
394 else 394 else
395 { 395 {
396 /* FORTRAN variable description */ 396 /* FORTRAN variable description */
397 if (nwords == 1) 397 if (nwords == 1)
398 { 398 {
399 printf("type missing for FORTRAN argument \"%s\"\n", 399 printf("type missing for FORTRAN argument \"%s\"\n",
400 words[0]); 400 words[0]);
401 exit(1); 401 exit(1);
402 } 402 }
403 ivar = GetExistVar(words[0]); 403 ivar = GetExistVar(words[0]);
404 ftype = GetForType(words[1]); 404 ftype = GetForType(words[1]);
405 variables[ivar-1]->for_type = ftype; 405 variables[ivar-1]->for_type = ftype;
406 if (ftype == EXTERNAL) 406 if (ftype == EXTERNAL)
407 { 407 {
408 strcpy((char *)(variables[ivar-1]->fexternal),words[1]); 408 strcpy((char *)(variables[ivar-1]->fexternal),words[1]);
409 switch (variables[ivar-1]->type) 409 switch (variables[ivar-1]->type)
410 { 410 {
411 case COLUMN: 411 case COLUMN:
412 case POLYNOM: 412 case POLYNOM:
413 case ROW: 413 case ROW:
414 case STRING: 414 case STRING:
415 case VECTOR: 415 case VECTOR:
416 sprintf(str,"ne%d",ivar); 416 sprintf(str,"ne%d",ivar);
417 AddForName(variables[ivar-1]->el[0],str); 417 AddForName(variables[ivar-1]->el[0],str);
418 break; 418 break;
419 case SPARSE: 419 case SPARSE:
420 sprintf(str,"me%d",ivar); 420 sprintf(str,"me%d",ivar);
421 AddForName(variables[ivar-1]->el[0],str); 421 AddForName(variables[ivar-1]->el[0],str);
422 sprintf(str,"ne%d",ivar); 422 sprintf(str,"ne%d",ivar);
423 AddForName(variables[ivar-1]->el[1],str); 423 AddForName(variables[ivar-1]->el[1],str);
424 sprintf(str,"nel%d",ivar); 424 sprintf(str,"nel%d",ivar);
425 AddForName(variables[ivar-1]->el[2],str); 425 AddForName(variables[ivar-1]->el[2],str);
426 sprintf(str,"it%d",ivar); 426 sprintf(str,"it%d",ivar);
427 AddForName(variables[ivar-1]->el[3],str); 427 AddForName(variables[ivar-1]->el[3],str);
428 break; 428 break;
429 case IMATRIX: 429 case IMATRIX:
430 sprintf(str,"me%d",ivar); 430 sprintf(str,"me%d",ivar);
431 AddForName(variables[ivar-1]->el[0],str); 431 AddForName(variables[ivar-1]->el[0],str);
432 sprintf(str,"ne%d",ivar); 432 sprintf(str,"ne%d",ivar);
433 AddForName(variables[ivar-1]->el[1],str); 433 AddForName(variables[ivar-1]->el[1],str);
434 sprintf(str,"it%d",ivar); 434 sprintf(str,"it%d",ivar);
435 AddForName(variables[ivar-1]->el[2],str); 435 AddForName(variables[ivar-1]->el[2],str);
436 break; 436 break;
437 case MATRIX: 437 case MATRIX:
438 case BMATRIX: 438 case BMATRIX:
439 case STRINGMAT: 439 case STRINGMAT:
440 sprintf(str,"me%d",ivar); 440 sprintf(str,"me%d",ivar);
441 AddForName(variables[ivar-1]->el[0],str); 441 AddForName(variables[ivar-1]->el[0],str);
442 sprintf(str,"ne%d",ivar); 442 sprintf(str,"ne%d",ivar);
443 AddForName(variables[ivar-1]->el[1],str); 443 AddForName(variables[ivar-1]->el[1],str);
444 break; 444 break;
445 default: 445 default:
446 printf("FORTRAN argument \"%s\" with external type \"%s\"\n", 446 printf("FORTRAN argument \"%s\" with external type \"%s\"\n",
447 variables[ivar-1]->name,words[1]); 447 variables[ivar-1]->name,words[1]);
448 printf(" cannot have a variable type of \"%s\"\n",SGetSciType(variables[ivar-1]->type)); 448 printf(" cannot have a variable type of \"%s\"\n",SGetSciType(variables[ivar-1]->type));
449 exit(1); 449 exit(1);
450 break; 450 break;
451 } 451 }
452 } 452 }
453 } 453 }
454 } 454 }
455 else if (out1 == 1) 455 else if (out1 == 1)
456 { 456 {
457 /* output variable description */ 457 /* output variable description */
458 i = ivar - 1; 458 i = ivar - 1;
459 if (nwords == 1) 459 if (nwords == 1)
460 { 460 {
461 printf("type missing for output variable \"out\"\n"); 461 printf("type missing for output variable \"out\"\n");
462 exit(1); 462 exit(1);
463 } 463 }
464 ivar = GetOutVar(words[0]); 464 ivar = GetOutVar(words[0]);
465 basfun->out = ivar; 465 basfun->out = ivar;
466 i = ivar - 1; 466 i = ivar - 1;
467 type = GetBasType(words[1]); 467 type = GetBasType(words[1]);
468 variables[i]->type = type; 468 variables[i]->type = type;
469 switch (type) 469 switch (type)
470 { 470 {
471 case LIST: 471 case LIST:
472 case TLIST: 472 case TLIST:
473 case SEQUENCE: 473 case SEQUENCE:
474 l = nwords - 2; 474 l = nwords - 2;
475 if (l > MAXEL) 475 if (l > MAXEL)
476 { 476 {
477 printf("list or sequence too long for output variable \"out\"\n"); 477 printf("list or sequence too long for output variable \"out\"\n");
478 printf(" augment constant \"MAXEL\" and recompile intersci\n"); 478 printf(" augment constant \"MAXEL\" and recompile intersci\n");
479 exit(1); 479 exit(1);
480 } 480 }
481 for (j = 0; j < l; j++) 481 for (j = 0; j < l; j++)
482 variables[i]->el[j] = GetExistVar(words[j+2]); 482 variables[i]->el[j] = GetExistVar(words[j+2]);
483 variables[i]->length = l; 483 variables[i]->length = l;
484 break; 484 break;
485 case EMPTY: 485 case EMPTY:
486 break; 486 break;
487 default: 487 default:
488 printf("output variable \"out\" of SCILAB function\n"); 488 printf("output variable \"out\" of SCILAB function\n");
489 printf(" must have type \"LIST\", \"TLIST\", \"SEQUENCE\" or\n"); 489 printf(" must have type \"LIST\", \"TLIST\", \"SEQUENCE\" or\n");
490 printf(" \"EMPTY\"\n"); 490 printf(" \"EMPTY\"\n");
491 exit(1); 491 exit(1);
492 break; 492 break;
493 } 493 }
494 out1 = 0; 494 out1 = 0;
495 } 495 }
496 else 496 else
497 { 497 {
498 /* possibly equal variables */ 498 /* possibly equal variables */
499 ivar = GetExistVar(words[0]); 499 ivar = GetExistVar(words[0]);
500 i = ivar -1 ; 500 i = ivar -1 ;
501 variables[i]->equal = GetExistVar(words[1]); 501 variables[i]->equal = GetExistVar(words[1]);
502 } 502 }
503 } 503 }
504 /* end of description file */ 504 /* end of description file */
505 return(0); 505 return(0);
506} 506}
507 507
508/* 508/*
509 put the words of SCILAB function description line "s" in "words" and 509put the words of SCILAB function description line "s" in "words" and
510 return the number of words with checking syntax of optional variables: 510return the number of words with checking syntax of optional variables:
511 "{g the_g }" => 1 word "{g the_g\n" 511"{g the_g }" => 1 word "{g the_g\n"
512 "[f v]" => 1 word "[f v\n" 512"[f v]" => 1 word "[f v\n"
513 */ 513*/
514 514
515int ParseScilabLine(char *s,char *words[]) 515int ParseScilabLine(char *s,char *words[])
516{ 516{
517 char w[MAXNAM]; 517 char w[MAXNAM];
518 int nwords = 0; 518 int nwords = 0;
519 int inword = 1; 519 int inword = 1;
520 int inopt1 = 0; /* { } */ 520 int inopt1 = 0; /* { } */
521 int inopt2 = 0; /* [ ] */ 521 int inopt2 = 0; /* [ ] */
522 int i = 0; 522 int i = 0;
523 if (*s == ' ' || *s == '\t') inword = 0; 523 if (*s == ' ' || *s == '\t') inword = 0;
524 if (*s == '{') inopt1 = 1; 524 if (*s == '{') inopt1 = 1;
525 if (*s == '[') inopt2 = 1; 525 if (*s == '[') inopt2 = 1;
526 while (*s) { 526 while (*s) {
527 if (inopt1) { 527 if (inopt1) {
528 w[i++] = *s++; 528 w[i++] = *s++;
529 if (*s == '{' || *s == '[' || *s == ']' || *s == '\n') { 529 if (*s == '{' || *s == '[' || *s == ']' || *s == '\n') {
530 printf("Bad syntax for optional argument. No matching \"}\"\n"); 530 printf("Bad syntax for optional argument. No matching \"}\"\n");
531 exit(1); 531 exit(1);
532 } 532 }
533 else if (*s == '}') { 533 else if (*s == '}') {
534 w[i++] = '\n'; 534 w[i++] = '\n';
535 w[i] = '\0'; 535 w[i] = '\0';
536 words[nwords] = (char *)malloc((unsigned)(i+1)); 536 words[nwords] = (char *)malloc((unsigned)(i+1));
537 strcpy(words[nwords],w); 537 strcpy(words[nwords],w);
538 nwords++; 538 nwords++;
539 inopt1 = 0; 539 inopt1 = 0;
540 inword = 0; 540 inword = 0;
541 } 541 }
542 } 542 }
543 else if (inopt2) { 543 else if (inopt2) {
544 w[i++] = *s++; 544 w[i++] = *s++;
545 if (*s == '[' || *s == '{' || *s == '}' || *s == '\n') { 545 if (*s == '[' || *s == '{' || *s == '}' || *s == '\n') {
546 printf("Bad syntax for optional argument. No matching \"]\"\n"); 546 printf("Bad syntax for optional argument. No matching \"]\"\n");
547 exit(1); 547 exit(1);
548 } 548 }
549 else if (*s == ']') { 549 else if (*s == ']') {
550 w[i++] = '\n'; 550 w[i++] = '\n';
551 w[i] = '\0'; 551 w[i] = '\0';
552 words[nwords] = (char *)malloc((unsigned)(i+1)); 552 words[nwords] = (char *)malloc((unsigned)(i+1));
553 strcpy(words[nwords],w); 553 strcpy(words[nwords],w);
554 nwords++; 554 nwords++;
555 inopt2 = 0; 555 inopt2 = 0;
556 inword = 0; 556 inword = 0;
557 } 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 }
558 } 579 }
559 else if (inword) { 580 return(nwords);
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} 581}
582 582
583/* put the words of line "s" in "words" and return the number of words */ 583/* put the words of line "s" in "words" and return the number of words */
584 584
585int ParseLine(s,words) 585int ParseLine(char *s, char *words[])
586 char *s, *words[];
587{ 586{
588 char w[MAXNAM]; 587 char w[MAXNAM];
589 int nwords = 0; 588 int nwords = 0;
590 int inword = 1; 589 int inword = 1;
591 int i = 0; 590 int i = 0;
592 if(*s == ' ' || *s == '\t') inword = 0; 591 if(*s == ' ' || *s == '\t') inword = 0;
593 while (*s) { 592 while (*s)
594 if (inword) { 593 {
595 w[i++] = *s++; 594 if (inword)
596 if (*s == ' ' || *s == '\t' || *s == '\n') { 595 {
597 w[i] = '\0'; 596 w[i++] = *s++;
598 words[nwords] = (char *)malloc((unsigned)(i+1)); 597 if (*s == ' ' || *s == '\t' || *s == '\n')
599 strcpy(words[nwords],w); 598 {
600 nwords++; 599 w[i] = '\0';
601 inword = 0; 600 words[nwords] = (char *)malloc((unsigned)(i+1));
602 } 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 }
603 } 615 }
604 else { 616
605 s++; /* *s++; */ 617 /* bug 7599 fixed: if the last line end with eof, not eol then one word missed */
606 if (*s != ' ' && *s != '\t') { 618 if (i > 1)
607 i = 0; 619 {
608 inword = 1; 620 w[i] = '\0';
609 } 621 words[nwords] = (char *)malloc((unsigned)(i+1));
622 strcpy(words[nwords],w);
623 nwords++;
610 } 624 }
611 } 625
612 return(nwords); 626 return(nwords);
613} 627}
614 628
615 629
616 630
617void ReadListFile(listname,varlistname,ivar) 631void ReadListFile(listname,varlistname,ivar)
618 char *listname; 632char *listname;
619 char *varlistname; 633char *varlistname;
620 IVAR ivar; 634IVAR ivar;
621{ 635{
622 FILE *fin; 636 FILE *fin;
623 char filin[MAXNAM]; 637 char filin[MAXNAM];
624 int nel; 638 int nel;
625 639
626 sprintf(filin,"%s.list",listname); 640 sprintf(filin,"%s.list",listname);
627 fin = fopen(filin,"r"); 641 fin = fopen(filin,"r");
628 if (fin == 0) 642 if (fin == 0)
629 { 643 {
630 printf("description file for list or tlist \"%s\" does not exist\n", 644 printf("description file for list or tlist \"%s\" does not exist\n",
631 filin); 645 filin);
632 exit(1); 646 exit(1);
633 } 647 }
634 printf("reading description file for list or tlist \"%s\"\n", listname); 648 printf("reading description file for list or tlist \"%s\"\n", listname);
635 649
636 nel = 0; 650 nel = 0;
637 while(ReadListElement(fin,varlistname,ivar,nel)) 651 while(ReadListElement(fin,varlistname,ivar,nel))
638 { 652 {
639 nel++; 653 nel++;
640 } 654 }
641 655
642 fclose(fin); 656 fclose(fin);
643} 657}
644 658
645int ReadListElement(f,varlistname,iivar,nel) 659int ReadListElement(f,varlistname,iivar,nel)
646 FILE *f; 660FILE *f;
647 char *varlistname; 661char *varlistname;
648 int nel; 662int nel;
649 IVAR iivar; 663IVAR iivar;
650{ 664{
651 char s[MAXLINE]; 665 char s[MAXLINE];
652 char *words[MAXLINE]; 666 char *words[MAXLINE];
653 int i, nline, nwords, type; 667 int i, nline, nwords, type;
654 IVAR ivar; 668 IVAR ivar;
655 char str[MAXNAM]; 669 char str[MAXNAM];
656 nline = 0; 670 nline = 0;
657 while (fgets(s,MAXLINE,f) != NULL) 671 while (fgets(s,MAXLINE,f) != NULL)
658 { 672 {
659 /* analyse of one line */ 673 /* analyse of one line */
660 nline++; 674 nline++;
661 switch (nline) 675 switch (nline)
662 { 676 {
663 case 1: 677 case 1:
664 break; 678 break;
665 case 2: 679 case 2:
666 /* SCILAB variable description */ 680 /* SCILAB variable description */
667 nwords = ParseLine(s,words); 681 nwords = ParseLine(s,words);
668 sprintf(str,"%s(%s)",words[0],varlistname); 682 sprintf(str,"%s(%s)",words[0],varlistname);
669 ivar = GetVar(str,0); 683 ivar = GetVar(str,0);
670 i = ivar - 1; 684 i = ivar - 1;
671 if (nwords == 1) 685 if (nwords == 1)
672 { 686 {
673 printf("type missing for variable \"%s\"\n",words[0]); 687 printf("type missing for variable \"%s\"\n",words[0]);
674 exit(1); 688 exit(1);
675 } 689 }
676 type = GetBasType(words[1]); 690 type = GetBasType(words[1]);
677 variables[i]->type = type; 691 variables[i]->type = type;
678 variables[i]->list_name = (char *)malloc((unsigned)(strlen(varlistname)+1)); 692 variables[i]->list_name = (char *)malloc((unsigned)(strlen(varlistname)+1));
679 strcpy(variables[i]->list_name,varlistname); 693 strcpy(variables[i]->list_name,varlistname);
680 variables[i]->list_el = nel+1; 694 variables[i]->list_el = nel+1;
681 sprintf(str,"stk(l%de%d)",iivar+1,nel+1); 695 sprintf(str,"stk(l%de%d)",iivar+1,nel+1);
682 AddForName(ivar,str); 696 AddForName(ivar,str);
683 switch (type) 697 switch (type)
684 { 698 {
685 case SCALAR: 699 case SCALAR:
686 case ANY: 700 case ANY:
687 break; 701 break;
688 case COLUMN: 702 case COLUMN:
689 case ROW: 703 case ROW:
690 case STRING: 704 case STRING:
691 case VECTOR: 705 case VECTOR:
692 if (nwords != 3) 706 if (nwords != 3)
693 { 707 {
694 printf("bad type for variable \"%s\"\n", 708 printf("bad type for variable \"%s\"\n",
695 words[0]); 709 words[0]);
696 exit(1); 710 exit(1);
697 } 711 }
698 if (isdigit(words[2][0])) 712 if (isdigit(words[2][0]))
699 { 713 {
700 variables[i]->el[0] = GetVar(words[2],0); 714 variables[i]->el[0] = GetVar(words[2],0);
701 } 715 }
702 else 716 else
703 { 717 {
704 sprintf(str,"%s(%s)",words[2],varlistname); 718 sprintf(str,"%s(%s)",words[2],varlistname);
705 variables[i]->el[0] = GetVar(str,0); 719 variables[i]->el[0] = GetVar(str,0);
706 } 720 }
707 break; 721 break;
708 case POLYNOM: 722 case POLYNOM:
709 case MATRIX: 723 case MATRIX:
710 case BMATRIX: 724 case BMATRIX:
711 case STRINGMAT: 725 case STRINGMAT:
712 if (nwords != 4) 726 if (nwords != 4)
713 { 727 {
714 printf("bad type for variable \"%s\"\n", 728 printf("bad type for variable \"%s\"\n",
715 words[0]); 729 words[0]);
716 exit(1); 730 exit(1);
717 } 731 }
718 if (isdigit(words[2][0])) 732 if (isdigit(words[2][0]))
719 { 733 {
720 variables[i]->el[0] = GetVar(words[2],0); 734 variables[i]->el[0] = GetVar(words[2],0);
721 } 735 }
722 else 736 else
723 { 737 {
724 sprintf(str,"%s(%s)",words[2],varlistname); 738 sprintf(str,"%s(%s)",words[2],varlistname);
725 variables[i]->el[0] = GetVar(str,0); 739 variables[i]->el[0] = GetVar(str,0);
726 } 740 }
727 if (isdigit(words[3][0])) 741 if (isdigit(words[3][0]))
728 { 742 {
729 variables[i]->el[1] = GetVar(words[3],0); 743 variables[i]->el[1] = GetVar(words[3],0);
730 } 744 }
731 else 745 else
732 { 746 {
733 sprintf(str,"%s(%s)",words[3],varlistname); 747 sprintf(str,"%s(%s)",words[3],varlistname);
734 variables[i]->el[1] = GetVar(str,0); 748 variables[i]->el[1] = GetVar(str,0);
735 } 749 }
736 break; 750 break;
737 case IMATRIX: 751 case IMATRIX:
738 if (nwords != 6) 752 if (nwords != 6)
739 { 753 {
740 printf("bad type for variable \"%s\"\n", 754 printf("bad type for variable \"%s\"\n",
741 words[0]); 755 words[0]);
742 exit(1); 756 exit(1);
743 } 757 }
744 if (isdigit(words[2][0])) 758 if (isdigit(words[2][0]))
745 { 759 {
746 variables[i]->el[0] = GetVar(words[2],0); 760 variables[i]->el[0] = GetVar(words[2],0);
747 } 761 }
748 else 762 else
749 { 763 {
750 sprintf(str,"%s(%s)",words[2],varlistname); 764 sprintf(str,"%s(%s)",words[2],varlistname);
751 variables[i]->el[0] = GetVar(str,0); 765 variables[i]->el[0] = GetVar(str,0);
752 } 766 }
753 if (isdigit(words[3][0])) 767 if (isdigit(words[3][0]))
754 { 768 {
755 variables[i]->el[1] = GetVar(words[3],0); 769 variables[i]->el[1] = GetVar(words[3],0);
756 } 770 }
757 else 771 else
758 { 772 {
759 sprintf(str,"%s(%s)",words[3],varlistname); 773 sprintf(str,"%s(%s)",words[3],varlistname);
760 variables[i]->el[1] = GetVar(str,0); 774 variables[i]->el[1] = GetVar(str,0);
761 } 775 }
762 sprintf(str,"%s(%s)",words[4],varlistname); 776 sprintf(str,"%s(%s)",words[4],varlistname);
763 variables[i]->el[2] = GetVar(str,0); 777 variables[i]->el[2] = GetVar(str,0);
764 break; 778 break;
765 case SPARSE: 779 case SPARSE:
766 if (nwords != 6) 780 if (nwords != 6)
767 { 781 {
768 printf("bad type for variable \"%s\"\n", 782 printf("bad type for variable \"%s\"\n",
769 words[0]); 783 words[0]);
770 exit(1); 784 exit(1);
771 } 785 }
772 if (isdigit(words[2][0])) 786 if (isdigit(words[2][0]))
773 { 787 {
774 variables[i]->el[0] = GetVar(words[2],0); 788 variables[i]->el[0] = GetVar(words[2],0);
775 } 789 }
776 else 790 else
777 { 791 {
778 sprintf(str,"%s(%s)",words[2],varlistname); 792 sprintf(str,"%s(%s)",words[2],varlistname);
779 variables[i]->el[0] = GetVar(str,0); 793 variables[i]->el[0] = GetVar(str,0);
780 } 794 }
781 if (isdigit(words[3][0])) 795 if (isdigit(words[3][0]))
782 { 796 {
783 variables[i]->el[1] = GetVar(words[3],0); 797 variables[i]->el[1] = GetVar(words[3],0);
784 } 798 }
785 else 799 else
786 { 800 {
787 sprintf(str,"%s(%s)",words[3],varlistname); 801 sprintf(str,"%s(%s)",words[3],varlistname);
788 variables[i]->el[1] = GetVar(str,0); 802 variables[i]->el[1] = GetVar(str,0);
789 } 803 }
790 if (isdigit(words[4][0])) 804 if (isdigit(words[4][0]))
791 { 805 {
792 variables[i]->el[2] = GetVar(words[4],0); 806 variables[i]->el[2] = GetVar(words[4],0);
793 } 807 }
794 else 808 else
795 { 809 {
796 sprintf(str,"%s(%s)",words[4],varlistname); 810 sprintf(str,"%s(%s)",words[4],varlistname);
797 variables[i]->el[2] = GetVar(str,0); 811 variables[i]->el[2] = GetVar(str,0);
798 } 812 }
799 sprintf(str,"%s(%s)",words[5],varlistname); 813 sprintf(str,"%s(%s)",words[5],varlistname);
800 variables[i]->el[3] = GetVar(str,0); 814 variables[i]->el[3] = GetVar(str,0);
801 break; 815 break;
802 case WORK: 816 case WORK:
803 case SEQUENCE: 817 case SEQUENCE:
804 case EMPTY: 818 case EMPTY:
805 case LIST: 819 case LIST:
806 case TLIST: 820 case TLIST:
807 printf("variable \"%s\" cannot have type \"%s\"\n", 821 printf("variable \"%s\" cannot have type \"%s\"\n",
808 words[0],SGetSciType(type)); 822 words[0],SGetSciType(type));
809 exit(1); 823 exit(1);
810 default: 824 default:
811 printf("variable \"%s\" has unknown type \"%s\"\n", 825 printf("variable \"%s\" has unknown type \"%s\"\n",
812 words[0],SGetSciType(type)); 826 words[0],SGetSciType(type));
813 } 827 }
814 break; 828 break;
815 default: 829 default:
816 /* end of description */ 830 /* end of description */
817 if (s[0] == '*') 831 if (s[0] == '*')
818 { 832 {
819 return(1); 833 return(1);
820 } 834 }
821 else 835 else
822 { 836 {
823 printf("bad description file for list or tlist \"%s\"\n", 837 printf("bad description file for list or tlist \"%s\"\n",
824 varlistname); 838 varlistname);
825 exit(1); 839 exit(1);
826 } 840 }
827 break; 841 break;
828 } 842 }
829 } 843 }
830 return(0); 844 return(0);
831} 845}
832 846
833/********************************************************************* 847/*********************************************************************
834 Dealing with the set of variables 848Dealing with the set of variables
835*********************************************************************/ 849*********************************************************************/
836 850
837 851
838/* return the variable number of variable name. if it does not already exist, 852/* return the variable number of variable name. if it does not already exist,
839 it is created and "nVariable" is incremented 853it is created and "nVariable" is incremented
840 p corresponds to the present slot of var structure: 854p corresponds to the present slot of var structure:
841 - if the variable does not exist it is created with p value 855- if the variable does not exist it is created with p value
842 - if the variable exists it is created with (p or 0) value 856- if the variable exists it is created with (p or 0) value
843 */ 857*/
844 858
845IVAR GetVar(name,p) 859IVAR GetVar(name,p)
846 char *name; 860char *name;
847 int p; 861int p;
848{ 862{
849 int i; 863 int i;
850 VARPTR var; 864 VARPTR var;
851 if (strcmp(name,"out") == 0) { 865 if (strcmp(name,"out") == 0) {
852 printf("the name of a variable which is not the output variable\n"); 866 printf("the name of a variable which is not the output variable\n");
853 printf(" of SCILAB function cannot be \"out\"\n"); 867 printf(" of SCILAB function cannot be \"out\"\n");
854 exit(1); 868 exit(1);
855 } 869 }
856 for (i = 0; i < nVariable; i++) { 870 for (i = 0; i < nVariable; i++) {
857 var = variables[i]; 871 var = variables[i];
858 if (strcmp(var->name,name) == 0) { 872 if (strcmp(var->name,name) == 0) {
859 var->present = var->present || p; 873 var->present = var->present || p;
860 return(i+1); 874 return(i+1);
861 } 875 }
862 } 876 }
863 if (nVariable == MAXVAR) { 877 if (nVariable == MAXVAR) {
864 printf("too many variables\n"); 878 printf("too many variables\n");
865 printf(" augment constant \"MAXVAR\" and recompile intersci\n"); 879 printf(" augment constant \"MAXVAR\" and recompile intersci\n");
866 exit(1); 880 exit(1);
867 } 881 }
868 var = VarAlloc(); 882 var = VarAlloc();
869 if (var == 0) { 883 if (var == 0) {
870 printf("Running out of memory\n"); 884 printf("Running out of memory\n");
871 exit(1); 885 exit(1);
872 } 886 }
873 var->name = (char *)malloc((unsigned)(strlen(name) + 1)); 887 var->name = (char *)malloc((unsigned)(strlen(name) + 1));
874 strcpy(var->name,name); 888 strcpy(var->name,name);
875 var->type = 0; 889 var->type = 0;
876 var->length = 0; 890 var->length = 0;
877 var->for_type = 0; 891 var->for_type = 0;
878 var->equal = 0; 892 var->equal = 0;
879 var->nfor_name = 0; 893 var->nfor_name = 0;
880 var->kp_state = -1; 894 var->kp_state = -1;
881 var->list_el = 0; 895 var->list_el = 0;
882 var->opt_type = 0; 896 var->opt_type = 0;
883 var->present = p; 897 var->present = p;
884 variables[nVariable++] = var; 898 var->list_name = 0; ;/* bug fixed : an uninitialized pointer */
885 return(nVariable); 899 variables[nVariable++] = var;
900 return(nVariable);
886} 901}
887 902
888/* return the variable number of variable name which must already exist */ 903/* return the variable number of variable name which must already exist */
889 904
890IVAR GetExistVar(char *name) 905IVAR GetExistVar(char *name)
891{ 906{
892 int i; 907 int i;
893 VARPTR var; 908 VARPTR var;
894 if (strcmp(name,"out") == 0) { 909 if (strcmp(name,"out") == 0) {
895 printf("the name of a variable which is not the output variable\n"); 910 printf("the name of a variable which is not the output variable\n");
896 printf(" of SCILAB function cannot be \"out\"\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);
897 exit(1); 925 exit(1);
898 }
899 for (i = 0; i < nVariable; i++) {
900 var = variables[i];
901 if (strcmp(var->name,name) == 0) {
902 /* always present */
903 var->present = 1;
904 return(i+1);
905 }
906 }
907 i=CreatePredefVar(name);
908 if ( i != -1) return(i);
909 printf("variable \"%s\" must exist\n",name);
910 exit(1);
911} 926}
912 927
913/* fname,rhs,lhs,err are predefined variables 928/* fname,rhs,lhs,err are predefined variables
914 if someone want to add them in the Fortran or C Calling sequence 929if someone want to add them in the Fortran or C Calling sequence
915 it's done without aby checks 930it's done without aby checks
916*/ 931*/
917 932
918int CreatePredefVar(name) 933int CreatePredefVar(name)
919 char *name; 934char *name;
920{ 935{
921 VARPTR var; 936 VARPTR var;
922 if (strcmp(name,"err") == 0 937 if (strcmp(name,"err") == 0
923 || strcmp(name,"rhs") == 0 938 || strcmp(name,"rhs") == 0
924 || strcmp(name,"lhs") == 0 939 || strcmp(name,"lhs") == 0
925 || strcmp(name,"fname") == 0) 940 || strcmp(name,"fname") == 0)
926 { 941 {
927 int num ; 942 int num ;
928 num=GetVar(name,1); 943 num=GetVar(name,1);
929 var = variables[num-1]; 944 var = variables[num-1];
930 var->for_type = PREDEF; 945 var->for_type = PREDEF;
931 return(num); 946 return(num);
932 } 947 }
933 return(-1); 948 return(-1);
934} 949}
935 950
936/* return the variable number of variable "out" 951/* return the variable number of variable "out"
937 which is created and "nVariable" is incremented */ 952which is created and "nVariable" is incremented */
938 953
939IVAR GetOutVar(name) 954IVAR GetOutVar(name)
940 char *name; 955char *name;
941{ 956{
942 VARPTR var; 957 VARPTR var;
943 if (strcmp(name,"out") != 0) { 958 if (strcmp(name,"out") != 0) {
944 printf("the name of output variable of SCILAB function\n"); 959 printf("the name of output variable of SCILAB function\n");
945 printf(" must be \"out\"\n"); 960 printf(" must be \"out\"\n");
946 exit(1); 961 exit(1);
947 } 962 }
948 if (nVariable == MAXVAR) { 963 if (nVariable == MAXVAR) {
949 printf("too many variables\n"); 964 printf("too many variables\n");
950 printf(" augmente constant \"MAXVAR\" and recompile intersci\n"); 965 printf(" augmente constant \"MAXVAR\" and recompile intersci\n");
951 exit(1); 966 exit(1);
952 } 967 }
953 var = VarAlloc(); 968 var = VarAlloc();
954 if (var == 0) { 969 if (var == 0) {
955 printf("Running out of memory\n"); 970 printf("Running out of memory\n");
956 exit(1); 971 exit(1);
957 } 972 }
958 var->name = (char *)malloc((unsigned)(strlen(name) + 1)); 973 var->name = (char *)malloc((unsigned)(strlen(name) + 1));
959 strcpy(var->name,name); 974 strcpy(var->name,name);
960 var->type = 0; 975 var->type = 0;
961 var->length = 0; 976 var->length = 0;
962 var->for_type = 0; 977 var->for_type = 0;
963 var->equal = 0; 978 var->equal = 0;
964 var->nfor_name = 0; 979 var->nfor_name = 0;
965 var->kp_state = -1; 980 var->kp_state = -1;
966 var->list_el = 0; 981 var->list_el = 0;
967 var->opt_type = 0; 982 var->opt_type = 0;
968 var->present = 0; 983 var->present = 0;
969 variables[nVariable++] = var; 984 variables[nVariable++] = var;
970 return(nVariable); 985 return(nVariable);
971} 986}
972 987
973/* return the variable number of variable "out" 988/* return the variable number of variable "out"
974 which must exist */ 989which must exist */
975 990
976IVAR GetExistOutVar() 991IVAR GetExistOutVar()
977{ 992{
978 int i; 993 int i;
979 char str[4]; 994 char str[4];
980 strcpy(str,"out"); 995 strcpy(str,"out");
981 for (i = 0; i < nVariable; i++) { 996 for (i = 0; i < nVariable; i++) {
982 if (strcmp(variables[i]->name,str) == 0) 997 if (strcmp(variables[i]->name,str) == 0)
983 return(i+1); 998 return(i+1);
984 } 999 }
985 printf("variable \"out\" must exist\n"); 1000 printf("variable \"out\" must exist\n");
986 exit(1); 1001 exit(1);
987} 1002}
988 1003
989/*************************** 1004/***************************
990 * add name in the for_name array 1005* add name in the for_name array
991 * field of variable ivar 1006* field of variable ivar
992 ***************************/ 1007***************************/
993 1008
994void AddForName(ivar,name) 1009void AddForName(ivar,name)
995 IVAR ivar; 1010IVAR ivar;
996 char* name; 1011char* name;
997{ 1012{
998 VARPTR var; 1013 VARPTR var;
999 int l; 1014 int l;
1000 var = variables[ivar-1]; 1015 var = variables[ivar-1];
1001 l = var->nfor_name; 1016 l = var->nfor_name;
1002 if (l == MAXARG) { 1017 if (l == MAXARG) {
1003 printf("too many \"for_name\" for variable \"%s\"\n",var->name); 1018 printf("too many \"for_name\" for variable \"%s\"\n",var->name);
1004 printf(" augment constant \"MAXARG\" and recompile intersci\n"); 1019 printf(" augment constant \"MAXARG\" and recompile intersci\n");
1005 exit(1); 1020 exit(1);
1006 } 1021 }
1007 var->for_name[l] = (char *)malloc((unsigned)(strlen(name) + 1)); 1022 var->for_name[l] = (char *)malloc((unsigned)(strlen(name) + 1));
1008 strcpy(var->for_name[l],name); 1023 strcpy(var->for_name[l],name);
1009 var->nfor_name = l + 1; 1024 var->nfor_name = l + 1;
1010} 1025}
1011 1026
1012void AddForName1(ivar,name) 1027void AddForName1(ivar,name)
1013 IVAR ivar; 1028IVAR ivar;
1014 char* name; 1029char* name;
1015{ 1030{
1016 VARPTR var; 1031 VARPTR var;
1017 int l; 1032 int l;
1018 var = variables[ivar-1]; 1033 var = variables[ivar-1];
1019 l = var->nfor_name; 1034 l = var->nfor_name;
1020 if ( pass == 0 && var->kp_state == -1 ) 1035 if ( pass == 0 && var->kp_state == -1 )
1021 { 1036 {
1022 var->kp_state = var->nfor_name ; 1037 var->kp_state = var->nfor_name ;
1023 } 1038 }
1024 if (l == MAXARG) { 1039 if (l == MAXARG) {
1025 printf("too many \"for_name\" for variable \"%s\"\n",var->name); 1040 printf("too many \"for_name\" for variable \"%s\"\n",var->name);
1026 printf(" augment constant \"MAXARG\" and recompile intersci\n"); 1041 printf(" augment constant \"MAXARG\" and recompile intersci\n");
1027 exit(1); 1042 exit(1);
1028 } 1043 }
1029 var->for_name[l] = (char *)malloc((unsigned)(strlen(name) + 1)); 1044 var->for_name[l] = (char *)malloc((unsigned)(strlen(name) + 1));
1030 strcpy(var->for_name[l],name); 1045 strcpy(var->for_name[l],name);
1031 var->nfor_name = l + 1; 1046 var->nfor_name = l + 1;
1032} 1047}
1033 1048
1034void ForNameClean() 1049void ForNameClean()
1035{ 1050{
1036 VARPTR var; 1051 VARPTR var;
1037 int i; 1052 int i;
1038 for (i = 0; i < nVariable; i++) { 1053 for (i = 0; i < nVariable; i++) {
1039 var = variables[i]; 1054 var = variables[i];
1040 if ( var->kp_state != -1 ) 1055 if ( var->kp_state != -1 )
1041 { 1056 {
1042 var->nfor_name = var->kp_state ; 1057 var->nfor_name = var->kp_state ;
1043 } 1058 }
1044 } 1059 }
1045} 1060}
1046 1061
1047void ChangeForName(ivar,name) 1062void ChangeForName(ivar,name)
1048 IVAR ivar; 1063IVAR ivar;
1049 char* name; 1064char* name;
1050{ 1065{
1051 VARPTR var; 1066 VARPTR var;
1052 int l; 1067 int l;
1053 var = variables[ivar-1]; 1068 var = variables[ivar-1];
1054 l = var->nfor_name; 1069 l = var->nfor_name;
1055 var->for_name[0] = (char *)malloc((unsigned)(strlen(name) + 1)); 1070 var->for_name[0] = (char *)malloc((unsigned)(strlen(name) + 1));
1056 strcpy(var->for_name[0],name); 1071 strcpy(var->for_name[0],name);
1057 /* useful ??? */ 1072 /* useful ??? */
1058 if (l == 0) var->nfor_name = 1; 1073 if (l == 0) var->nfor_name = 1;
1059} 1074}
1060 1075
1061/*********************************************************** 1076/***********************************************************
1062 Convertions de type entre codage entier 1077Convertions de type entre codage entier
1063 et description par chaine de caracteres 1078et description par chaine de caracteres
1064 pour les types Scilab et les types Fortran 1079pour les types Scilab et les types Fortran
1065************************************************************/ 1080************************************************************/
1066 1081
1067/* Attention tableau en ordre alphabetique */ 1082/* Attention tableau en ordre alphabetique */
1068 1083
1069static struct btype { char *sname ; 1084static struct btype { char *sname ;
1070 int code ;} 1085int code ;}
1071SType[] = { 1086SType[] = {
1072 {"any", ANY}, 1087 {"any", ANY},
1073 {"bmatrix", BMATRIX}, 1088 {"bmatrix", BMATRIX},
1074 {"bpointer", SCIBPOINTER}, 1089 {"bpointer", SCIBPOINTER},
1075 {"column", COLUMN}, 1090 {"column", COLUMN},
1076 {"empty", EMPTY}, 1091 {"empty", EMPTY},
1077 {"imatrix", IMATRIX}, 1092 {"imatrix", IMATRIX},
1078 {"list", LIST}, 1093 {"list", LIST},
1079 {"lpointer", SCILPOINTER}, 1094 {"lpointer", SCILPOINTER},
1080 {"matrix", MATRIX}, 1095 {"matrix", MATRIX},
1081 {"mpointer", SCIMPOINTER}, 1096 {"mpointer", SCIMPOINTER},
1082 {"opointer", SCIOPOINTER}, 1097 {"opointer", SCIOPOINTER},
1083 {"polynom", POLYNOM}, 1098 {"polynom", POLYNOM},
1084 {"row", ROW}, 1099 {"row", ROW},
1085 {"scalar", SCALAR}, 1100 {"scalar", SCALAR},
1086 {"sequence", SEQUENCE}, 1101 {"sequence", SEQUENCE},
1087 {"smpointer", SCISMPOINTER}, 1102 {"smpointer", SCISMPOINTER},
1088 {"sparse", SPARSE}, 1103 {"sparse", SPARSE},
1089 {"string", STRING}, 1104 {"string", STRING},
1090 {"stringmat", STRINGMAT}, 1105 {"stringmat", STRINGMAT},
1091 {"tlist", TLIST}, 1106 {"tlist", TLIST},
1092 {"vector", VECTOR}, 1107 {"vector", VECTOR},
1093 {"work", WORK}, 1108 {"work", WORK},
1094 {(char *) 0 , -1} 1109 {(char *) 0 , -1}
1095 }; 1110};
1096 1111
1097/* Type Scilab: renvoit un codage du type en nombre entier etant donne une chaine */ 1112/* Type Scilab: renvoit un codage du type en nombre entier etant donne une chaine */
1098 1113
1099int GetBasType(sname) 1114int GetBasType(sname)
1100 char *sname; 1115char *sname;
1101{ 1116{
1102 int i=0; 1117 int i=0;
1103 while ( SType[i].sname != (char *) NULL) 1118 while ( SType[i].sname != (char *) NULL)
1104 { 1119 {
1105 int j ; 1120 int j ;
1106 j = strcmp(sname,SType[i].sname); 1121 j = strcmp(sname,SType[i].sname);
1107 if ( j == 0 ) 1122 if ( j == 0 )
1108 { 1123 {
1109 return(SType[i].code); 1124 return(SType[i].code);
1110 } 1125 }
1111 else 1126 else
1112 { 1127 {
1113 if ( j <= 0) 1128 if ( j <= 0)
1114 break; 1129 break;
1115 else i++; 1130 else i++;
1116 } 1131 }
1117 } 1132 }
1118 printf("the type of variable \"%s\" is unknown\n",sname); 1133 printf("the type of variable \"%s\" is unknown\n",sname);
1119 exit(1); 1134 exit(1);
1120} 1135}
1121 1136
1122/* Type Scilab : Renvoit la description (string) d'un type a partir de son code */ 1137/* Type Scilab : Renvoit la description (string) d'un type a partir de son code */
1123 1138
1124char *SGetSciType(type) 1139char *SGetSciType(type)
1125 int type; 1140int type;
1126{ 1141{
1127 int i=0; 1142 int i=0;
1128 while ( SType[i].code != -1 ) 1143 while ( SType[i].code != -1 )
1129 { 1144 {
1130 if ( SType[i].code == type ) 1145 if ( SType[i].code == type )
1131 return(SType[i].sname); 1146 return(SType[i].sname);
1132 else 1147 else
1133 i++; 1148 i++;
1134 } 1149 }
1135 return("unknown"); 1150 return("unknown");
1136} 1151}
1137 1152
1138/* Attention tableau en ordre alphabetique */ 1153/* Attention tableau en ordre alphabetique */
1139 1154
1140static struct ftype { char *fname ; 1155static struct ftype { char *fname ;
1141 int code ;} 1156int code ;}
1142FType[] = { 1157FType[] = {
1143 {"Cstringv",CSTRINGV}, 1158 {"Cstringv",CSTRINGV},
1144 {"bpointer",BPOINTER}, 1159 {"bpointer",BPOINTER},
1145 {"char",CHAR}, 1160 {"char",CHAR},
1146 {"double", DOUBLE}, 1161 {"double", DOUBLE},
1147 {"int",INT}, 1162 {"int",INT},
1148 {"integer",INT}, 1163 {"integer",INT},
1149 {"lpointer",LPOINTER}, 1164 {"lpointer",LPOINTER},
1150 {"mpointer",MPOINTER}, 1165 {"mpointer",MPOINTER},
1151 {"opointer",OPOINTER}, 1166 {"opointer",OPOINTER},
1152 {"predef",PREDEF}, 1167 {"predef",PREDEF},
1153 {"real",REAL}, 1168 {"real",REAL},
1154 {"smpointer",SMPOINTER}, 1169 {"smpointer",SMPOINTER},
1155 {(char *) 0 , -1} 1170 {(char *) 0 , -1}
1156 }; 1171};
1157 1172
1158/* Type Fortran: renvoit un codage du type en nombre entier etant donne une chaine */ 1173/* Type Fortran: renvoit un codage du type en nombre entier etant donne une chaine */
1159/* convert string to int FORTRAN type */ 1174/* convert string to int FORTRAN type */
1160 1175
1161int GetForType(char *type) 1176int GetForType(char *type)
1162{ 1177{
1163 int i=0; 1178 int i=0;
1164 while ( FType[i].fname != (char *) NULL) 1179 while ( FType[i].fname != (char *) NULL)
1165 { 1180 {
1166 int j; 1181 int j;
1167 j = strcmp(type,FType[i].fname); 1182 j = strcmp(type,FType[i].fname);
1168 if ( j == 0 ) 1183 if ( j == 0 )
1169 { 1184 {
1170 return(FType[i].code); 1185 return(FType[i].code);
1171 } 1186 }
1172 else 1187 else
1173 { 1188 {
1174 if ( j <= 0) 1189 if ( j <= 0)
1175 break; 1190 break;
1176 else i++; 1191 else i++;
1177 } 1192 }
1178 } 1193 }
1179 return(EXTERNAL); 1194 return(EXTERNAL);
1180} 1195}
1181 1196
1182/* Type Scilab : Renvoit la description (string) d'un type a partir de son code */ 1197/* Type Scilab : Renvoit la description (string) d'un type a partir de son code */
1183 1198
1184char *SGetForType(int type) 1199char *SGetForType(int type)
1185{ 1200{
1186 int i=0; 1201 int i=0;
1187 while ( FType[i].code != -1 ) 1202 while ( FType[i].code != -1 )
1188 { 1203 {
1189 if ( FType[i].code == type ) 1204 if ( FType[i].code == type )
1190 return(FType[i].fname); 1205 return(FType[i].fname);
1191 else 1206 else
1192 i++; 1207 i++;
1193 } 1208 }
1194 return("External"); 1209 return("External");
1195} 1210}
1196 1211
1197/*************************************************************** 1212/***************************************************************
1198 Code generation 1213Code generation
1199***************************************************************/ 1214***************************************************************/
1200 1215
1201 1216
1202void WriteMainHeader(FILE *f,char *fname) 1217void WriteMainHeader(FILE *f,char *fname)
1203{ 1218{
1204 char *scidir; 1219 char *scidir;
1205 Fprintf(f,indent,"subroutine %s\n",fname); 1220 Fprintf(f,indent,"subroutine %s\n",fname);
1206 scidir = getenv("SCI"); 1221 scidir = getenv("SCI");
1207 if ( scidir != NULL) 1222 if ( scidir != NULL)
1208 Fprintf(f,indent,"include '%s/modules/core/includes/stack.h'\n",scidir); 1223 Fprintf(f,indent,"include '%s/modules/core/includes/stack.h'\n",scidir);
1209 else 1224 else
1210 Fprintf(f,indent,"include 'SCIDIR/modules/core/includes/stack.h'\n"); 1225 Fprintf(f,indent,"include 'SCIDIR/modules/core/includes/stack.h'\n");
1211 Fprintf(f,indent,"rhs = max(0,rhs)\n"); 1226 Fprintf(f,indent,"rhs = max(0,rhs)\n");
1212 FCprintf(f,"c\n"); 1227 FCprintf(f,"c\n");
1213} 1228}
1214 1229
1215 1230
1216void WriteHeader(FILE *f,char *fname0,char *fname) 1231void WriteHeader(FILE *f,char *fname0,char *fname)
1217{ 1232{
1218 Fprintf(f,indent,"subroutine %s%s(fname)\n",fname0,fname); 1233 Fprintf(f,indent,"subroutine %s%s(fname)\n",fname0,fname);
1219 FCprintf(f,"c\n"); 1234 FCprintf(f,"c\n");
1220 Fprintf(f,indent,"character*(*) fname\n"); 1235 Fprintf(f,indent,"character*(*) fname\n");
1221 Fprintf(f,indent,"include 'stack.h'\n"); 1236 Fprintf(f,indent,"include 'stack.h'\n");
1222 FCprintf(f,"c\n"); 1237 FCprintf(f,"c\n");
1223 Fprintf(f,indent,"int iadr, sadr\n"); 1238 Fprintf(f,indent,"int iadr, sadr\n");
1224 WriteDeclaration(f); 1239 WriteDeclaration(f);
1225 Fprintf(f,indent,"iadr(l)=l+l-1\n"); 1240 Fprintf(f,indent,"iadr(l)=l+l-1\n");
1226 Fprintf(f,indent,"sadr(l)=(l/2)+1\n"); 1241 Fprintf(f,indent,"sadr(l)=(l/2)+1\n");
1227 Fprintf(f,indent,"rhs = max(0,rhs)\n"); 1242 Fprintf(f,indent,"rhs = max(0,rhs)\n");
1228 FCprintf(f,"c\n"); 1243 FCprintf(f,"c\n");
1229} 1244}
1230 1245
1231void WriteFunctionCode(FILE *f) 1246void WriteFunctionCode(FILE *f)
1232{ 1247{
1233 int i; 1248 int i;
1234 IVAR ivar; 1249 IVAR ivar;
1235 icre=1; 1250 icre=1;
1236 if ( pass == 1) 1251 if ( pass == 1)
1237 { 1252 {
1238 printf(" generating code for SCILAB function\"%s\"\n", 1253 printf(" generating code for SCILAB function\"%s\"\n",
1239 basfun->name); 1254 basfun->name);
1240 printf(" and FORTRAN subroutine\"%s\"\n",forsub->name); 1255 printf(" and FORTRAN subroutine\"%s\"\n",forsub->name);
1241 } 1256 }
1242 FCprintf(f,"c SCILAB function : %s, fin = %d\n",basfun->name,nFun); 1257 FCprintf(f,"c SCILAB function : %s, fin = %d\n",basfun->name,nFun);
1243 WriteHeader(f,"ints",basfun->name); 1258 WriteHeader(f,"ints",basfun->name);
1244 1259
1245 /* possibly init for string flag */ 1260 /* possibly init for string flag */
1246 for (i = 0; i < forsub->narg; i++) 1261 for (i = 0; i < forsub->narg; i++)
1247 { 1262 {
1248 if (variables[forsub->arg[i]-1]->for_type == CHAR) 1263 if (variables[forsub->arg[i]-1]->for_type == CHAR)
1249 { 1264 {
1250 Fprintf(f,indent,"lbuf = 1\n"); 1265 Fprintf(f,indent,"lbuf = 1\n");
1251 break; 1266 break;
1252 } 1267 }
1253 } 1268 }
1254 1269
1255 /* init for work space */ 1270 /* init for work space */
1256 1271
1257 AddDeclare(DEC_INT,"topk"); 1272 AddDeclare(DEC_INT,"topk");
1258 AddDeclare(DEC_INT,"rhsk"); 1273 AddDeclare(DEC_INT,"rhsk");
1259 Fprintf(f,indent,"topk = top\n"); 1274 Fprintf(f,indent,"topk = top\n");
1260 Fprintf(f,indent,"rhsk = rhs\n"); 1275 Fprintf(f,indent,"rhsk = rhs\n");
1261 1276
1262 /* rhs argument number checking */ 1277 /* rhs argument number checking */
1263 AddDeclare(DEC_LOGICAL,"checkrhs"); 1278 AddDeclare(DEC_LOGICAL,"checkrhs");
1264 Fprintf(f,indent,"if(.not.checkrhs(fname,%d,%d)) return\n",basfun->nin - maxOpt,basfun->nin); 1279 Fprintf(f,indent,"if(.not.checkrhs(fname,%d,%d)) return\n",basfun->nin - maxOpt,basfun->nin);
1265 1280
1266 /* lhs argument number checking */ 1281 /* lhs argument number checking */
1267 ivar = basfun->out; 1282 ivar = basfun->out;
1268 if ((variables[ivar-1]->length == 0) || (variables[ivar-1]->type == LIST) 1283 if ((variables[ivar-1]->length == 0) || (variables[ivar-1]->type == LIST)
1269 || (variables[ivar-1]->type == TLIST)) 1284 || (variables[ivar-1]->type == TLIST))
1270 { 1285 {
1271 AddDeclare(DEC_LOGICAL,"checklhs"); 1286 AddDeclare(DEC_LOGICAL,"checklhs");
1272 Fprintf(f,indent,"if(.not.checklhs(fname,1,1)) return\n"); 1287 Fprintf(f,indent,"if(.not.checklhs(fname,1,1)) return\n");
1273 } 1288 }
1274 else 1289 else
1275 { 1290 {
1276 AddDeclare(DEC_LOGICAL,"checklhs"); 1291 AddDeclare(DEC_LOGICAL,"checklhs");
1277 Fprintf(f,indent,"if(.not.checklhs(fname,1,%d)) return\n",variables[ivar-1]->length); 1292 Fprintf(f,indent,"if(.not.checklhs(fname,1,%d)) return\n",variables[ivar-1]->length);
1278 } 1293 }
1279 1294
1280 /* SCILAB argument checking */ 1295 /* SCILAB argument checking */
1281 for (i = 0; i < basfun->nin; i++) 1296 for (i = 0; i < basfun->nin; i++)
1282 { 1297 {
1283 switch ( variables[i]->type ) 1298 switch ( variables[i]->type )
1284 { 1299 {
1285 case LIST : 1300 case LIST :
1286 case TLIST: 1301 case TLIST:
1287 WriteListAnalysis(f,i); 1302 WriteListAnalysis(f,i);
1288 break; 1303 break;
1289 default: 1304 default:
1290 WriteArgCheck(f,i); 1305 WriteArgCheck(f,i);
1291 break; 1306 break;
1292 } 1307 }
1293 } 1308 }
1294 1309
1295 /* SCILAB cross checking */ 1310 /* SCILAB cross checking */
1296 1311
1297 WriteCrossCheck(f); 1312 WriteCrossCheck(f);
1298 1313
1299 /* SCILAB equal output variable checking */ 1314 /* SCILAB equal output variable checking */
1300 WriteEqualCheck(f); 1315 WriteEqualCheck(f);
1301 1316
1302 /* FORTRAN call */ 1317 /* FORTRAN call */
1303 WriteFortranCall(f); 1318 WriteFortranCall(f);
1304 1319
1305 /* FORTRAN output to SCILAB */ 1320 /* FORTRAN output to SCILAB */
1306 WriteOutput(f); 1321 WriteOutput(f);
1307} 1322}
1308 1323
1309 1324
1310void WriteInfoCode(f) 1325void WriteInfoCode(f)
1311 FILE* f; 1326FILE* f;
1312{ 1327{
1313 int i,iout; 1328 int i,iout;
1314 IVAR ivar; 1329 IVAR ivar;
1315 VARPTR var,vout; 1330 VARPTR var,vout;
1316 1331
1317 iout = GetExistOutVar(); 1332 iout = GetExistOutVar();
1318 vout = variables[iout -1]; 1333 vout = variables[iout -1];
1319 1334
1320 switch (vout->type) { 1335 switch (vout->type) {
1321 case LIST: 1336 case LIST:
1322 case TLIST: 1337 case TLIST:
1323 /* loop on output variables */ 1338 /* loop on output variables */
1324 printf("list("); 1339 printf("list(");
1325 for (i = 0; i < vout->length; i++) 1340 for (i = 0; i < vout->length; i++)
1326 { 1341 {
1327 ivar = vout->el[i]; 1342 ivar = vout->el[i];
1328 var = variables[ivar-1]; 1343 var = variables[ivar-1];
1329 printf("%s",var->name); 1344 printf("%s",var->name);
1330 if ( i != vout->length -1 ) 1345 if ( i != vout->length -1 )
1331 printf(","); 1346 printf(",");
1332 else 1347 else
1333 printf(")"); 1348 printf(")");
1334 } 1349 }
1335 break ; 1350 break ;
1336 case SEQUENCE: 1351 case SEQUENCE:
1337 /* loop on output variables */ 1352 /* loop on output variables */
1338 printf("["); 1353 printf("[");
1339 for (i = 0; i < vout->length; i++) 1354 for (i = 0; i < vout->length; i++)
1340 { 1355 {
1341 ivar = vout->el[i]; 1356 ivar = vout->el[i];
1342 var = variables[ivar-1]; 1357 var = variables[ivar-1];
1343 printf("%s",var->name); 1358 printf("%s",var->name);
1344 if ( i != vout->length -1 ) 1359 if ( i != vout->length -1 )
1345 printf(","); 1360 printf(",");
1346 else 1361 else
1347 printf("]"); 1362 printf("]");
1348 } 1363 }
1349 break; 1364 break;
1350 case EMPTY: 1365 case EMPTY:
1351 printf("[]\n"); 1366 printf("[]\n");
1352 break; 1367 break;
1353 } 1368 }
1354 1369
1355 printf("=%s(",basfun->name); 1370 printf("=%s(",basfun->name);
1356 for (i = 0; i < basfun->nin; i++) 1371 for (i = 0; i < basfun->nin; i++)
1357 { 1372 {
1358 printf("%s(%s)",variables[i]->name,SGetSciType(variables[i]->type)); 1373 printf("%s(%s)",variables[i]->name,SGetSciType(variables[i]->type));
1359 if ( i != basfun->nin -1 ) 1374 if ( i != basfun->nin -1 )
1360 printf(","); 1375 printf(",");
1361 } 1376 }
1362 printf(")\n"); 1377 printf(")\n");
1363 1378
1364} 1379}
1365 1380
1366/* Ckecking and getting infos for datas coming from scilab calling 1381/* Ckecking and getting infos for datas coming from scilab calling
1367 sequence ( datas on the stack ) 1382sequence ( datas on the stack )
1368*/ 1383*/
1369 1384
1370void WriteArgCheck(f,i) 1385void WriteArgCheck(f,i)
1371 FILE *f; 1386FILE *f;
1372 int i; 1387int i;
1373{ 1388{
1374 int i1; 1389 int i1;
1375 char str[MAXNAM]; 1390 char str[MAXNAM];
1376 char str1[MAXNAM]; 1391 char str1[MAXNAM];
1377 char size[MAXNAM]; 1392 char size[MAXNAM];
1378 char data[MAXNAM]; 1393 char data[MAXNAM];
1379 1394
1380 VARPTR var = variables[basfun->in[i]-1]; 1395 VARPTR var = variables[basfun->in[i]-1];
1381 i1 = i + 1; 1396 i1 = i + 1;
1382 1397
1383 FCprintf(f,"c checking variable %s (number %d)\n",var->name,i1); 1398 FCprintf(f,"c checking variable %s (number %d)\n",var->name,i1);
1384 FCprintf(f,"c \n"); 1399 FCprintf(f,"c \n");
1385 1400
1386 /* Optional Argument consideration */ 1401 /* Optional Argument consideration */
1387 if (var->opt_type != 0) 1402 if (var->opt_type != 0)
1388 { 1403 {
1389 /** if (i1 < basfun->nin) { 1404 /** if (i1 < basfun->nin) {
1390 printf("Optional arguments must be at the end of the calling sequence\n"); 1405 printf("Optional arguments must be at the end of the calling sequence\n");
1391 exit(1); 1406 exit(1);
1392 } 1407 }
1393 **/ 1408 **/
1394 Fprintf(f,indent++,"if(rhs .le. %d) then\n", i1-1 ); 1409 Fprintf(f,indent++,"if(rhs .le. %d) then\n", i1-1 );
1395 switch (var->opt_type) { 1410 switch (var->opt_type) {
1396 case NAME: 1411 case NAME:
1397 AddDeclare(DEC_LOGICAL,"optvarget"); 1412 AddDeclare(DEC_LOGICAL,"optvarget");
1398 Fprintf(f,indent,"if (.not.optvarget(fname,topk,%d,'%s ')) return\n",i1,var->opt_name); 1413 Fprintf(f,indent,"if (.not.optvarget(fname,topk,%d,'%s ')) return\n",i1,var->opt_name);
1399 break; 1414 break;
1400 case VALUE: 1415 case VALUE:
1401 switch (var->type) { 1416 switch (var->type) {
1402 case SCALAR: 1417 case SCALAR:
1403 AddDeclare(DEC_LOGICAL,"cremat"); 1418 AddDeclare(DEC_LOGICAL,"cremat");
1404 Fprintf(f,indent,"top = top+1\n"); 1419 Fprintf(f,indent,"top = top+1\n");
1405 Fprintf(f,indent,"rhs = rhs+1\n"); 1420 Fprintf(f,indent,"rhs = rhs+1\n");
1406 Fprintf(f,indent,"if(.not.cremat(fname,top,0,1,1,lr%d,lc%d)) return\n",i1,i1); 1421 Fprintf(f,indent,"if(.not.cremat(fname,top,0,1,1,lr%d,lc%d)) return\n",i1,i1);
1407 Fprintf(f,indent,"stk(lr%d)= %s\n",i1,var->opt_name); 1422 Fprintf(f,indent,"stk(lr%d)= %s\n",i1,var->opt_name);
1408 break; 1423 break;
1409 case SCISMPOINTER: 1424 case SCISMPOINTER:
1410 case SCILPOINTER: 1425 case SCILPOINTER:
1411 case SCIBPOINTER: 1426 case SCIBPOINTER:
1412 case SCIOPOINTER: 1427 case SCIOPOINTER:
1413 case SCIMPOINTER: 1428 case SCIMPOINTER:
1414 sprintf(buf,"cre%s", SGetSciType(var->type)); 1429 sprintf(buf,"cre%s", SGetSciType(var->type));
1415 AddDeclare(DEC_LOGICAL,buf); 1430 AddDeclare(DEC_LOGICAL,buf);
1416 Fprintf(f,indent,"top = top+1\n"); 1431 Fprintf(f,indent,"top = top+1\n");
1417 Fprintf(f,indent,"rhs = rhs+1\n"); 1432 Fprintf(f,indent,"rhs = rhs+1\n");
1418 Fprintf(f,indent,"if(.not.cre%s(fname,top,lwv)) return\n", SGetSciType(var->type)); 1433 Fprintf(f,indent,"if(.not.cre%s(fname,top,lwv)) return\n", SGetSciType(var->type));
1419 break; 1434 break;
1420 case MATRIX: 1435 case MATRIX:
1421 OptvarGetSize(var->opt_name,size,data); 1436 OptvarGetSize(var->opt_name,size,data);
1422 AddDeclare(DEC_LOGICAL,"cremat"); 1437 AddDeclare(DEC_LOGICAL,"cremat");
1423 Fprintf(f,indent,"top = top+1\n"); 1438 Fprintf(f,indent,"top = top+1\n");
1424 Fprintf(f,indent,"rhs = rhs+1\n"); 1439 Fprintf(f,indent,"rhs = rhs+1\n");
1425 sprintf(str,"dat%d %s",i1,data); 1440 sprintf(str,"dat%d %s",i1,data);
1426 AddDeclare(DEC_DATA,str); 1441 AddDeclare(DEC_DATA,str);
1427 sprintf(str,"dat%d(%s)",i1,size); 1442 sprintf(str,"dat%d(%s)",i1,size);
1428 AddDeclare(DEC_DOUBLE,str); 1443 AddDeclare(DEC_DOUBLE,str);
1429 Fprintf(f,indent,"m%d = 1\n",i1); 1444 Fprintf(f,indent,"m%d = 1\n",i1);
1430 Fprintf(f,indent,"n%d = %s\n",i1,size); 1445 Fprintf(f,indent,"n%d = %s\n",i1,size);
1431 Fprintf(f,indent,"if(.not.cremat(fname,top,0,m%d,n%d,lr%d,lc%d)) return\n",i1,i1,i1,i1); 1446 Fprintf(f,indent,"if(.not.cremat(fname,top,0,m%d,n%d,lr%d,lc%d)) return\n",i1,i1,i1,i1);
1432 Fprintf(f,indent,"call dcopy(%s,dat%d,1,stk(lr%d),1)\n",size,i1,i1); 1447 Fprintf(f,indent,"call dcopy(%s,dat%d,1,stk(lr%d),1)\n",size,i1,i1);
1433 break; 1448 break;
1434 case STRING: 1449 case STRING:
1435 AddDeclare(DEC_LOGICAL,"cresmat2"); 1450 AddDeclare(DEC_LOGICAL,"cresmat2");
1436 Fprintf(f,indent,"top = top+1\n"); 1451 Fprintf(f,indent,"top = top+1\n");
1437 Fprintf(f,indent,"rhs = rhs+1\n"); 1452 Fprintf(f,indent,"rhs = rhs+1\n");
1438 Fprintf(f,indent,"nlr%d = %d\n",i1,strlen(var->opt_name)); 1453 Fprintf(f,indent,"nlr%d = %d\n",i1,strlen(var->opt_name));
1439 Fprintf(f,indent,"if(.not.cresmat2(fname,top,nlr%d,lr%d)) return\n",i1,i1,i1); 1454 Fprintf(f,indent,"if(.not.cresmat2(fname,top,nlr%d,lr%d)) return\n",i1,i1,i1);
1440 Fprintf(f,indent,"call cvstr(nlr%d,istk(lr%d),'%s',0)\n",i1,i1,var->opt_name); 1455 Fprintf(f,indent,"call cvstr(nlr%d,istk(lr%d),'%s',0)\n",i1,i1,var->opt_name);
1441 break; 1456 break;
1442 default: 1457 default:
1443 printf("Optional variable with value must be \"SCALAR\" or \"STRING\"\n"); 1458 printf("Optional variable with value must be \"SCALAR\" or \"STRING\"\n");
1444 exit(1); 1459 exit(1);
1445 break; 1460 break;
1446 } 1461 }
1447 break; 1462 break;
1448 } 1463 }
1449 Fprintf(f,--indent,"endif\n"); 1464 Fprintf(f,--indent,"endif\n");
1450 } 1465 }
1451 1466
1452 /* size checking */ 1467 /* size checking */
1453 switch(var->type) 1468 switch(var->type)
1454 { 1469 {
1455 case BMATRIX: 1470 case BMATRIX:
1456 AddDeclare(DEC_LOGICAL,"getbmat"); 1471 AddDeclare(DEC_LOGICAL,"getbmat");
1457 Fprintf(f,indent,"if(.not.getbmat(fname,top,top-rhs+%d,m%d,n%d,lr%d)) return\n",i1,i1,i1,i1); 1472 Fprintf(f,indent,"if(.not.getbmat(fname,top,top-rhs+%d,m%d,n%d,lr%d)) return\n",i1,i1,i1,i1);
1458 /* square matrix */ 1473 /* square matrix */
1459 if (var->el[0] == var->el[1]) { 1474 if (var->el[0] == var->el[1]) {
1460 /* square matrix */ 1475 /* square matrix */
1461 AddDeclare(DEC_LOGICAL,"checkval"); 1476 AddDeclare(DEC_LOGICAL,"checkval");
1462 Fprintf(f,indent,"if(.not.checkval(fname,m%d,n%d)) return\n",i1,i1); 1477 Fprintf(f,indent,"if(.not.checkval(fname,m%d,n%d)) return\n",i1,i1);
1463 } 1478 }
1464 sprintf(str,"m%d",i1); 1479 sprintf(str,"m%d",i1);
1465 Check(f,str,var,i1,0); 1480 Check(f,str,var,i1,0);
1466 sprintf(str,"n%d",i1); 1481 sprintf(str,"n%d",i1);
1467 Check(f,str,var,i1,1); 1482 Check(f,str,var,i1,1);
1468 break; 1483 break;
1469 case MATRIX: 1484 case MATRIX:
1470 case IMATRIX: 1485 case IMATRIX:
1471 AddDeclare(DEC_LOGICAL,"getmat"); 1486 AddDeclare(DEC_LOGICAL,"getmat");
1472 Fprintf(f,indent,"if(.not.getmat(fname,top,top-rhs+%d,it%d,m%d,n%d,lr%d,lc%d)) return\n",i1,i1,i1,i1,i1,i1); 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);
1473 /* square matrix */ 1488 /* square matrix */
1474 if (var->el[0] == var->el[1]) { 1489 if (var->el[0] == var->el[1]) {
1475 /* square matrix */ 1490 /* square matrix */
1476 AddDeclare(DEC_LOGICAL,"checkval"); 1491 AddDeclare(DEC_LOGICAL,"checkval");
1477 Fprintf(f,indent,"if(.not.checkval(fname,m%d,n%d)) return\n",i1,i1); 1492 Fprintf(f,indent,"if(.not.checkval(fname,m%d,n%d)) return\n",i1,i1);
1478 } 1493 }
1479 sprintf(str,"m%d",i1); 1494 sprintf(str,"m%d",i1);
1480 Check(f,str,var,i1,0); 1495 Check(f,str,var,i1,0);
1481 sprintf(str,"n%d",i1); 1496 sprintf(str,"n%d",i1);
1482 Check(f,str,var,i1,1); 1497 Check(f,str,var,i1,1);
1483 sprintf(str,"it%d",i1); 1498 sprintf(str,"it%d",i1);
1484 if (var->type == IMATRIX ) AddForName1(var->el[2],str); 1499 if (var->type == IMATRIX ) AddForName1(var->el[2],str);
1485 break; 1500 break;
1486 case SPARSE: 1501 case SPARSE:
1487 AddDeclare(DEC_LOGICAL,"getsparse"); 1502 AddDeclare(DEC_LOGICAL,"getsparse");
1488 Fprintf(f,indent,"if(.not.getsparse(fname,top,top-rhs+%d,it%d,m%d,n%d,nel%d,mnel%d,icol%d,lr%d,lc%d)) return\n",i1,i1,i1,i1,i1,i1,i1,i1,i1); 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);
1489 /* square matrix */ 1504 /* square matrix */
1490 if (var->el[0] == var->el[1]) { 1505 if (var->el[0] == var->el[1]) {
1491 /* square matrix */ 1506 /* square matrix */
1492 AddDeclare(DEC_LOGICAL,"checkval"); 1507 AddDeclare(DEC_LOGICAL,"checkval");
1493 Fprintf(f,indent,"if(.not.checkval(fname,m%d,n%d)) return\n",i1,i1); 1508 Fprintf(f,indent,"if(.not.checkval(fname,m%d,n%d)) return\n",i1,i1);
1494 } 1509 }
1495 sprintf(str,"m%d",i1); 1510 sprintf(str,"m%d",i1);
1496 Check(f,str,var,i1,0); 1511 Check(f,str,var,i1,0);
1497 sprintf(str,"n%d",i1); 1512 sprintf(str,"n%d",i1);
1498 Check(f,str,var,i1,1); 1513 Check(f,str,var,i1,1);
1499 sprintf(str,"nel%d",i1); 1514 sprintf(str,"nel%d",i1);
1500 AddForName1(var->el[2],str); 1515 AddForName1(var->el[2],str);
1501 sprintf(str,"it%d",i1); 1516 sprintf(str,"it%d",i1);
1502 AddForName1(var->el[3],str); 1517 AddForName1(var->el[3],str);
1503 break; 1518 break;
1504 case STRINGMAT: 1519 case STRINGMAT:
1505 AddDeclare(DEC_LOGICAL,"getsmat"); 1520 AddDeclare(DEC_LOGICAL,"getsmat");
1506 Fprintf(f,indent,"if(.not.getsmat(fname,top,top-rhs+%d,m%d,n%d,1,1,lr%d,nlr%d)) return\n", 1521 Fprintf(f,indent,"if(.not.getsmat(fname,top,top-rhs+%d,m%d,n%d,1,1,lr%d,nlr%d)) return\n",
1507 i1,i1,i1,i1,i1); 1522 i1,i1,i1,i1,i1);
1508 /* square matrix */ 1523 /* square matrix */
1509 if (var->el[0] == var->el[1]) { 1524 if (var->el[0] == var->el[1]) {
1510 /* square matrix */ 1525 /* square matrix */
1511 AddDeclare(DEC_LOGICAL,"checkval"); 1526 AddDeclare(DEC_LOGICAL,"checkval");
1512 Fprintf(f,indent,"if(.not.checkval(fname,m%d,n%d)) return\n",i1,i1); 1527 Fprintf(f,indent,"if(.not.checkval(fname,m%d,n%d)) return\n",i1,i1);
1513 } 1528 }
1514 sprintf(str,"m%d",i1); 1529 sprintf(str,"m%d",i1);
1515 Check(f,str,var,i1,0); 1530 Check(f,str,var,i1,0);
1516 strcpy(str1,variables[var->el[0]-1]->name); 1531 strcpy(str1,variables[var->el[0]-1]->name);
1517 sprintf(str,"n%d",i1); 1532 sprintf(str,"n%d",i1);
1518 Check(f,str,var,i1,1); 1533 Check(f,str,var,i1,1);
1519 break; 1534 break;
1520 case ROW: 1535 case ROW:
1521 AddDeclare(DEC_LOGICAL,"getvectrow"); 1536 AddDeclare(DEC_LOGICAL,"getvectrow");
1522 Fprintf(f,indent,"if(.not.getvectrow(fname,top,top-rhs+%d,it%d,m%d,n%d,lr%d,lc%d)) return\n",i1,i1,i1,i1,i1,i1); 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);
1523 sprintf(str,"n%d",i1); 1538 sprintf(str,"n%d",i1);
1524 Check(f,str,var,i1,0); 1539 Check(f,str,var,i1,0);
1525 break; 1540 break;
1526 case COLUMN: 1541 case COLUMN:
1527 AddDeclare(DEC_LOGICAL,"getvectcol"); 1542 AddDeclare(DEC_LOGICAL,"getvectcol");
1528 Fprintf(f,indent,"if(.not.getvectcol(fname,top,top-rhs+%d,it%d,m%d,n%d,lr%d,lc%d)) return\n",i1,i1,i1,i1,i1,i1); 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);
1529 sprintf(str,"m%d",i1); 1544 sprintf(str,"m%d",i1);
1530 Check(f,str,var,i1,0); 1545 Check(f,str,var,i1,0);
1531 break; 1546 break;
1532 case VECTOR: 1547 case VECTOR:
1533 AddDeclare(DEC_LOGICAL,"getvect"); 1548 AddDeclare(DEC_LOGICAL,"getvect");
1534 Fprintf(f,indent,"if(.not.getvect(fname,top,top-rhs+%d,it%d,m%d,n%d,lr%d,lc%d)) return\n",i1,i1,i1,i1,i1,i1); 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);
1535 sprintf(str,"n%d*m%d",i1,i1); 1550 sprintf(str,"n%d*m%d",i1,i1);
1536 Check(f,str,var,i1,0); 1551 Check(f,str,var,i1,0);
1537 AddForName1(var->el[0],str); 1552 AddForName1(var->el[0],str);
1538 break; 1553 break;
1539 case POLYNOM: 1554 case POLYNOM:
1540 AddDeclare(DEC_LOGICAL,"getonepoly"); 1555 AddDeclare(DEC_LOGICAL,"getonepoly");
1541 sprintf(str,"namelr%d*4",i1); 1556 sprintf(str,"namelr%d*4",i1);
1542 AddDeclare(DEC_CHAR,str); 1557 AddDeclare(DEC_CHAR,str);
1543 Fprintf(f,indent,"if(.not.getonepoly(fname,top,top-rhs+%d,it%d,m%d,namelr%d,namellr%d,lr%d,lc%d)\n",i1,i1,i1,i1,i1,i1,i1); 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);
1544 AddDeclare(DEC_LOGICAL,"checkval"); 1559 AddDeclare(DEC_LOGICAL,"checkval");
1545 sprintf(str,"m%d",i1); 1560 sprintf(str,"m%d",i1);
1546 Check(f,str,var,i1,0); 1561 Check(f,str,var,i1,0);
1547 AddForName(var->el[0],str); 1562 AddForName(var->el[0],str);
1548 break; 1563 break;
1549 case SCALAR: 1564 case SCALAR:
1550 AddDeclare(DEC_LOGICAL,"getscalar"); 1565 AddDeclare(DEC_LOGICAL,"getscalar");
1551 Fprintf(f,indent,"if(.not.getscalar(fname,top,top-rhs+%d,lr%d)) return\n",i1,i1); 1566 Fprintf(f,indent,"if(.not.getscalar(fname,top,top-rhs+%d,lr%d)) return\n",i1,i1);
1552 break; 1567 break;
1553 case SCIMPOINTER: 1568 case SCIMPOINTER:
1554 case SCISMPOINTER: 1569 case SCISMPOINTER:
1555 case SCILPOINTER: 1570 case SCILPOINTER:
1556 case SCIBPOINTER: 1571 case SCIBPOINTER:
1557 case SCIOPOINTER: 1572 case SCIOPOINTER:
1558 sprintf(buf,"get%s", SGetSciType(var->type)); 1573 sprintf(buf,"get%s", SGetSciType(var->type));
1559 AddDeclare(DEC_LOGICAL,buf); 1574 AddDeclare(DEC_LOGICAL,buf);
1560 Fprintf(f,indent,"if(.not.get%s(fname,top,top-rhs+%d,lr%d)) return\n", SGetSciType(var->type),i1,i1); 1575 Fprintf(f,indent,"if(.not.get%s(fname,top,top-rhs+%d,lr%d)) return\n", SGetSciType(var->type),i1,i1);
1561 break; 1576 break;
1562 case STRING: 1577 case STRING:
1563 AddDeclare(DEC_LOGICAL,"getsmat"); 1578 AddDeclare(DEC_LOGICAL,"getsmat");
1564 Fprintf(f,indent,"if(.not.getsmat(fname,top,top-rhs+%d,m%d,n%d,1,1,lr%d,nlr%d)) return\n",i1,i1,i1,i1,i1,i1,11); 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);
1565 AddDeclare(DEC_LOGICAL,"checkval"); 1580 AddDeclare(DEC_LOGICAL,"checkval");
1566 Fprintf(f,indent,"if(.not.checkval(fname,m%d*n%d,1)) return\n",i1,i1); 1581 Fprintf(f,indent,"if(.not.checkval(fname,m%d*n%d,1)) return\n",i1,i1);
1567 sprintf(str,"nlr%d",i1); 1582 sprintf(str,"nlr%d",i1);
1568 Check(f,str,var,i1,0); 1583 Check(f,str,var,i1,0);
1569 break; 1584 break;
1570 case ANY: 1585 case ANY:
1571 case LIST: 1586 case LIST:
1572 case TLIST: 1587 case TLIST:
1573 break; 1588 break;
1574 default: 1589 default:
1575 printf("unknown variable type %d\n",var->type); 1590 printf("unknown variable type %d\n",var->type);
1576 } 1591 }
1577} 1592}
1578 1593
1579void OptvarGetSize(optvar,size,data) 1594void OptvarGetSize(optvar,size,data)
1580 char *optvar,*size,*data; 1595char *optvar,*size,*data;
1581{ 1596{
1582 int i,j=0,ok=0; 1597 int i,j=0,ok=0;
1583 for ( i = 0 ; i < (int) strlen(optvar) ; i++ ) 1598 for ( i = 0 ; i < (int) strlen(optvar) ; i++ )
1584 { 1599 {
1585 if ( optvar[i] == ')' ) 1600 if ( optvar[i] == ')' )
1586 { 1601 {
1587 size[j++] = '\0'; break; 1602 size[j++] = '\0'; break;
1588 } 1603 }
1589 if ( ok ==1 ) size[j++]= optvar[i]; 1604 if ( ok ==1 ) size[j++]= optvar[i];
1590 if ( optvar[i] == '(' ) ok =1 ; 1605 if ( optvar[i] == '(' ) ok =1 ;
1591 } 1606 }
1592 if ( i < (int) strlen(optvar)) strcpy(data,optvar+i+1); 1607 if ( i < (int) strlen(optvar)) strcpy(data,optvar+i+1);
1593} 1608}
1594 1609
1595/* 1610/*
1596 Utility function for WriteArgCheck 1611Utility function for WriteArgCheck
1597 Check for fixed sized dimensions 1612Check for fixed sized dimensions
1598*/ 1613*/
1599 1614
1600void Check(f,str,var,i1,nel) 1615void Check(f,str,var,i1,nel)
1601 FILE *f; 1616FILE *f;
1602 char *str; 1617char *str;
1603 int i1, nel; 1618int i1, nel;
1604 VARPTR var; 1619VARPTR var;
1605{ 1620{
1606 char str1[MAXNAM]; 1621 char str1[MAXNAM];
1607 strcpy(str1,variables[var->el[nel]-1]->name); 1622 strcpy(str1,variables[var->el[nel]-1]->name);
1608 if (isdigit(str1[0]) != 0) 1623 if (isdigit(str1[0]) != 0)
1609 { 1624 {
1610 /* the dimension of the variable is a constant int */ 1625 /* the dimension of the variable is a constant int */
1611 if ( strcmp(str,str1) != 0) 1626 if ( strcmp(str,str1) != 0)
1612 { 1627 {
1613 AddDeclare(DEC_LOGICAL,"checkval"); 1628 AddDeclare(DEC_LOGICAL,"checkval");
1614 Fprintf(f,indent,"if(.not.checkval(fname,%s,%s)) return\n",str,str1); 1629 Fprintf(f,indent,"if(.not.checkval(fname,%s,%s)) return\n",str,str1);
1615 } 1630 }
1616 } 1631 }
1617 AddForName1(var->el[nel],str); 1632 AddForName1(var->el[nel],str);
1618} 1633}
1619 1634
1620 1635
1621void WriteCrossCheck(f) 1636void WriteCrossCheck(f)
1622 FILE *f; 1637FILE *f;
1623{ 1638{
1624 int i, j; 1639 int i, j;
1625 char *n1, *n2; 1640 char *n1, *n2;
1626 VARPTR var; 1641 VARPTR var;
1627 FCprintf(f,"c \n"); 1642 FCprintf(f,"c \n");
1628 FCprintf(f,"c cross variable size checking\n"); 1643 FCprintf(f,"c cross variable size checking\n");
1629 FCprintf(f,"c \n"); 1644 FCprintf(f,"c \n");
1630 for (i = 0; i < nVariable; i++) { 1645 for (i = 0; i < nVariable; i++) {
1631 var = variables[i]; 1646 var = variables[i];
1632 /* does not check list elements */ 1647 /* does not check list elements */
1633 if (var->nfor_name != 0 && var->list_el == 0) { 1648 if (var->nfor_name != 0 && var->list_el == 0) {
1634 if (strncmp(var->for_name[0],"ne",2) != 0 && 1649 if (strncmp(var->for_name[0],"ne",2) != 0 &&
1635 strncmp(var->for_name[0],"me",2) != 0) { 1650 strncmp(var->for_name[0],"me",2) != 0) {
1636 n1 = Forname2Int(var->for_name[0]); 1651 n1 = Forname2Int(var->for_name[0]);
1637 for (j = 1; j < var->nfor_name; j++) { 1652 for (j = 1; j < var->nfor_name; j++) {
1638 n2 = Forname2Int(var->for_name[j]); 1653 n2 = Forname2Int(var->for_name[j]);
1639 if ( strcmp(n1,n2) != 0) 1654 if ( strcmp(n1,n2) != 0)
1640 { 1655 {
1641 AddDeclare(DEC_LOGICAL,"checkval"); 1656 AddDeclare(DEC_LOGICAL,"checkval");
1642 Fprintf(f,indent,"if(.not.checkval(fname,%s,%s)) return\n",n1,n2); 1657 Fprintf(f,indent,"if(.not.checkval(fname,%s,%s)) return\n",n1,n2);
1643 } 1658 }
1644 } 1659 }
1645 } 1660 }
1661 }
1646 } 1662 }
1647 } 1663 /* FCprintf(f,"c \n");
1648 /* FCprintf(f,"c \n"); 1664 FCprintf(f,"c cross formal parameter checking\n");
1649 FCprintf(f,"c cross formal parameter checking\n"); 1665 FCprintf(f,"c not implemented yet\n"); */
1650 FCprintf(f,"c not implemented yet\n"); */
1651} 1666}
1652 1667
1653void WriteEqualCheck(f) 1668void WriteEqualCheck(f)
1654 FILE *f; 1669FILE *f;
1655{ 1670{
1656 /* FCprintf(f,"c \n"); 1671 /* FCprintf(f,"c \n");
1657 FCprintf(f,"c cross equal output variable checking\n"); 1672 FCprintf(f,"c cross equal output variable checking\n");
1658 FCprintf(f,"c not implemented yet\n"); */ 1673 FCprintf(f,"c not implemented yet\n"); */
1659} 1674}
1660 1675
1661void WriteFortranCall(f) 1676void WriteFortranCall(f)
1662 FILE *f; 1677FILE *f;
1663{ 1678{
1664 int i, j, ind; 1679 int i, j, ind;
1665 IVAR ivar, iivar; 1680 IVAR ivar, iivar;
1666 char call[MAXCALL]; 1681 char call[MAXCALL];
1667 char str1[8],str2[8]; 1682 char str1[8],str2[8];
1668 sprintf(call,"call %s(",forsub->name); 1683 sprintf(call,"call %s(",forsub->name);
1669 /* loop on FORTRAN arguments */ 1684 /* loop on FORTRAN arguments */
1670 for (i = 0; i < forsub->narg; i++) 1685 for (i = 0; i < forsub->narg; i++)
1671 { 1686 {
1672 ivar = forsub->arg[i]; 1687 ivar = forsub->arg[i];
1673 ind = 0; 1688 ind = 0;
1674 if (variables[ivar-1]->list_el != 0) 1689 if (variables[ivar-1]->list_el != 0)
1675 { 1690 {
1676 /* FORTRAN argument is a list element */ 1691 /* FORTRAN argument is a list element */
1677 iivar = GetExistVar(variables[ivar-1]->list_name); 1692 iivar = GetExistVar(variables[ivar-1]->list_name);
1678 for (j = 0; j < basfun->nin; j++) 1693 for (j = 0; j < basfun->nin; j++)
1679 { 1694 {
1680 if (iivar == basfun->in[j]) 1695 if (iivar == basfun->in[j])
1681 { 1696 {
1682 /* it must be a SCILAB argument */ 1697 /* it must be a SCILAB argument */
1683 sprintf(str1,"%de%d",iivar,variables[ivar-1]->list_el); 1698 sprintf(str1,"%de%d",iivar,variables[ivar-1]->list_el);
1684 sprintf(str2,"%de%d",iivar,variables[ivar-1]->list_el); 1699 sprintf(str2,"%de%d",iivar,variables[ivar-1]->list_el);
1685 WriteCallConvertion(f,ivar,str2,str1,call); 1700 WriteCallConvertion(f,ivar,str2,str1,call);
1686 ind = 1; 1701 ind = 1;
1687 break; 1702 break;
1688 } 1703 }
1689 } 1704 }
1690 if (ind == 0) 1705 if (ind == 0)
1691 { 1706 {
1692 printf("list or tlist \"%s\" must be an argument of SCILAB function\n", 1707 printf("list or tlist \"%s\" must be an argument of SCILAB function\n",
1693 variables[ivar-1]->list_name); 1708 variables[ivar-1]->list_name);
1694 exit(1); 1709 exit(1);
1695 } 1710 }
1696 } 1711 }
1697 else 1712 else
1698 { 1713 {
1699 for (j = 0; j < basfun->nin; j++) 1714 for (j = 0; j < basfun->nin; j++)
1700 { 1715 {
1701 if (ivar == basfun->in[j]) 1716 if (ivar == basfun->in[j])
1702 { 1717 {
1703 /* FORTRAN argument is a SCILAB argument */ 1718 /* FORTRAN argument is a SCILAB argument */
1704 sprintf(str1,"%d",j+1); 1719 sprintf(str1,"%d",j+1);
1705 sprintf(str2,"%d",i+1); 1720 sprintf(str2,"%d",i+1);
1706 WriteCallConvertion(f,ivar,str2,str1,call); 1721 WriteCallConvertion(f,ivar,str2,str1,call);
1707 ind = 1; 1722 ind = 1;
1708 break; 1723 break;
1709 } 1724 }
1710 } 1725 }
1711 } 1726 }
1712 if (ind == 0) 1727 if (ind == 0)
1713 { 1728 {
1714 /* FORTRAN argument is not a SCILAB argument */ 1729 /* FORTRAN argument is not a SCILAB argument */
1715 WriteCallRest(f,ivar,i+1,call); 1730 WriteCallRest(f,ivar,i+1,call);
1716 } 1731 }
1717 } 1732 }
1718 if (forsub->narg == 0) 1733 if (forsub->narg == 0)
1719 strcat(call,")"); 1734 strcat(call,")");
1720 else 1735 else
1721 call[strlen(call)-1] = ')'; 1736 call[strlen(call)-1] = ')';
1722 Fprintf(f,indent,call); 1737 Fprintf(f,indent,call);
1723 Fprintf(f,indent,"\n"); 1738 Fprintf(f,indent,"\n");
1724 /* 1739 /*
1725 Fprintf(f,indent++,"if(err .gt. 0) then\n"); 1740 Fprintf(f,indent++,"if(err .gt. 0) then\n");
1726 Fprintf(f,indent,"buf = fname // ' Internal Error'\n"); 1741 Fprintf(f,indent,"buf = fname // ' Internal Error'\n");
1727 Fprintf(f,indent,"call error(999)\n"); 1742 Fprintf(f,indent,"call error(999)\n");
1728 Fprintf(f,indent,"return\n"); 1743 Fprintf(f,indent,"return\n");
1729 Fprintf(f,--indent,"endif\n"); 1744 Fprintf(f,--indent,"endif\n");
1730 */ 1745 */
1731 Fprintf(f,indent,"if(err .gt. 0 .or. err1 .gt. 0) return\n"); 1746 Fprintf(f,indent,"if(err .gt. 0 .or. err1 .gt. 0) return\n");
1732 1747
1733 FCprintf(f,"c\n"); 1748 FCprintf(f,"c\n");
1734} 1749}
1735 1750
1736/* 1751/*
1737 Convertion to a Fortran type before caling sequence 1752Convertion to a Fortran type before caling sequence
1738 for arguments coming from the scilab stack 1753for arguments coming from the scilab stack
1739 the part of the caing sequence is adde to the buffer call 1754the part of the caing sequence is adde to the buffer call
1740*/ 1755*/
1741 1756
1742void WriteCallConvertion(f,ivar,farg,barg,call) 1757void WriteCallConvertion(f,ivar,farg,barg,call)
1743 FILE *f; 1758FILE *f;
1744 IVAR ivar; 1759IVAR ivar;
1745 char *farg; 1760char *farg;
1746 char *barg; 1761char *barg;
1747 char *call; 1762char *call;
1748{ 1763{
1749 VARPTR var = variables[ivar-1]; 1764 VARPTR var = variables[ivar-1];
1750 char str[MAXNAM]; 1765 char str[MAXNAM];
1751 char str1[MAXNAM]; 1766 char str1[MAXNAM];
1752 switch (var->type) 1767 switch (var->type)
1753 { 1768 {
1754 case POLYNOM: 1769 case POLYNOM:
1755 case ROW: 1770 case ROW:
@@ -1759,1534 +1774,1534 @@ void WriteCallConvertion(f,ivar,farg,barg,call)
1759 case IMATRIX: 1774 case IMATRIX:
1760 case MATRIX: 1775 case MATRIX:
1761 case SPARSE: 1776 case SPARSE:
1762 switch ( var->type ) 1777 switch ( var->type )
1763 { 1778 {
1764 case POLYNOM: sprintf(str1,"n%s",barg); break; 1779 case POLYNOM: sprintf(str1,"n%s",barg); break;
1765 case COLUMN: sprintf(str1,"m%s",barg); break ; 1780 case COLUMN: sprintf(str1,"m%s",barg); break ;
1766 case VECTOR: sprintf(str1,"m%s*n%s",barg,barg); break ; 1781 case VECTOR: sprintf(str1,"m%s*n%s",barg,barg); break ;
1767 case SCALAR: sprintf(str1,"1"); break ; 1782 case SCALAR: sprintf(str1,"1"); break ;
1768 case ROW: sprintf(str1,"n%s",barg); break; 1783 case ROW: sprintf(str1,"n%s",barg); break;
1769 case SPARSE: sprintf(str1,"nel%s",barg);break; 1784 case SPARSE: sprintf(str1,"nel%s",barg);break;
1770 case IMATRIX: 1785 case IMATRIX:
1771 case MATRIX: sprintf(str1,"n%s*m%s",barg,barg); break; 1786 case MATRIX: sprintf(str1,"n%s*m%s",barg,barg); break;
1772 } 1787 }
1773 switch (var->for_type) 1788 switch (var->for_type)
1774 { 1789 {
1775 case CHAR: 1790 case CHAR:
1776 case CSTRINGV: 1791 case CSTRINGV:
1777 printf("incompatibility between the variable type and the FORTRAN type for variable \"%s\"\n",var->name); 1792 printf("incompatibility between the variable type and the FORTRAN type for variable \"%s\"\n",var->name);
1778 exit(1); 1793 exit(1);
1779 case INT: 1794 case INT:
1780 Fprintf(f,indent,"call entier(%s,stk(lr%s),istk(iadr(lr%s)))\n",str1,barg,barg); 1795 Fprintf(f,indent,"call entier(%s,stk(lr%s),istk(iadr(lr%s)))\n",str1,barg,barg);
1781 if (var->type == IMATRIX || var->type == SPARSE) 1796 if (var->type == IMATRIX || var->type == SPARSE)
1782 { 1797 {
1783 Fprintf(f,indent++,"if (it%s.eq.1) then\n",barg); 1798 Fprintf(f,indent++,"if (it%s.eq.1) then\n",barg);
1784 Fprintf(f,indent,"call entier(%s,stk(lc%s),istk(iadr(lc%s)))\n",str1,barg,barg); 1799 Fprintf(f,indent,"call entier(%s,stk(lc%s),istk(iadr(lc%s)))\n",str1,barg,barg);
1785 Fprintf(f,--indent,"endif\n"); 1800 Fprintf(f,--indent,"endif\n");
1786 if ( var->type == SPARSE) 1801 if ( var->type == SPARSE)
1787 sprintf(str,"it%s,m%s,n%s,nel%s,istk(mnel%s),istk(icol%s),istk(iadr(lr%s)),istk(iadr(lc%s))" 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))"
1788 ,barg,barg,barg,barg,barg,barg,barg,barg); 1803 ,barg,barg,barg,barg,barg,barg,barg,barg);
1789 else 1804 else
1790 sprintf(str,"istk(iadr(lr%s)),istk(iadr(lc%s)),it%s",barg,barg,barg); 1805 sprintf(str,"istk(iadr(lr%s)),istk(iadr(lc%s)),it%s",barg,barg,barg);
1791 ChangeForName(ivar,str); 1806 ChangeForName(ivar,str);
1792 strcat(call,str); 1807 strcat(call,str);
1793 strcat(call,","); 1808 strcat(call,",");
1794 } 1809 }
1795 else 1810 else
1796 { 1811 {
1797 sprintf(str,"istk(iadr(lr%s))",barg); 1812 sprintf(str,"istk(iadr(lr%s))",barg);
1798 ChangeForName(ivar,str); 1813 ChangeForName(ivar,str);
1799 strcat(call,str); 1814 strcat(call,str);
1800 strcat(call,","); 1815 strcat(call,",");
1801 } 1816 }
1802 break; 1817 break;
1803 case REAL: 1818 case REAL:
1804 Fprintf(f,indent,"call simple(%s,stk(lr%s),stk(lr%s))\n",str1,barg,barg,barg); 1819 Fprintf(f,indent,"call simple(%s,stk(lr%s),stk(lr%s))\n",str1,barg,barg,barg);
1805 if (var->type == IMATRIX || var->type == SPARSE) 1820 if (var->type == IMATRIX || var->type == SPARSE)
1806 { 1821 {
1807 Fprintf(f,indent++,"if (it%s.eq.1) then\n",barg); 1822 Fprintf(f,indent++,"if (it%s.eq.1) then\n",barg);
1808 Fprintf(f,indent,"call simple(%s,stk(lc%s),stk(lc%s))\n",str1,barg,barg); 1823 Fprintf(f,indent,"call simple(%s,stk(lc%s),stk(lc%s))\n",str1,barg,barg);
1809 Fprintf(f,--indent,"endif\n"); 1824 Fprintf(f,--indent,"endif\n");
1810 if ( var->type == SPARSE) 1825 if ( var->type == SPARSE)
1811 sprintf(str,"it%s,m%s,n%s,nel%s,istk(mnel%s),istk(icol%s),stk(lr%s),stk(lc%s)," 1826 sprintf(str,"it%s,m%s,n%s,nel%s,istk(mnel%s),istk(icol%s),stk(lr%s),stk(lc%s),"
1812 ,barg,barg,barg,barg,barg,barg,barg,barg); 1827 ,barg,barg,barg,barg,barg,barg,barg,barg);
1813 else 1828 else
1814 sprintf(str,"stk(lr%s),stk(lc%s),it%s,",barg,barg,barg); 1829 sprintf(str,"stk(lr%s),stk(lc%s),it%s,",barg,barg,barg);
1815 strcat(call,str); 1830 strcat(call,str);
1816 } 1831 }
1817 else 1832 else
1818 { 1833 {
1819 sprintf(str,"stk(lr%s),",barg); 1834 sprintf(str,"stk(lr%s),",barg);
1820 strcat(call,str); 1835 strcat(call,str);
1821 } 1836 }
1822 break; 1837 break;
1823 case DOUBLE: 1838 case DOUBLE:
1824 if (var->type == IMATRIX) 1839 if (var->type == IMATRIX)
1825 { 1840 {
1826 sprintf(str,"stk(lr%s),stk(lc%s),it%s,",barg,barg,barg); 1841 sprintf(str,"stk(lr%s),stk(lc%s),it%s,",barg,barg,barg);
1827 strcat(call,str); 1842 strcat(call,str);
1828 } 1843 }
1829 else if (var->type == SPARSE) 1844 else if (var->type == SPARSE)
1830 { 1845 {
1831 sprintf(str,"it%s,m%s,n%s,nel%s,istk(mnel%s),istk(icol%s),stk(lr%s),stk(lc%s)," 1846 sprintf(str,"it%s,m%s,n%s,nel%s,istk(mnel%s),istk(icol%s),stk(lr%s),stk(lc%s),"
1832 ,barg,barg,barg,barg,barg,barg,barg,barg); 1847 ,barg,barg,barg,barg,barg,barg,barg,barg);
1833 strcat(call,str); 1848 strcat(call,str);
1834 } 1849 }
1835 else 1850 else
1836 { 1851 {
1837 sprintf(str,"stk(lr%s),",barg); 1852 sprintf(str,"stk(lr%s),",barg);
1838 strcat(call,str); 1853 strcat(call,str);
1839 } 1854 }
1840 break; 1855 break;
1841 } 1856 }
1842 break; 1857 break;
1843 case BMATRIX: 1858 case BMATRIX:
1844 sprintf(str1,"n%s*m%s",barg,barg); 1859 sprintf(str1,"n%s*m%s",barg,barg);
1845 if (var->for_type != INT) 1860 if (var->for_type != INT)
1846 { 1861 {
1847 printf("incompatibility between the type %s and FORTRAN type %s for variable \"%s\"\n", 1862 printf("incompatibility between the type %s and FORTRAN type %s for variable \"%s\"\n",
1848 SGetSciType(var->type),SGetForType(var->for_type),var->name); 1863 SGetSciType(var->type),SGetForType(var->for_type),var->name);
1849 exit(1); 1864 exit(1);
1850 } 1865 }
1851 sprintf(str,"istk(lr%s)",barg); 1866 sprintf(str,"istk(lr%s)",barg);
1852 ChangeForName(ivar,str); 1867 ChangeForName(ivar,str);
1853 strcat(call,str); 1868 strcat(call,str);
1854 strcat(call,","); 1869 strcat(call,",");
1855 break; 1870 break;
1856 case SCIMPOINTER: 1871 case SCIMPOINTER:
1857 if (var->for_type != MPOINTER) 1872 if (var->for_type != MPOINTER)
1858 { 1873 {
1859 printf("incompatibility between the type %s and FORTRAN type %s for variable \"%s\"\n", 1874 printf("incompatibility between the type %s and FORTRAN type %s for variable \"%s\"\n",
1860 SGetSciType(var->type),SGetForType(var->for_type),var->name); 1875 SGetSciType(var->type),SGetForType(var->for_type),var->name);
1861 exit(1); 1876 exit(1);
1862 } 1877 }
1863 sprintf(str,"stk(lr%s),",barg); 1878 sprintf(str,"stk(lr%s),",barg);
1864 strcat(call,str); 1879 strcat(call,str);
1865 break; 1880 break;
1866 case SCISMPOINTER: 1881 case SCISMPOINTER:
1867 if (var->for_type != SMPOINTER) 1882 if (var->for_type != SMPOINTER)
1868 { 1883 {
1869 printf("incompatibility between the type %s and FORTRAN type %s for variable \"%s\"\n", 1884 printf("incompatibility between the type %s and FORTRAN type %s for variable \"%s\"\n",
1870 SGetSciType(var->type),SGetForType(var->for_type),var->name); 1885 SGetSciType(var->type),SGetForType(var->for_type),var->name);
1871 exit(1); 1886 exit(1);
1872 } 1887 }
1873 sprintf(str,"stk(lr%s),",barg); 1888 sprintf(str,"stk(lr%s),",barg);
1874 strcat(call,str); 1889 strcat(call,str);
1875 break; 1890 break;
1876 case SCILPOINTER: 1891 case SCILPOINTER:
1877 if (var->for_type != LPOINTER) 1892 if (var->for_type != LPOINTER)
1878 { 1893 {
1879 printf("incompatibility between the type %s and FORTRAN type %s for variable \"%s\"\n", 1894 printf("incompatibility between the type %s and FORTRAN type %s for variable \"%s\"\n",
1880 SGetSciType(var->type),SGetForType(var->for_type),var->name); 1895 SGetSciType(var->type),SGetForType(var->for_type),var->name);
1881 exit(1); 1896 exit(1);
1882 } 1897 }
1883 sprintf(str,"stk(lr%s),",barg); 1898 sprintf(str,"stk(lr%s),",barg);
1884 strcat(call,str); 1899 strcat(call,str);
1885 break; 1900 break;
1886 case SCIBPOINTER: 1901 case SCIBPOINTER:
1887 if (var->for_type != BPOINTER) 1902 if (var->for_type != BPOINTER)
1888 { 1903 {
1889 printf("incompatibility between the type %s and FORTRAN type %s for variable \"%s\"\n", 1904 printf("incompatibility between the type %s and FORTRAN type %s for variable \"%s\"\n",
1890 SGetSciType(var->type),SGetForType(var->for_type),var->name); 1905 SGetSciType(var->type),SGetForType(var->for_type),var->name);
1891 exit(1); 1906 exit(1);
1892 } 1907 }
1893 sprintf(str,"stk(lr%s),",barg); 1908 sprintf(str,"stk(lr%s),",barg);
1894 strcat(call,str); 1909 strcat(call,str);
1895 break; 1910 break;
1896 case SCIOPOINTER: 1911 case SCIOPOINTER:
1897 if (var->for_type != OPOINTER) 1912 if (var->for_type != OPOINTER)
1898 { 1913 {
1899 printf("incompatibility between the type %s and FORTRAN type %s for variable \"%s\"\n", 1914 printf("incompatibility between the type %s and FORTRAN type %s for variable \"%s\"\n",
1900 SGetSciType(var->type),SGetForType(var->for_type),var->name); 1915 SGetSciType(var->type),SGetForType(var->for_type),var->name);
1901 exit(1); 1916 exit(1);
1902 } 1917 }
1903 sprintf(str,"stk(lr%s),",barg); 1918 sprintf(str,"stk(lr%s),",barg);
1904 strcat(call,str); 1919 strcat(call,str);
1905 break; 1920 break;
1906 case STRINGMAT: 1921 case STRINGMAT:
1907 if (var->for_type != CSTRINGV) 1922 if (var->for_type != CSTRINGV)
1908 { 1923 {
1909 printf("incompatibility between the type %s and FORTRAN type %s for variable \"%s\"\n", 1924 printf("incompatibility between the type %s and FORTRAN type %s for variable \"%s\"\n",
1910 SGetSciType(STRINGMAT),SGetForType(var->for_type),var->name); 1925 SGetSciType(STRINGMAT),SGetForType(var->for_type),var->name);
1911 exit(1); 1926 exit(1);
1912 } 1927 }
1913 AddDeclare(DEC_LOGICAL,"crestringv"); 1928 AddDeclare(DEC_LOGICAL,"crestringv");
1914 Fprintf(f,indent,"if(.not.crestringv(fname,top+%d,lr%s-5-m%s*n%s,lw%s)) return\n",icre++,barg,barg,barg,farg); 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);
1915 sprintf(str,"stk(lw%s),",farg); 1930 sprintf(str,"stk(lw%s),",farg);
1916 strcat(call,str); 1931 strcat(call,str);
1917 break; 1932 break;
1918 case LIST: 1933 case LIST:
1919 case TLIST: 1934 case TLIST:
1920 case SEQUENCE: 1935 case SEQUENCE:
1921 printf("a FORTRAN argument cannot have a variable type of \"LIST\"\n"); 1936 printf("a FORTRAN argument cannot have a variable type of \"LIST\"\n");
1922 printf(" \"TLIST\" or \"SEQUENCE\"\n"); 1937 printf(" \"TLIST\" or \"SEQUENCE\"\n");
1923 exit(1); 1938 exit(1);
1924 break; 1939 break;
1925 case STRING: 1940 case STRING:
1926 if (var->for_type != CHAR) 1941 if (var->for_type != CHAR)
1927 { 1942 {
1928 printf("incompatibility between the type %s and FORTRAN type %s for variable \"%s\"\n", 1943 printf("incompatibility between the type %s and FORTRAN type %s for variable \"%s\"\n",
1929 SGetSciType(STRING),SGetForType(var->for_type),var->name); 1944 SGetSciType(STRING),SGetForType(var->for_type),var->name);
1930 exit(1); 1945 exit(1);
1931 } 1946 }
1932 AddDeclare(DEC_LOGICAL,"bufstore"); 1947 AddDeclare(DEC_LOGICAL,"bufstore");
1933 Fprintf(f,indent,"if(.not.bufstore(fname,lbuf,lbufi%s,lbuff%s,lr%s,nlr%s)) return\n",farg,farg,barg,barg); 1948 Fprintf(f,indent,"if(.not.bufstore(fname,lbuf,lbufi%s,lbuff%s,lr%s,nlr%s)) return\n",farg,farg,barg,barg);
1934 sprintf(str,"buf(lbufi%s:lbuff%s),",farg,farg); 1949 sprintf(str,"buf(lbufi%s:lbuff%s),",farg,farg);
1935 strcat(call,str); 1950 strcat(call,str);
1936 break; 1951 break;
1937 case ANY: 1952 case ANY:
1938 sprintf(str,"istk(il%s),",barg); 1953 sprintf(str,"istk(il%s),",barg);
1939 strcat(call,str); 1954 strcat(call,str);
1940 break; 1955 break;
1941 } 1956 }
1942} 1957}
1943 1958
1944/* 1959/*
1945 Calling sequence for variables not coming from the 1960Calling sequence for variables not coming from the
1946 scilab calling sequence 1961scilab calling sequence
1947 working or output variables 1962working or output variables
1948*/ 1963*/
1949 1964
1950void WriteCallRest(f,ivar,farg,call) 1965void WriteCallRest(f,ivar,farg,call)
1951 FILE *f; 1966FILE *f;
1952 IVAR ivar; 1967IVAR ivar;
1953 int farg; 1968int farg;
1954 char *call; 1969char *call;
1955{ 1970{
1956 VARPTR var = variables[ivar-1]; 1971 VARPTR var = variables[ivar-1];
1957 char str[MAXNAM]; 1972 char str[MAXNAM];
1958 char str1[MAXNAM]; 1973 char str1[MAXNAM];
1959 char str2[MAXNAM]; 1974 char str2[MAXNAM];
1960 char str3[MAXNAM]; 1975 char str3[MAXNAM];
1961 char str4[MAXNAM]; 1976 char str4[MAXNAM];
1962 switch (var->type) 1977 switch (var->type)
1963 { 1978 {
1964 case 0: 1979 case 0:
1965 /* FORTRAN argument is the dimension of an output variable with EXTERNAL type */ 1980 /* FORTRAN argument is the dimension of an output variable with EXTERNAL type */
1966 if (var->nfor_name == 0 && var->for_type != PREDEF) 1981 if (var->nfor_name == 0 && var->for_type != PREDEF)
1967 { 1982 {
1968 printf("dimension variable \"%s\" is not defined\n",var->name); 1983 printf("dimension variable \"%s\" is not defined\n",var->name);
1969 exit(1); 1984 exit(1);
1970 } 1985 }
1971 switch (var->for_type) 1986 switch (var->for_type)
1972 { 1987 {
1973 case PREDEF: 1988 case PREDEF:
1974 if ( strcmp(var->name,"rhs") == 0) 1989 if ( strcmp(var->name,"rhs") == 0)
1975 sprintf(str,"rhsk"); 1990 sprintf(str,"rhsk");
1976 else 1991 else
1977 sprintf(str,"%s",var->name); 1992 sprintf(str,"%s",var->name);
1978 strcat(call,str); 1993 strcat(call,str);
1979 strcat(call,","); 1994 strcat(call,",");
1980 break; 1995 break;
1981 case 0: 1996 case 0:
1982 case INT: 1997 case INT:
1983 sprintf(str,"%s",var->for_name[0]); 1998 sprintf(str,"%s",var->for_name[0]);
1984 if ( ~isdigit(str[0])) 1999 if ( ~isdigit(str[0]))
1985 { 2000 {
1986 strcat(call,str); 2001 strcat(call,str);
1987 strcat(call,","); 2002 strcat(call,",");
1988 } 2003 }
1989 else 2004 else
1990 { 2005 {
1991 Fprintf(f,indent,"locd%d= int(%s)\n",farg,var->for_name[0]); 2006 Fprintf(f,indent,"locd%d= int(%s)\n",farg,var->for_name[0]);
1992 sprintf(str,"locd%d,",farg); 2007 sprintf(str,"locd%d,",farg);
1993 strcat(call,str); 2008 strcat(call,str);
1994 sprintf(str,"locd%d",farg); 2009 sprintf(str,"locd%d",farg);
1995 AddDeclare(DEC_INT,str); 2010 AddDeclare(DEC_INT,str);
1996 } 2011 }
1997 break; 2012 break;
1998 case DOUBLE: 2013 case DOUBLE:
1999 Fprintf(f,indent,"locd%d= dble(%s)\n",farg,var->for_name[0]); 2014 Fprintf(f,indent,"locd%d= dble(%s)\n",farg,var->for_name[0]);
2000 sprintf(str,"locd%d,",farg); 2015 sprintf(str,"locd%d,",farg);
2001 strcat(call,str); 2016 strcat(call,str);
2002 sprintf(str,"locd%d",farg); 2017 sprintf(str,"locd%d",farg);
2003 AddDeclare(DEC_DOUBLE,str); 2018 AddDeclare(DEC_DOUBLE,str);
2004 break; 2019 break;
2005 case REAL: 2020 case REAL:
2006 Fprintf(f,indent,"locr%d=real(%s)\n",farg,var->for_name[0]); 2021 Fprintf(f,indent,"locr%d=real(%s)\n",farg,var->for_name[0]);
2007 sprintf(str,"locr%d,",farg); 2022 sprintf(str,"locr%d,",farg);
2008 strcat(call,str); 2023 strcat(call,str);
2009 sprintf(str,"locr%d",farg); 2024 sprintf(str,"locr%d",farg);
2010 AddDeclare(DEC_REAL,str); 2025 AddDeclare(DEC_REAL,str);
2011 break; 2026 break;
2012 case CHAR: 2027 case CHAR:
2013 case CSTRINGV: 2028 case CSTRINGV:
2014 printf("a dimension variable cannot have FORTRAN type \"%s\"\n",SGetForType(var->for_type)); 2029 printf("a dimension variable cannot have FORTRAN type \"%s\"\n",SGetForType(var->for_type));
2015 exit(1); 2030 exit(1);
2016 break; 2031 break;
2017 } 2032 }
2018 break; 2033 break;
2019 /* working or output argument (always double reservation!) */ 2034 /* working or output argument (always double reservation!) */
2020 case COLUMN: 2035 case COLUMN:
2021 case ROW: 2036 case ROW:
2022 case WORK: 2037 case WORK:
2023 case POLYNOM: 2038 case POLYNOM:
2024 case VECTOR: 2039 case VECTOR:
2025 WriteCallRestCheck(f,var,farg,"nn",0,0) ; 2040 WriteCallRestCheck(f,var,farg,"nn",0,0) ;
2026 if (var->for_type == EXTERNAL) 2041 if (var->for_type == EXTERNAL)
2027 strcpy(str1,"1"); 2042 strcpy(str1,"1");
2028 else 2043 else
2029 strcpy(str1,Forname2Int(variables[var->el[0]-1]->for_name[0])); 2044 strcpy(str1,Forname2Int(variables[var->el[0]-1]->for_name[0]));
2030 AddDeclare(DEC_LOGICAL,"cremat"); 2045 AddDeclare(DEC_LOGICAL,"cremat");
2031 Fprintf(f,indent,"if(.not.cremat(fname,top+%d,0,%s,1,lw%d,loc%d)) return\n",icre++,str1,farg,farg); 2046 Fprintf(f,indent,"if(.not.cremat(fname,top+%d,0,%s,1,lw%d,loc%d)) return\n",icre++,str1,farg,farg);
2032 sprintf(str,"stk(lw%d),",farg); 2047 sprintf(str,"stk(lw%d),",farg);
2033 strcat(call,str); 2048 strcat(call,str);
2034 break; 2049 break;
2035 case SPARSE : 2050 case SPARSE :
2036 WriteCallRestCheck(f,var,farg,"nn",0,0) ; 2051 WriteCallRestCheck(f,var,farg,"nn",0,0) ;
2037 WriteCallRestCheck(f,var,farg,"mm",1,0) ; 2052 WriteCallRestCheck(f,var,farg,"mm",1,0) ;
2038 if (var->for_type == EXTERNAL) 2053 if (var->for_type == EXTERNAL)
2039 { 2054 {
2040 strcpy(str1,"1"); 2055 strcpy(str1,"1");
2041 strcpy(str2,"1"); 2056 strcpy(str2,"1");
2042 Fprintf(f,indent,"if(.not.cremat(fname,top+%d,0,%s,%s,lw%d,lwc%d)) return\n",icre++,str1,str2,farg,farg); 2057 Fprintf(f,indent,"if(.not.cremat(fname,top+%d,0,%s,%s,lw%d,lwc%d)) return\n",icre++,str1,str2,farg,farg);
2043 AddDeclare(DEC_LOGICAL,"cremat"); 2058 AddDeclare(DEC_LOGICAL,"cremat");
2044 sprintf(str,"stk(lw%d),",farg); 2059 sprintf(str,"stk(lw%d),",farg);
2045 strcat(call,str); 2060 strcat(call,str);
2046 } 2061 }
2047 else 2062 else
2048 { 2063 {
2049 sprintf(str1,"%s",Forname2Int(variables[var->el[0]-1]->for_name[0])); 2064 sprintf(str1,"%s",Forname2Int(variables[var->el[0]-1]->for_name[0]));
2050 sprintf(str2,"%s",Forname2Int(variables[var->el[1]-1]->for_name[0])); 2065 sprintf(str2,"%s",Forname2Int(variables[var->el[1]-1]->for_name[0]));
2051 sprintf(str3,"%s",Forname2Int(variables[var->el[2]-1]->for_name[0])); 2066 sprintf(str3,"%s",Forname2Int(variables[var->el[2]-1]->for_name[0]));
2052 sprintf(str4,"%s",Forname2Int(variables[var->el[3]-1]->for_name[0])); 2067 sprintf(str4,"%s",Forname2Int(variables[var->el[3]-1]->for_name[0]));
2053 AddDeclare(DEC_LOGICAL,"cresparse"); 2068 AddDeclare(DEC_LOGICAL,"cresparse");
2054 Fprintf(f,indent,"if(.not.cresparse(fname,top+%d,%s,%s,%s,%s,mnel%d,icol%d,lw%d,lwc%d)) return\n",icre++,str4,str1,str2,str3,farg,farg,farg,farg); 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);
2055 sprintf(str,"%s,%s,%s,%s,istk(mnel%d),istk(icol%d),stk(lw%d),stk(lwc%d),", 2070 sprintf(str,"%s,%s,%s,%s,istk(mnel%d),istk(icol%d),stk(lw%d),stk(lwc%d),",
2056 str4,str1,str2,str3,farg,farg,farg,farg); 2071 str4,str1,str2,str3,farg,farg,farg,farg);
2057 strcat(call,str); 2072 strcat(call,str);
2058 } 2073 }
2059 break; 2074 break;
2060 case IMATRIX: 2075 case IMATRIX:
2061 WriteCallRestCheck(f,var,farg,"nn",0,0) ; 2076 WriteCallRestCheck(f,var,farg,"nn",0,0) ;
2062 WriteCallRestCheck(f,var,farg,"mm",1,0) ; 2077 WriteCallRestCheck(f,var,farg,"mm",1,0) ;
2063 if (var->for_type == EXTERNAL) 2078 if (var->for_type == EXTERNAL)
2064 { 2079 {
2065 strcpy(str1,"1"); 2080 strcpy(str1,"1");
2066 strcpy(str2,"1"); 2081 strcpy(str2,"1");
2067 strcpy(str3,"1"); 2082 strcpy(str3,"1");
2068 } 2083 }
2069 else 2084 else
2070 { 2085 {
2071 sprintf(str1,"%s",Forname2Int(variables[var->el[0]-1]->for_name[0])); 2086 sprintf(str1,"%s",Forname2Int(variables[var->el[0]-1]->for_name[0]));
2072 sprintf(str2,"%s",Forname2Int(variables[var->el[1]-1]->for_name[0])); 2087 sprintf(str2,"%s",Forname2Int(variables[var->el[1]-1]->for_name[0]));
2073 sprintf(str3,"%s",Forname2Int(variables[var->el[2]-1]->for_name[0])); 2088 sprintf(str3,"%s",Forname2Int(variables[var->el[2]-1]->for_name[0]));
2074 }; 2089 };
2075 AddDeclare(DEC_LOGICAL,"cremat"); 2090 AddDeclare(DEC_LOGICAL,"cremat");
2076 Fprintf(f,indent,"if(.not.cremat(fname,top+%d,%s,%s,%s,lw%d,lwc%d)) return\n",icre++,str3,str1,str2,farg,farg); 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);
2077 sprintf(str3,"%s",Forname2Int(variables[var->el[2]-1]->for_name[0])); 2092 sprintf(str3,"%s",Forname2Int(variables[var->el[2]-1]->for_name[0]));
2078 sprintf(str,"stk(lw%d),stk(lwc%d),%s,",farg,farg,str3); 2093 sprintf(str,"stk(lw%d),stk(lwc%d),%s,",farg,farg,str3);
2079 strcat(call,str); 2094 strcat(call,str);
2080 break; 2095 break;
2081 case MATRIX: 2096 case MATRIX:
2082 WriteCallRestCheck(f,var,farg,"nn",0,0) ; 2097 WriteCallRestCheck(f,var,farg,"nn",0,0) ;
2083 WriteCallRestCheck(f,var,farg,"mm",1,0) ; 2098 WriteCallRestCheck(f,var,farg,"mm",1,0) ;
2084 if (var->for_type == EXTERNAL) 2099 if (var->for_type == EXTERNAL)
2085 { 2100 {
2086 strcpy(str1,"1"); 2101 strcpy(str1,"1");
2087 strcpy(str2,"1"); 2102 strcpy(str2,"1");
2088 } 2103 }
2089 else 2104 else
2090 { 2105 {
2091 sprintf(str1,"%s",Forname2Int(variables[var->el[0]-1]->for_name[0])); 2106 sprintf(str1,"%s",Forname2Int(variables[var->el[0]-1]->for_name[0]));
2092 sprintf(str2,"%s",Forname2Int(variables[var->el[1]-1]->for_name[0])); 2107 sprintf(str2,"%s",Forname2Int(variables[var->el[1]-1]->for_name[0]));
2093 }; 2108 };
2094 AddDeclare(DEC_LOGICAL,"cremat"); 2109 AddDeclare(DEC_LOGICAL,"cremat");
2095 Fprintf(f,indent,"if(.not.cremat(fname,top+%d,0,%s,%s,lw%d,lwc%d)) return\n",icre++,str1,str2,farg,farg); 2110 Fprintf(f,indent,"if(.not.cremat(fname,top+%d,0,%s,%s,lw%d,lwc%d)) return\n",icre++,str1,str2,farg,farg);
2096 sprintf(str,"stk(lw%d),",farg); 2111 sprintf(str,"stk(lw%d),",farg);
2097 strcat(call,str); 2112 strcat(call,str);
2098 break; 2113 break;
2099 case BMATRIX: 2114 case BMATRIX:
2100 WriteCallRestCheck(f,var,farg,"nn",0,0) ; 2115 WriteCallRestCheck(f,var,farg,"nn",0,0) ;
2101 WriteCallRestCheck(f,var,farg,"mm",1,0) ; 2116 WriteCallRestCheck(f,var,farg,"mm",1,0) ;
2102 if (var->for_type == EXTERNAL) 2117 if (var->for_type == EXTERNAL)
2103 { 2118 {
2104 strcpy(str1,"1"); 2119 strcpy(str1,"1");
2105 strcpy(str2,"1"); 2120 strcpy(str2,"1");
2106 } 2121 }
2107 else 2122 else
2108 { 2123 {
2109 sprintf(str1,"%s",Forname2Int(variables[var->el[0]-1]->for_name[0])); 2124 sprintf(str1,"%s",Forname2Int(variables[var->el[0]-1]->for_name[0]));
2110 sprintf(str2,"%s",Forname2Int(variables[var->el[1]-1]->for_name[0])); 2125 sprintf(str2,"%s",Forname2Int(variables[var->el[1]-1]->for_name[0]));
2111 }; 2126 };
2112 AddDeclare(DEC_LOGICAL,"crebmat"); 2127 AddDeclare(DEC_LOGICAL,"crebmat");
2113 Fprintf(f,indent,"if(.not.crebmat(fname,top+%d,%s,%s,lw%d)) return\n",icre++,str1,str2,farg); 2128 Fprintf(f,indent,"if(.not.crebmat(fname,top+%d,%s,%s,lw%d)) return\n",icre++,str1,str2,farg);
2114 sprintf(str,"istk(lw%d),",farg); 2129 sprintf(str,"istk(lw%d),",farg);
2115 strcat(call,str); 2130 strcat(call,str);
2116 break; 2131 break;
2117 case SCIMPOINTER: 2132 case SCIMPOINTER:
2118 case SCISMPOINTER: 2133 case SCISMPOINTER:
2119 case SCILPOINTER: 2134 case SCILPOINTER:
2120 case SCIBPOINTER: 2135 case SCIBPOINTER:
2121 case SCIOPOINTER: 2136 case SCIOPOINTER:
2122 sprintf(buf,"cre%s", SGetSciType(var->type)); 2137 sprintf(buf,"cre%s", SGetSciType(var->type));
2123 AddDeclare(DEC_LOGICAL,buf); 2138 AddDeclare(DEC_LOGICAL,buf);
2124 Fprintf(f,indent,"if(.not.cre%s(fname,top+%d,lw%d)) return\n", SGetSciType(var->type),icre++,farg); 2139 Fprintf(f,indent,"if(.not.cre%s(fname,top+%d,lw%d)) return\n", SGetSciType(var->type),icre++,farg);
2125 sprintf(str,"stk(lw%d),",farg); 2140 sprintf(str,"stk(lw%d),",farg);
2126 strcat(call,str); 2141 strcat(call,str);
2127 break; 2142 break;
2128 case STRINGMAT: 2143 case STRINGMAT:
2129 if (var->for_type == EXTERNAL || var->for_type == CSTRINGV ) 2144 if (var->for_type == EXTERNAL || var->for_type == CSTRINGV )
2130 { 2145 {
2131 /* for external or cstringv parameters, unknown formal dimensions 2146 /* for external or cstringv parameters, unknown formal dimensions
2132 can be used */ 2147 can be used */
2133 WriteCallRestCheck(f,var,farg,"mm",0,1) ; 2148 WriteCallRestCheck(f,var,farg,"mm",0,1) ;
2134 WriteCallRestCheck(f,var,farg,"nn",1,1) ; 2149 WriteCallRestCheck(f,var,farg,"nn",1,1) ;
2135 sprintf(str,"mm%d",farg); 2150 sprintf(str,"mm%d",farg);
2136 AddForName1(var->el[0],str); 2151 AddForName1(var->el[0],str);
2137 sprintf(str,"nn%d",farg); 2152 sprintf(str,"nn%d",farg);
2138 AddForName1(var->el[1],str); 2153 AddForName1(var->el[1],str);
2139 AddDeclare(DEC_LOGICAL,"crepointer"); 2154 AddDeclare(DEC_LOGICAL,"crepointer");
2140 Fprintf(f,indent,"if(.not.crepointer(fname,top+%d,lw%d)) return\n",icre++,farg); 2155 Fprintf(f,indent,"if(.not.crepointer(fname,top+%d,lw%d)) return\n",icre++,farg);
2141 sprintf(str,"stk(lw%d),",farg); 2156 sprintf(str,"stk(lw%d),",farg);
2142 strcat(call,str); 2157 strcat(call,str);
2143 } 2158 }
2144 else 2159 else
2145 { 2160 {
2146 /** XXXX dimensions should be specifief **/ 2161 /** XXXX dimensions should be specifief **/
2147 fprintf(stderr,"WARNING : your code contains a specification\n"); 2162 fprintf(stderr,"WARNING : your code contains a specification\n");
2148 fprintf(stderr," not fully implemented in intersci\n"); 2163 fprintf(stderr," not fully implemented in intersci\n");
2149 WriteCallRestCheck(f,var,farg,"mm",0,0) ; 2164 WriteCallRestCheck(f,var,farg,"mm",0,0) ;
2150 WriteCallRestCheck(f,var,farg,"nn",1,0) ; 2165 WriteCallRestCheck(f,var,farg,"nn",1,0) ;
2151 AddDeclare(DEC_LOGICAL,"cresmatafaire"); 2166 AddDeclare(DEC_LOGICAL,"cresmatafaire");
2152 Fprintf(f,indent,"if(.not.cresmatafaire(fname,top+%d,lw%d)) return\n",icre++,farg); 2167 Fprintf(f,indent,"if(.not.cresmatafaire(fname,top+%d,lw%d)) return\n",icre++,farg);
2153 sprintf(str,"stk(lw%d),",farg); 2168 sprintf(str,"stk(lw%d),",farg);
2154 strcat(call,str); 2169 strcat(call,str);
2155 } 2170 }
2156 break; 2171 break;
2157 case SCALAR: 2172 case SCALAR:
2158 AddDeclare(DEC_LOGICAL,"cremat"); 2173 AddDeclare(DEC_LOGICAL,"cremat");
2159 Fprintf(f,indent,"if(.not.cremat(fname,top+%d,0,1,1,lw%d,loc%d)) return\n",icre++,farg,farg); 2174 Fprintf(f,indent,"if(.not.cremat(fname,top+%d,0,1,1,lw%d,loc%d)) return\n",icre++,farg,farg);
2160 sprintf(str,"stk(lw%d),",farg); 2175 sprintf(str,"stk(lw%d),",farg);
2161 strcat(call,str); 2176 strcat(call,str);
2162 break; 2177 break;
2163 case STRING: 2178 case STRING:
2164 WriteCallRestCheck(f,var,farg,"nn",0,0) ; 2179 WriteCallRestCheck(f,var,farg,"nn",0,0) ;
2165 if (var->for_type == EXTERNAL) 2180 if (var->for_type == EXTERNAL)
2166 { 2181 {
2167 AddDeclare(DEC_LOGICAL,"crepointer"); 2182 AddDeclare(DEC_LOGICAL,"crepointer");
2168 Fprintf(f,indent,"if(.not.crepointer(fname,top+%d,lw%d)) return\n",icre++,farg); 2183 Fprintf(f,indent,"if(.not.crepointer(fname,top+%d,lw%d)) return\n",icre++,farg);
2169 sprintf(str,"stk(lw%d),",farg); 2184 sprintf(str,"stk(lw%d),",farg);
2170 strcat(call,str); 2185 strcat(call,str);
2171 } 2186 }
2172 else 2187 else
2173 { 2188 {
2174 strcpy(str1,Forname2Int(variables[var->el[0]-1]->for_name[0])); 2189 strcpy(str1,Forname2Int(variables[var->el[0]-1]->for_name[0]));
2175 AddDeclare(DEC_LOGICAL,"cresmat2"); 2190 AddDeclare(DEC_LOGICAL,"cresmat2");
2176 Fprintf(f,indent,"if(.not.cresmat2(fname,top+%d,%s,lr%d)) return\n",icre++,str1,farg); 2191 Fprintf(f,indent,"if(.not.cresmat2(fname,top+%d,%s,lr%d)) return\n",icre++,str1,farg);
2177 AddDeclare(DEC_LOGICAL,"bufstore"); 2192 AddDeclare(DEC_LOGICAL,"bufstore");
2178 Fprintf(f,indent,"if(.not.bufstore(fname,lbuf,lbufi%d,lbuff%d,lr%d,%s)) return\n",farg,farg,farg,str1); 2193 Fprintf(f,indent,"if(.not.bufstore(fname,lbuf,lbufi%d,lbuff%d,lr%d,%s)) return\n",farg,farg,farg,str1);
2179 sprintf(str,"buf(lbufi%d:lbuff%d),",farg,farg); 2194 sprintf(str,"buf(lbufi%d:lbuff%d),",farg,farg);
2180 strcat(call,str); 2195 strcat(call,str);
2181 } 2196 }
2182 break; 2197 break;
2183 case LIST: 2198 case LIST:
2184 case TLIST: 2199 case TLIST:
2185 case SEQUENCE: 2200 case SEQUENCE:
2186 case ANY: 2201 case ANY:
2187 printf("work or output FORTRAN argument cannot have\n"); 2202 printf("work or output FORTRAN argument cannot have\n");
2188 printf(" type \"ANY\", \"LIST\", \"TLIST\" or \"SEQUENCE\"\n"); 2203 printf(" type \"ANY\", \"LIST\", \"TLIST\" or \"SEQUENCE\"\n");
2189 exit(1); 2204 exit(1);
2190 break; 2205 break;
2191 } 2206 }
2192} 2207}
2193 2208
2194/* Utility function for WriteCallRest 2209/* Utility function for WriteCallRest
2195 when flag==1 we acccept undefined dimensions 2210when flag==1 we acccept undefined dimensions
2196 this is used with stringmat/Cstringv 2211this is used with stringmat/Cstringv
2197 where dimensions and space are allocated inside 2212where dimensions and space are allocated inside
2198 the interfaced function and returned 2213the interfaced function and returned
2199 to the interface */ 2214to the interface */
2200 2215
2201void WriteCallRestCheck(f,var,farg,name,iel,flag) 2216void WriteCallRestCheck(f,var,farg,name,iel,flag)
2202 VARPTR var ; 2217VARPTR var ;
2203 FILE *f; 2218FILE *f;
2204 char *name; 2219char *name;
2205 int iel,farg,flag; 2220int iel,farg,flag;
2206{ 2221{
2207 char sdim[MAXNAM]; 2222 char sdim[MAXNAM];
2208 char str[MAXNAM]; 2223 char str[MAXNAM];
2209 int ind,j; 2224 int ind,j;
2210 if (variables[var->el[iel]-1]->nfor_name == 0) 2225 if (variables[var->el[iel]-1]->nfor_name == 0)
2211 { 2226 {
2212 strcpy(str,variables[var->el[iel]-1]->name); 2227 strcpy(str,variables[var->el[iel]-1]->name);
2213 if (isdigit(str[0]) == 0) 2228 if (isdigit(str[0]) == 0)
2214 { 2229 {
2215 ind = 0; 2230 ind = 0;
2216 for (j = 0; j < basfun->nin; j++) 2231 for (j = 0; j < basfun->nin; j++)
2217 { 2232 {
2218 if (strcmp(variables[var->el[iel]-1]->name, 2233 if (strcmp(variables[var->el[iel]-1]->name,
2219 variables[basfun->in[j]-1]->name) == 0) 2234 variables[basfun->in[j]-1]->name) == 0)
2220 { 2235 {
2221 /* dimension of FORTRAN argument is a SCILAB argument */ 2236 /* dimension of FORTRAN argument is a SCILAB argument */
2222 sprintf(sdim,"%s%d",name,farg); 2237 sprintf(sdim,"%s%d",name,farg);
2223 Fprintf(f,indent,"%s= int(stk(lr%d))\n",sdim,j+1); 2238 Fprintf(f,indent,"%s= int(stk(lr%d))\n",sdim,j+1);
2224 AddForName1(var->el[iel],sdim); 2239 AddForName1(var->el[iel],sdim);
2225 ind = 1; 2240 ind = 1;
2226 break; 2241 break;
2227 } 2242 }
2228 } 2243 }
2229 if (ind == 0 && flag != 1 ) 2244 if (ind == 0 && flag != 1 )
2230 { 2245 {
2231 /** 2246 /**
2232 printf("dimension variable \"%s\" is not defined\n", 2247 printf("dimension variable \"%s\" is not defined\n",
2233 variables[var->el[iel]-1]->name); 2248 variables[var->el[iel]-1]->name);
2234 exit(1); 2249 exit(1);
2235 **/ 2250 **/
2236 } 2251 }
2237 } 2252 }
2238 else 2253 else
2239 { 2254 {
2240 sprintf(sdim,"%s%d",name,farg); 2255 sprintf(sdim,"%s%d",name,farg);
2241 Fprintf(f,indent,"%s=%s\n",sdim,str); 2256 Fprintf(f,indent,"%s=%s\n",sdim,str);
2242 AddForName1(var->el[iel],sdim); 2257 AddForName1(var->el[iel],sdim);
2243 } 2258 }
2244 } 2259 }
2245} 2260}
2246 2261
2247void WriteOutput(f) 2262void WriteOutput(f)
2248 FILE *f; 2263FILE *f;
2249{ 2264{
2250 IVAR iout,ivar; 2265 IVAR iout,ivar;
2251 VARPTR var,vout; 2266 VARPTR var,vout;
2252 int i; 2267 int i;
2253 2268
2254 Fprintf(f,indent,"topk=top-rhs\n"); 2269 Fprintf(f,indent,"topk=top-rhs\n");
2255 AddDeclare(DEC_INT,"topl"); 2270 AddDeclare(DEC_INT,"topl");
2256 Fprintf(f,indent,"topl=top+%d\n",icre-1); 2271 Fprintf(f,indent,"topl=top+%d\n",icre-1);
2257 2272
2258 iout = GetExistOutVar(); 2273 iout = GetExistOutVar();
2259 vout = variables[iout -1]; 2274 vout = variables[iout -1];
2260 2275
2261 switch (vout->type) { 2276 switch (vout->type) {
2262 case LIST: 2277 case LIST:
2263 case TLIST: 2278 case TLIST:
2264 FCprintf(f,"c Creation of output %s\n",SGetSciType(vout->type)); 2279 FCprintf(f,"c Creation of output %s\n",SGetSciType(vout->type));
2265 Fprintf(f,indent,"top=topl+1\n"); 2280 Fprintf(f,indent,"top=topl+1\n");
2266 Fprintf(f,indent,"call cre%s(top,%d,lw)\n",SGetSciType(vout->type),vout->length); 2281 Fprintf(f,indent,"call cre%s(top,%d,lw)\n",SGetSciType(vout->type),vout->length);
2267 /* loop on output variables */ 2282 /* loop on output variables */
2268 for (i = 0; i < vout->length; i++) 2283 for (i = 0; i < vout->length; i++)
2269 { 2284 {
2270 ivar = vout->el[i]; 2285 ivar = vout->el[i];
2271 var = variables[ivar-1]; 2286 var = variables[ivar-1];
2272 FCprintf(f,"c \n"); 2287 FCprintf(f,"c \n");
2273 FCprintf(f,"c Element %d: %s\n",i+1,var->name); 2288 FCprintf(f,"c Element %d: %s\n",i+1,var->name);
2274 WriteVariable(f,var,ivar,1,i+1); 2289 WriteVariable(f,var,ivar,1,i+1);
2275 } 2290 }
2276 FCprintf(f,"c \n"); 2291 FCprintf(f,"c \n");
2277 FCprintf(f,"c Putting in order the stack\n"); 2292 FCprintf(f,"c Putting in order the stack\n");
2278 Fprintf(f,indent,"call copyobj(fname,topl+1,topk+1)\n"); 2293 Fprintf(f,indent,"call copyobj(fname,topl+1,topk+1)\n");
2279 Fprintf(f,indent,"top=topk+1\n"); 2294 Fprintf(f,indent,"top=topk+1\n");
2280 Fprintf(f,indent,"return\n"); 2295 Fprintf(f,indent,"return\n");
2281 break; 2296 break;
2282 case SEQUENCE: 2297 case SEQUENCE:
2283 /* loop on output variables */ 2298 /* loop on output variables */
2284 for (i = 0; i < vout->length; i++) 2299 for (i = 0; i < vout->length; i++)
2285 { 2300 {
2286 ivar = vout->el[i]; 2301 ivar = vout->el[i];
2287 var = variables[ivar-1]; 2302 var = variables[ivar-1];
2288 FCprintf(f,"c \n"); 2303 FCprintf(f,"c \n");
2289 Fprintf(f,indent++,"if(lhs .ge. %d) then\n",i+1); 2304 Fprintf(f,indent++,"if(lhs .ge. %d) then\n",i+1);
2290 FCprintf(f,"c --------------output variable: %s\n",var->name); 2305 FCprintf(f,"c --------------output variable: %s\n",var->name);
2291 Fprintf(f,indent,"top=topl+%d\n",i+1); 2306 Fprintf(f,indent,"top=topl+%d\n",i+1);
2292 WriteVariable(f,var,ivar,0,0); 2307 WriteVariable(f,var,ivar,0,0);
2293 Fprintf(f,--indent,"endif\n"); 2308 Fprintf(f,--indent,"endif\n");
2294 } 2309 }
2295 FCprintf(f,"c Putting in order the stack\n"); 2310 FCprintf(f,"c Putting in order the stack\n");
2296 for (i = 0; i < vout->length; i++) 2311 for (i = 0; i < vout->length; i++)
2297 { 2312 {
2298 Fprintf(f,indent++,"if(lhs .ge. %d) then\n",i+1); 2313 Fprintf(f,indent++,"if(lhs .ge. %d) then\n",i+1);
2299 Fprintf(f,indent,"call copyobj(fname,topl+%d,topk+%d)\n",i+1,i+1); 2314 Fprintf(f,indent,"call copyobj(fname,topl+%d,topk+%d)\n",i+1,i+1);
2300 Fprintf(f,--indent,"endif\n"); 2315 Fprintf(f,--indent,"endif\n");
2301 } 2316 }
2302 Fprintf(f,indent,"top=topk+lhs\n"); 2317 Fprintf(f,indent,"top=topk+lhs\n");
2303 Fprintf(f,indent,"return\n"); 2318 Fprintf(f,indent,"return\n");