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