void WriteFortranCall(FILE * f)
{
int i;
IVAR ivar, iivar;
char call[MAXCALL];
sprintf(call, "C2F(%s)(", forsub->name);
CheckCreateOrder();
/* loop on FORTRAN arguments */
for (i = 0; i < forsub->narg; i++)
{
ivar = forsub->arg[i];
if (variables[ivar - 1]->list_el != 0)
{
/* FORTRAN argument is a list element */
iivar = GetExistVar(variables[ivar - 1]->list_name);
if (variables[iivar - 1]->is_sciarg == 0)
{
printf("list or tlist \"%s\" must be an argument of SCILAB function\n", variables[ivar - 1]->list_name);
exit(1);
}
strcat(call, variables[ivar - 1]->for_name[0]);
strcat(call, ",");
}
else
{
int bCheck = 0;
if (variables[ivar - 1]->is_sciarg != 1)
{
/* FORTRAN argument is not a SCILAB argument */
/* a new variable is created on the stack for each
* Fortran argument */
(*(CRERHSTAB[variables[ivar - 1]->type].fonc)) (f, variables[ivar - 1]);
}
#ifdef _MSC_VER
_try
{
bCheck = (variables[ivar - 1]->C_name[0] != NULL);
if (bCheck)
{
char *buffertmp = _strdup(variables[ivar - 1]->C_name[0]);
if (buffertmp)
{
free(buffertmp);
buffertmp = NULL;
}
}
}
_except(EXCEPTION_EXECUTE_HANDLER)
{
bCheck = 0;
}
#else
bCheck = (variables[ivar - 1]->C_name[0] != NULL);
#endif
if (target == 'C' && bCheck)
{
strcat(call, "&");
strcat(call, variables[ivar - 1]->C_name[0]);
}
else
strcat(call, variables[ivar - 1]->for_name[0]);
strcat(call, ",");
}
}
if (forsub->narg == 0)
strcat(call, ")");
else
call[strlen(call) - 1] = ')';
if (target == 'C')
strcat(call, ";\n");
Fprintf(f, indent, call);
for (i = 0; i < nVariable; i++)
{
if (strcmp(variables[i]->name, "err") == 0)
{
AddDeclare(DEC_INT, "err=0");
Fprintf(f, indent++, "if (err > 0) {\n");
Fprintf(f, indent, "Scierror(999,\"%%s: Internal Error \\n\",fname);\n");
Fprintf(f, indent, "return 0;\n");
Fprintf(f, --indent, "};\n");
break;
}
}
}
int ReadFunction(FILE *f)
{
int i = 0, j = 0, l = 0, type = 0, ftype = 0;
char s[MAXLINE];
char *words[MAXLINE];
char *optwords[MAXLINE];
IVAR ivar = 0;
int nwords = 0, line1 = 0, inbas = 0, fline1 = 0, infor = 0, nopt = 0, out1 = 0;
nVariable = 0;
icre = 1;
basfun->maxOpt = 0;
basfun->NewMaxOpt = 0;
line1 = 1;
inbas = 0;
fline1 = 0;
infor = 0;
out1 = 0;
strcpy(s, "");
while (fgets(s, MAXLINE, f) != NULL)
{
removeEOL(s);
/* ignoring comments */
if (s[0] == '/' && s[1] == '/' ) continue;
/* analysis of one line */
if (line1 != 1)
nwords = ParseLine(s, words);
else
nwords = ParseScilabLine(s, words);
/* empty definition at end of file */
if (line1 == 1 && nwords == 0)
{
return 0;
}
/* end of description */
if (words[0][0] == '*') return(1);
if (line1 == 1)
{
/* SCILAB function description */
if ((int)strlen(words[0]) > nlgh)
{
printf("SCILAB function name too long: \"%s\"\n", words[0]);
exit(1);
}
basfun->name = (char *)malloc((unsigned)(strlen(words[0]) + 1));
strcpy(basfun->name, words[0]);
printf("**************************\n");
printf("processing SCILAB function \"%s\"\n", words[0]);
funNames[nFun] = basfun->name;
i = nwords - 1;
if (i > MAXARG)
{
printf("too may input arguments for SCILAB function\"%s\"\n",
words[0]);
printf(" augment constant \"MAXARG\" and recompile intersci\n");
exit(1);
}
basfun->nin = i;
for (i = 0; i < basfun->nin ; i++)
{
if (words[i + 1][0] == '{')
{
basfun->maxOpt++;
nopt = ParseLine(words[i + 1] + 1, optwords);
if (nopt != 2)
{
printf("Bad syntax for optional argument. Two variables needed\n");
exit(1);
}
ivar = GetVar(optwords[0], 1);
basfun->in[i] = ivar;
variables[ivar - 1]->opt_type = NAME;
variables[ivar - 1]->opt_name =
(char *)malloc((unsigned)(strlen(optwords[1]) + 1));
variables[ivar - 1]->stack_position = icre++;
strcpy(variables[ivar - 1]->opt_name, optwords[1]);
variables[ivar - 1]->is_sciarg = 1;
}
else if (words[i + 1][0] == '[')
{
basfun->maxOpt++;
nopt = ParseLine(words[i + 1] + 1, optwords);
if (nopt != 2)
{
printf("Bad syntax for optional argument. Two variables needed\n");
exit(1);
}
ivar = GetVar(optwords[0], 1);
basfun->in[i] = ivar;
variables[ivar - 1]->opt_type = VALUE;
variables[ivar - 1]->opt_name =
(char *)malloc((unsigned)(strlen(optwords[1]) + 1));
strcpy(variables[ivar - 1]->opt_name, optwords[1]);
variables[ivar - 1]->stack_position = icre++;
variables[ivar - 1]->is_sciarg = 1;
}
else
{
basfun->in[i] = GetVar(words[i + 1], 1);
variables[basfun->in[i] - 1]->stack_position = icre++;
variables[basfun->in[i] - 1]->is_sciarg = 1;
}
}
line1 = 0;
inbas = 1;
}
else if (inbas == 1)
{
if (nwords == 0)
{
/* end of SCILAB variable description */
inbas = 0;
fline1 = 1;
}
else
{
/* SCILAB variable description */
ivar = GetVar(words[0], 1);
i = ivar - 1;
if ( variables[i]->is_sciarg == 0)
{
/** we only fix stack_position for remaining arguments**/
variables[i]->stack_position = icre++;
}
if (nwords == 1)
{
printf("type missing for variable \"%s\"\n", words[0]);
exit(1);
}
type = GetBasType(words[1]);
variables[i]->type = type;
switch (type)
{
case SCALAR:
case ANY:
case SCIMPOINTER:
case SCISMPOINTER:
case SCILPOINTER:
case SCIBPOINTER:
case SCIOPOINTER:
break;
case COLUMN:
case ROW:
case STRING:
case WORK:
case VECTOR:
if (nwords != 3)
{
printf("bad type specification for variable \"%s\"\n", words[0]);
printf("only %d argument given and %d are expected\n", nwords, 3);
exit(1);
}
variables[i]->el[0] = GetVar(words[2], 1);
variables[i]->length++;
break;
case LIST:
case TLIST:
if (nwords != 3)
{
printf("bad type specification for variable \"%s\"\n", words[0]);
printf("only %d argument given and %d are expected\n", nwords, 3);
exit(1);
}
ReadListFile(words[2], words[0], i,
variables[i]->stack_position);
break;
case POLYNOM:
case MATRIX:
case BMATRIX:
case STRINGMAT:
if (nwords != 4)
{
printf("bad type specification for variable \"%s\"\n", words[0]);
printf("%d argument given and %d are expected\n", nwords, 4);
exit(1);
}
variables[i]->el[0] = GetVar(words[2], 1);
variables[i]->el[1] = GetVar(words[3], 1);
variables[i]->length = 2;
break;
case IMATRIX:
if (nwords != 5)
{
printf("bad type specification for variable \"%s\"\n", words[0]);
printf("%d argument given and %d are expected\n", nwords, 4);
exit(1);
}
variables[i]->el[0] = GetVar(words[2], 1);
variables[i]->el[1] = GetVar(words[3], 1);
variables[i]->el[2] = GetVar(words[4], 1);
variables[i]->length = 3;
break;
case SPARSE:
if (nwords != 6)
{
printf("bad type specification for variable \"%s\"\n", words[0]);
printf("%d argument given and %d are expected\n", nwords, 6);
printf("name sparse m n nel it\n");
exit(1);
}
variables[i]->el[0] = GetVar(words[2], 1);
variables[i]->el[1] = GetVar(words[3], 1);
variables[i]->el[2] = GetVar(words[4], 1);
variables[i]->el[3] = GetVar(words[5], 1);
variables[i]->length = 4;
break;
case SEQUENCE:
printf("variable \"%s\" cannot have type \"SEQUENCE\"\n",
words[0]);
exit(1);
break;
case EMPTY:
printf("variable \"%s\" cannot have type \"EMPTY\"\n",
words[0]);
exit(1);
break;
}
}
}
else if (fline1 == 1)
{
/* FORTRAN subroutine description */
forsub->name = (char *)malloc((unsigned)(strlen(words[0]) + 1));
strcpy(forsub->name, words[0]);
i = nwords - 1;
if (i > MAXARG)
{
printf("too many argument for FORTRAN subroutine \"%s\"\n",
words[0]);
printf(" augment constant \"MAXARG\" and recompile intersci\n");
exit(1);
}
forsub->narg = i;
for (i = 0; i < nwords - 1; i++)
{
forsub->arg[i] = GetExistVar(words[i + 1]);
}
fline1 = 0;
infor = 1;
}
else if (infor == 1)
{
if (nwords == 0)
{
/* end of FORTRAN subroutine description */
infor = 0;
out1 = 1;
}
else
{
/* FORTRAN variable description */
if (nwords == 1)
{
printf("type missing for FORTRAN argument \"%s\"\n",
words[0]);
exit(1);
}
ivar = GetExistVar(words[0]);
ftype = GetForType(words[1]);
variables[ivar - 1]->for_type = ftype;
if (ftype == EXTERNAL)
{
strcpy((char *)(variables[ivar - 1]->fexternal), words[1]);
switch (variables[ivar - 1]->type)
{
case LIST :
case TLIST :
case SCALAR :
case SEQUENCE :
case WORK:
case EMPTY :
case ANY:
case SCIMPOINTER :
case SCISMPOINTER :
case SCILPOINTER :
case SCIBPOINTER :
case SCIOPOINTER :
printf("FORTRAN argument \"%s\" with external type \"%s\"\n",
variables[ivar - 1]->name, words[1]);
printf(" cannot have a variable type of \"%s\"\n", SGetSciType(variables[ivar - 1]->type));
exit(1);
break;
}
}
}
}
else if (out1 == 1)
{
/* output variable description */
if (nwords == 1)
{
printf("type missing for output variable \"out\"\n");
exit(1);
}
ivar = GetOutVar(words[0]);
basfun->out = ivar;
i = ivar - 1;
type = GetBasType(words[1]);
variables[i]->type = type;
switch (type)
{
case LIST:
case TLIST:
case SEQUENCE:
l = nwords - 2;
if (l > MAXEL)
{
printf("list or sequence too long for output variable \"out\"\n");
printf(" augment constant \"MAXEL\" and recompile intersci\n");
exit(1);
}
for (j = 0; j < l; j++)
{
int k = GetExistVar(words[j + 2]);
variables[i]->el[j] = k;
variables[k - 1]->out_position = j + 1;
}
variables[i]->length = l;
break;
case EMPTY:
break;
default:
printf("output variable \"out\" of SCILAB function\n");
printf(" must have type \"LIST\", \"TLIST\", \"SEQUENCE\" or\n");
printf(" \"EMPTY\"\n");
exit(1);
break;
}
out1 = 0;
}
else
{
/* possibly equal variables */
ivar = GetExistVar(words[0]);
i = ivar - 1 ;
variables[i]->equal = GetExistVar(words[1]);
}
strcpy(s, "");
}
/* end of description file */
return(0);
}
