void GetPOLYNOM(FILE *f, VARPTR var, int flag)
{
int i1 = var->stack_position;
if (var->list_el == 0 )
{
sprintf(str1, "%d", i1);
AddDeclare(DEC_LOGICAL, "getonepoly");
AddDeclare(DEC_CHAR, str);
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);
}
else
{
sprintf(str1, "%de%d", i1, var->list_el);
AddDeclare(DEC_LOGICAL, "getlistpoly");
Fprintf(f, indent, "if(.not.getlistpoly(fname,topk,top-rhs+%d,%d,it%s,m%s,n%s,name%s,\n",
i1, var->list_el, str1, str1, str1, str1);
Fprintf(f, indent, "$ namel%s,ilp%s,lr%s,lc%s)\n", str1, str1, str1, str1);
}
Check(f, var, 0);
/* Convertion */
switch (var->for_type)
{
case INT:
Fprintf(f, indent, "call entier(n%s,stk(lr%s),istk(iadr(lr%s)))\n",
str1, str1, str1);
sprintf(str, "istk(iadr(lr%s))", str1);
ChangeForName1(var, str);
break;
case REAL:
Fprintf(f, indent, "call simple(n%s,stk(lr%s),stk(lr%s))\n",
str1, str1, str1);
sprintf(str, "stk(lr%s)", str1);
ChangeForName1(var, str);
break;
case DOUBLE:
sprintf(str, "stk(lr%s)", str1);
ChangeForName1(var, str);
break;
default:
printf("incompatibility between Scilab and Fortran type for variable \"%s\"\n",
var->name);
exit(1);
}
}
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;
}
}
}
void WriteFunctionCode(FILE * f)
{
int i;
IVAR ivar;
if (pass == 1)
{
printf(" generating C interface for function (%s) Scilab function\"%s\"\n", forsub->name, basfun->name);
}
FCprintf(f, "/******************************************\n");
FCprintf(f, " * SCILAB function : %s, fin = %d\n", basfun->name, nFun);
FCprintf(f, " ******************************************/\n");
WriteHeader(f, "ints", basfun->name);
/* optional arguments : new style */
/** XXXXXX basfun->NewMaxOpt= basfun->maxOpt; */
basfun->NewMaxOpt = basfun->maxOpt;
if (basfun->NewMaxOpt > 0)
{
/** optional arguments **/
AddDeclare(DEC_INT, "nopt");
AddDeclare(DEC_INT, "iopos");
Fprintf(f, indent, "nopt=NumOpt();\n");
}
/* rhs argument number checking */
if (basfun->NewMaxOpt > 0)
Fprintf(f, indent, "CheckRhs(%d,%d+nopt);\n", basfun->nin - basfun->maxOpt, basfun->nin - basfun->maxOpt);
else
Fprintf(f, indent, "CheckRhs(%d,%d);\n", basfun->nin - basfun->maxOpt, basfun->nin);
/* lhs argument number checking */
ivar = basfun->out;
if (ivar == 0)
{
Fprintf(f, indent, "CheckLhs(0,1);\n");
}
else
{
if ((variables[ivar - 1]->length == 0) || (variables[ivar - 1]->type == LIST) || (variables[ivar - 1]->type == TLIST))
{
Fprintf(f, indent, "CheckLhs(1,1);\n");
}
else
{
Fprintf(f, indent, "CheckLhs(1,%d);\n", variables[ivar - 1]->length);
}
}
/* SCILAB argument checking */
for (i = 0; i < basfun->nin - basfun->NewMaxOpt; i++)
{
switch (variables[i]->type)
{
case LIST:
WriteListAnalysis(f, i, "l");
break;
case TLIST:
WriteListAnalysis(f, i, "t");
break;
case MLIST:
WriteListAnalysis(f, i, "m");
break;
default:
WriteArgCheck(f, i);
break;
}
}
if (basfun->NewMaxOpt != 0)
{
sprintf(str1, "rhs_opts opts[]={\n");
for (i = basfun->nin - basfun->NewMaxOpt; i < basfun->nin; i++)
{
sprintf(str2, "\t{-1,\"%s\",\"%s\",0,0,0},\n", variables[i]->name, SGetForTypeAbrev(variables[i]));
strcat(str1, str2);
}
strcat(str1, "\t{-1,NULL,NULL,NULL,0,0}}");
AddDeclare(DEC_DATA, str1);
Fprintf(f, indent, "iopos=Rhs;\n");
Fprintf(f, indent, "if ( get_optionals(fname,opts) == 0) return 0;\n");
for (i = basfun->nin - basfun->NewMaxOpt; i < basfun->nin; i++)
{
WriteOptArgPhase2(f, i);
}
}
/* SCILAB cross checking */
WriteCrossCheck(f);
/* SCILAB equal output variable checking */
WriteEqualCheck(f);
/* FORTRAN call */
WriteFortranCall(f);
/* FORTRAN output to SCILAB */
WriteOutput(f);
}
void WriteOptArg(FILE *f,VARPTR var)
{
char lsize[MAXNAM];
char ldata[MAXNAM];
Fprintf(f,indent++,"if( Rhs <= %d)\n",
var->stack_position-1 );
Fprintf(f,indent,"{\n");
switch (var->opt_type)
{
case NAME:
AddDeclare(DEC_LOGICAL,"optvarget");
Fprintf(f,indent,"if (.not.optvarget(fname,topk,%d,'%s ')) return\n",
var->stack_position,var->opt_name);
break;
case VALUE:
switch (var->type)
{
case SCALAR:
(*(CRERHSTAB[var->type].fonc))(f,var);
Fprintf(f,indent,"stk(lr%d)= %s\n",var->stack_position,
var->opt_name);
break;
case MATRIX:
OptvarGetSize(var->opt_name,lsize,ldata);
AddDeclare1(DEC_DATA,"%s dat%d[]= %s",
SGetCDec(var->for_type),
var->stack_position,ldata);
Fprintf(f,indent,"m%d = 1;n%d = %s;\n",var->stack_position,
var->stack_position,lsize);
(*(CRERHSTAB[var->type].fonc))(f,var);
AddDeclare1(DEC_INT,"un=1");
Fprintf(f,indent,"C2F(%scopy)(&m%d,dat%d,&un,%s(l%d),&un);\n",
SGetForTypeAbrev(var),
var->stack_position,
var->stack_position,
SGetForTypeStack(var),var->stack_position);
break;
case STRING:
Fprintf(f,indent,"m%d = %d\n",var->stack_position,
strlen(var->opt_name));
(*(CRERHSTAB[var->type].fonc))(f,var);
Fprintf(f,indent,"call stringcopy(m%d,'%s',cstk(lr%d))\n",
var->stack_position,var->opt_name,var->stack_position);
break;
case SCIOPOINTER :
(*(CRERHSTAB[var->type].fonc))(f,var);
break;
default:
printf("Optional variable with value must be \"SCALAR\" or \"STRING\"\n");
exit(1);
break;
}
break;
}
Fprintf(f,indent--,"}\n");
Fprintf(f,indent++,"else\n");
Fprintf(f,indent,"{\n");
(*(RHSTAB[var->type].fonc))(f,var,0);
Fprintf(f,indent--,"}\n");
}
