/****************************************************
* interface for string matrix primitives
* Copyright Inria/Enpc
*
* Note: in this interface arguments are transmited by
* reference. interfaces must take care not to
* change transmited arguments.
* Rewriten from scratch from strelm.f except for
* intmacrostring
* intlibstring
* Jean-Philippe Chancelier 2002
******************************************************/
#include <ctype.h>
#include <string.h>
#include <stdio.h>
#include "../stack-c.h"
#ifdef WIN32
#include "../os_specific/win_mem_alloc.h" /* MALLOC */
#else
#include "../os_specific/sci_mem_alloc.h" /* MALLOC */
#endif
static integer cx1 = 1;
#if WIN32
extern int C2F(getorient)( );
extern int C2F(rcsort)( );
extern int C2F(funnam)( );
extern int C2F(cvdm)( );
extern int C2F(cvwm)( );
extern int C2F(namstr)( );
extern char *GetExceptionString(DWORD ExceptionCode);
#endif
/****************************************************
* [r,w]=grep(S1,S2)
******************************************************/
static int intgrep(char* fname)
{
int m1,n1,m2,n2,un=1,l3,l4,l5,l6,mn,i,j,count;
char **Str1,**Str2;
CheckRhs(2,2);
CheckLhs(1,2);
GetRhsVar(1,"S",&m1,&n1,&Str1);
GetRhsVar(2,"S",&m2,&n2,&Str2);
mn = m1*n1;
CreateVar(3,"d",&mn,&un,&l3);
if (Lhs == 2) CreateVar(4,"d",&mn,&un,&l4);
count = 0;
for ( i = 0 ; i < mn ; i++ )
{
for ( j = 0 ; j < m2*n2 ; j++ )
if ( strstr( Str1[i],Str2[j]) != NULL)
{
*stk(l3+count) = i+1;
if ( Lhs == 2 ) *stk(l4+count) = j+1;
count++;
break;
}
}
if ( Lhs == 1 )
{
CreateVarFrom(4,"d",&un,&count,&l4,&l3);
LhsVar(1)=4;
}
else
{
CreateVarFrom(5,"d",&un,&count,&l5,&l3);
CreateVarFrom(6,"d",&un,&count,&l6,&l4);
LhsVar(1)=5;
LhsVar(2)=6;
}
FreeRhsSVar(Str1);
FreeRhsSVar(Str2);
return 0;
}
/****************************************************
* y= ascii(x)
* x : intXXX or constant matrix or srinng matrix
*
******************************************************/
static int intascii(char* fname)
{
static int un=1,inc=1;
int m1,n1,l1,mn,ichar=I_UCHAR,l2,i,nchars=0,k=0,j;
char **Str;
SciIntMat M;
CheckRhs(1,1);
CheckLhs(1,1);
switch ( VarType(1)) {
case 1 :
GetRhsVar(1,"d",&m1,&n1,&l1);
mn = m1*n1;
/* we create a string of the same length */
CreateVar(2,"c",&mn,&un,&l2);
for (i=0 ; i < mn ; i++ )
*cstk(l2+i) = (int) *stk(l1+i);
LhsVar(1) = 2 ;
break;
case 10 :
GetRhsVar(1,"S",&m1,&n1,&Str);
mn = m1*n1;
for ( i = 0 ; i < mn ; i++ )
nchars += strlen(Str[i]);
CreateVar(2,"d",&un,&nchars,&l2);
k=0;
for ( i = 0 ; i < mn ; i++ )
for ( j =0 ; j < (int)strlen(Str[i]) ; j++ )
*stk(l2+k++) = (unsigned char) Str[i][j];
FreeRhsSVar(Str);
LhsVar(1) = 2 ;
break;
case 8 :
GetRhsVar(1,"I",&m1,&n1,&M);
mn = m1*n1;
/* we create a string of the same length */
CreateVar(2,"c",&mn,&un,&l1);
/* from intxx to char */
C2F(tpconv)(&M.it,&ichar,&mn, M.D, &inc, cstk(l1), &inc);
LhsVar(1) = 2 ;
break;
default :
OverLoad(1);
return 0;
}
return(0);
}
/****************************************************
* y= strcat(str1,sep,[op])
* op = 'c' or 'r'
******************************************************/
static int intstrcat(char* fname)
{
char typ = '*';
char **Str,**Str1;
static char def_sep[] ="";
char *sep = def_sep;
static int un=1;
int m1,n1,mn,i,j,k,m2,n2,l2,m3,n3,l3,nchars=0;
CheckRhs(1,3);
CheckLhs(1,1);
switch ( VarType(1)) {
case 10 :
GetRhsVar(1,"S",&m1,&n1,&Str);
mn = m1*n1;
if (Rhs >= 2) {
GetRhsVar(2,"c",&m2,&n2,&l2);
sep = cstk(l2);
}
if (Rhs >= 3) {
GetRhsVar(3,"c",&m3,&n3,&l3);
if ( m3*n3 != 0)
typ = cstk(l3)[0];
if (typ != 'c' && typ != 'r' ) {
Scierror(999,"%s: third argument should be 'c' or 'r'\r\n",fname);
return 0;
}
}
switch ( typ ) {
case '*' :
/* just return one string */
for ( i = 0 ; i < mn ; i++ )
nchars += strlen(Str[i]);
nchars += (mn-1)*strlen(sep);
CreateVar(Rhs+1,"c",&un,&nchars,&l3);
k=0;
for ( i = 0 ; i < mn ; i++ )
{
for ( j =0 ; j < (int)strlen(Str[i]) ; j++ )
*cstk(l3+ k++) = Str[i][j];
if ( i != mn-1)
for ( j =0 ; j < (int)strlen(sep) ; j++ )
*cstk(l3+ k++) = sep[j];
}
FreeRhsSVar(Str);
LhsVar(1) = Rhs+1 ;
break;
case 'c':
/* return a column matrix */
if ( (Str1 = MALLOC((m1+1)*sizeof(char *)))==NULL)
{
Scierror(999,"%s: Out of memory\r\n",fname);
return 0;
}
Str1[m1]=NULL;
for (i= 0 ; i < m1 ; i++) {
/* length of row i */
nchars = 0;
for ( j = 0 ; j < n1 ; j++ )
nchars += strlen(Str[i+ m1*j]);
nchars += (n1-1)*strlen(sep);
if ( (Str1[i]=MALLOC((nchars+1)*sizeof(char)))==NULL)
{
Scierror(999,"%s: Out of memory\r\n",fname);
return 0;
}
/* fill the string */
strcpy(Str1[i],Str[i]);
for ( j = 1 ; j < n1 ; j++ ) {
strcat(Str1[i],sep);
strcat(Str1[i],Str[i+ m1*j]);
}
}
CreateVarFromPtr(Rhs+1,"S", &m1, &un, Str1);
FreeRhsSVar(Str);
LhsVar(1) = Rhs+1 ;
FreeRhsSVar(Str1);
break;
case 'r':
/* return a row matrix */
if ( (Str1 = MALLOC((n1+1)*sizeof(char *)))==NULL)
{
Scierror(999,"%s: Out of memory\r\n",fname);
return 0;
}
Str1[n1]=NULL;
for (j= 0 ; j < n1 ; j++) {
/* length of col j */
nchars = 0;
for ( i = 0 ; i < m1 ; i++ )
nchars += strlen(Str[i+ m1*j]);
nchars += (m1-1)*strlen(sep);
if ( (Str1[j]=MALLOC((nchars+1)*sizeof(char)))==NULL)
{
Scierror(999,"%s: Out of memory\r\n",fname);
return 0;
}
/* fill the string */
strcpy(Str1[j],Str[j*m1]);
for ( i = 1 ; i < m1 ; i++ ) {
strcat(Str1[j],sep);
strcat(Str1[j],Str[i+ m1*j]);
}
}
CreateVarFromPtr(Rhs+1,"S", &un, &n1, Str1);
FreeRhsSVar(Str);
FreeRhsSVar(Str1);
LhsVar(1) = Rhs+1 ;
break;
}
break;
default :
OverLoad(1);
break;
}
return 0;
}
/****************************************************
* y= str2code(str1)
******************************************************/
static int intstr2code(char* fname)
{
static int un=1;
int m1,n1,l1,mn,l2;
CheckRhs(1,1);
CheckLhs(1,1);
switch ( VarType(1)) {
case 10 :
GetRhsVar(1,"c",&m1,&n1,&l1);
mn = m1*n1;
/* sciprint("string %s\r\n",cstk(l1)); */
CreateVar(2,"i",&mn,&un,&l2);
C2F(asciitocode)(&mn,istk(l2),cstk(l1),&un,mn);
/* take care of ref argument 1 */
LhsVar(1) = 2;
break;
default :
OverLoad(1);
break;
}
return 0;
}
/****************************************************
* y= code2str(str1)
******************************************************/
static int intcode2str(char* fname)
{
static int un=1;
int m1,n1,l1,mn,l2;
CheckRhs(1,1);
CheckLhs(1,1);
switch ( VarType(1)) {
case 1 :
GetRhsVar(1,"i",&m1,&n1,&l1);
mn = m1*n1;
CreateVar(2,"c",&mn,&un,&l2);
C2F(codetoascii)(&mn,istk(l1),cstk(l2),mn);
/* take care of ref argument 1 */
LhsVar(1) = 2;
break;
default :
OverLoad(1);
break;
}
return 0;
}
/****************************************************
* y= intstrindex(str1,strmat)
******************************************************/
static int intstrindex(char* fname)
{
static int un=1,zero=0;
char *loc ;
char **Str;
int m1,n1,l1,m2,n2,l3,i,count=0;
CheckRhs(2,2);
CheckLhs(1,1);
GetRhsVar(1,"c",&m1,&n1,&l1);
if ( m1 == 0 )
{
CreateVar(3,"d",&zero,&zero,&l3);
LhsVar(1) = 3;
return 0;
}
GetRhsVar(2,"S",&m2,&n2,&Str);
CreateVar(3,"d",&un,&m1,&l3);
/* working area */
for ( i = 0 ; i < m2*n2 ; i++)
{
char *needle = Str[i];
loc = cstk(l1);
while (loc != NULL)
{
loc = strstr(loc,needle);
if ( loc != NULL)
{
*stk(l3+count++)=loc-cstk(l1)+1;
loc += 1;
}
}
}
/* resizing with computed size */
CreateVar(3,"d",&un,&count,&l3);
FreeRhsSVar(Str);
/* WARNING:: must take care of arg 1 which is transmited by ref
* and was changed by the GetRhsVar
*/
LhsVar(1) = 3;
return 0;
}
/****************************************************
* y= intstrsubst(matstr,search,replace)
* exec loader.sce ;
* mysubs('pipo','pi','foo')
******************************************************/
static char ** subst(char **Str,int n,char *needle,char *replace)
{
int i,count,size,j;
char **Str1;
Str1 = MALLOC( (n+1)*sizeof(char*));
if (Str1 == NULL)
{
return NULL;
}
Str1[n]= NULL;
for ( i = 0 ; i < n ; i++)
{
char *loc = Str[i];
int locsize= strlen(loc);
count=0;
while (loc != NULL)
{
loc = strstr(loc, needle);
if ( loc != NULL)
{
*loc = '\0'; /* we put a mark */
loc += 1;
count++;
}
}
/* now we know the number of occurences = count */
size = locsize + count*(strlen(replace)-strlen(needle))+1;
Str1[i]= MALLOC( size*sizeof(char));
if (Str1 == NULL)
{
/** XXXX */
return NULL;
}
/* fill result */
Str1[i][0]='\0';
loc = Str[i];
for ( j = 0 ; j < count ; j++ )
{
strcat(Str1[i],loc);
loc += strlen(loc)+ strlen(needle);
strcat(Str1[i],replace);
}
strcat(Str1[i],loc);
}
return Str1;
}
static int intstrsubst(char* fname)
{
char *needle,*replace ;
char **Str,**Str1;
int m1,n1,m2,n2,l2,m3,n3,l3;
CheckRhs(3,3);
CheckLhs(1,1);
GetRhsVar(1,"S",&m1,&n1,&Str);
GetRhsVar(2,"c",&m2,&n2,&l2);
needle= cstk(l2);
GetRhsVar(3,"c",&m3,&n3,&l3);
replace = cstk(l3);
Str1 = subst(Str,m1*n1,needle,replace);
if (Str1 == NULL)
{
Scierror(999,"running out of memory\r\n");
FreeRhsSVar(Str);
return 0;
}
CreateVarFromPtr(4,"S",&m1,&n1,Str1);
FreeRhsSVar(Str);
FreeRhsSVar(Str1);
/* take care of ref argument 1 */
LhsVar(1) = 4;
return 0;
}
/****************************************************
* y= length(x)
******************************************************/
static int intlength(char* fname)
{
char **Str;
static int un=1;
int *header,m1,n1,l1,l2,mn,i;
CheckRhs(1,1);
CheckLhs(1,1);
switch ( VarType(1)) {
case 1 :
case 2 :
case 4 :
header = GetData(1);
CreateVar(2,"d",&un,&un,&l2);
*stk(l2)=header[1]*header[2];
LhsVar(1) = 2 ;
break;
case 10 :
GetRhsVar(1,"S",&m1,&n1,&Str);
mn = m1*n1;
CreateVar(2,"d",&m1,&n1,&l2);
for ( i = 0 ; i < mn ; i++ )
{
*stk(l2+i)= strlen(Str[i]);
}
FreeRhsSVar(Str);
LhsVar(1) = 2 ;
break;
case 15 :
GetRhsVar(1,"l",&m1,&n1,&l1);
CreateVar(2,"d",&un,&un,&l2);
*stk(l2)=m1;
LhsVar(1) = 2 ;
break;
case 16:
GetRhsVar(1,"t",&m1,&n1,&l1);
CreateVar(2,"d",&un,&un,&l2);
*stk(l2)=m1;
LhsVar(1) = 2 ;
break;
case 17 :
GetRhsVar(1,"m",&m1,&n1,&l1);
CreateVar(2,"d",&un,&un,&l2);
*stk(l2)=m1;
LhsVar(1) = 2 ;
break;
default :
OverLoad(1);
return 0;
}
return(0);
}
/****************************************************
* y= convstr(x [,flag])
******************************************************/
static int intconvstr(char* fname)
{
char **Str;
char flag = 'l';
int m1,n1,m2,n2,l2,mn,i,j;
CheckRhs(1,2);
CheckLhs(1,1);
GetRhsVar(1,"S",&m1,&n1,&Str);
mn = m1*n1;
if (Rhs == 2)
{
GetRhsVar(2,"c",&m2,&n2,&l2);
flag = *cstk(l2) ;
if ( flag != 'l' && flag != 'u')
{
Scierror(999,"%s: second argument \"%s\", should be 'u' or 'l'\r\n",
fname,cstk(l2));
return 0;
}
}
if ( flag == 'u' )
for ( i = 0 ; i < mn ; i++ )
for ( j=0 ; j < (int)strlen(Str[i]) ; j++)
Str[i][j]=toupper(Str[i][j]);
else
for ( i = 0 ; i < mn ; i++ )
for ( j=0 ; j < (int)strlen(Str[i]) ; j++)
Str[i][j]=tolower(Str[i][j]);
CreateVarFromPtr(Rhs+1,"S",&m1,&n1,Str);
FreeRhsSVar(Str);
LhsVar(1) = Rhs+1;
return(0);
}
/****************************************************
* y= part(matstr,v)
******************************************************/
static char **part(char **Str,int n,int *Ind,int nI)
{
int i,j,k;
char **Str1;
Str1 = MALLOC((n+1)*sizeof(char*));
if (Str1 == NULL)
{
return NULL;
}
Str1[n]= NULL;
for ( i = 0 ; i < n ; i++)
{
char *loc = Str[i];
int locsize= strlen(loc);
Str1[i]= MALLOC( (nI+1)*sizeof(char));
if (Str1 == NULL)
{
return NULL;
}
/* fill result */
k = 0;
for ( j = 0 ; j < nI ; j++)
{
if ( Ind[j] > 0 && Ind[j] <= locsize )
Str1[i][k++]= Str[i][Ind[j]-1];
else
Str1[i][k++]= ' ';
}
Str1[i][k]='\0';
}
return Str1;
}
static int intpart (char* fname)
{
char **Str,**Str1;
int m1,n1,m2,n2,l2;
CheckRhs(2,2)
CheckLhs(1,1);
GetRhsVar(1,"S",&m1,&n1,&Str);
GetRhsVar(2,"i",&m2,&n2,&l2);
Str1 = part(Str,m1*n1,istk(l2),m2*n2);
if (Str1 == NULL)
{
Scierror(999,"running out of memory\r\n");
FreeRhsSVar(Str);
return 0;
}
CreateVarFromPtr(3,"S",&m1,&n1,Str1);
FreeRhsSVar(Str);
FreeRhsSVar(Str1);
LhsVar(1) = 3;
return 0;
}
/****************************************************
* y= emptystr(....)
******************************************************/
static char **empty(int n)
{
int i;
char **Str1;
Str1 = MALLOC((n+1)*sizeof(char*));
if (Str1 == NULL)
{
return NULL;
}
Str1[n]= NULL;
for ( i = 0 ; i < n ; i++)
{
Str1[i]= MALLOC(sizeof(char));
if (Str1 == NULL)
{
return NULL;
}
Str1[i][0]='\0';
}
return Str1;
}
static int intemptystr(char* fname)
{
int *header;
char **Str1;
int m1,n1,l1,m2,n2,l2,m,n;
CheckRhs(0,2)
CheckLhs(1,1);
switch ( Rhs ) {
case 0 :
m=n=1;
break;
case 2:
GetRhsVar(1,"d",&m1,&n1,&l1);
CheckScalar(1,m1,n1);
GetRhsVar(2,"d",&m2,&n2,&l2);
CheckScalar(1,m2,n2);
m = (int) *stk(l1);n = (int) *stk(l2);
break;
case 1:
switch ( VarType(1)) {
case 1 :
case 2 :
case 4 :
case 10:
header = GetData(1);
m = header[1]; n = header[2];
break;
case 15 :
GetRhsVar(1,"l",&m1,&n1,&l1);
m = m1;n = 1;
break;
case 16:
GetRhsVar(1,"t",&m1,&n1,&l1);
m = m1;n = 1;
break;
case 17 :
GetRhsVar(1,"m",&m1,&n1,&l1);
m = m1;n = 1;
break;
default :
OverLoad(1);
return 0;
}
}
Str1 = empty(m*n);
if (Str1 == NULL)
{
Scierror(999,"running out of memory\r\n");
return 0;
}
CreateVarFromPtr(Rhs+1,"S",&m,&n,Str1);
FreeRhsSVar(Str1);
LhsVar(1) = Rhs+1;
return 0;
}
/*-----------------------------------------------------------
* XXXXXX To be done
*-----------------------------------------------------------*/
static integer C2F(strord)(r1, l1, r2, l2)
integer *r1, *l1, *r2, *l2;
{
/* Initialized data */
static integer blank = 40;
integer ret_val, ix1;
integer iord, ix, c1, c2, ll;
/* Parameter adjustments */
--r2;
--r1;
/* Function Body */
iord = 0;
if (*l1 == 0) {
if (*l2 > 0) {
ret_val = -1;
return ret_val;
} else {
ret_val = 0;
return ret_val;
}
} else {
if (*l2 == 0) {
ret_val = 1;
return ret_val;
}
}
ll = Min(*l1,*l2);
ix1 = Max(*l1,*l2);
for (ix = 1; ix <= ix1; ++ix) {
if (ix <= *l1) {
c1 = r1[ix];
} else {
c1 = blank;
}
if (ix <= *l2) {
c2 = r2[ix];
} else {
c2 = blank;
}
if (c1 >= 0) {
c1 = 256 - c1;
}
if (c2 >= 0) {
c2 = 256 - c2;
}
if (c1 > c2) {
ret_val = 1;
return ret_val;
} else if (c1 < c2) {
ret_val = -1;
return ret_val;
}
/* L10: */
}
ret_val = 0;
return ret_val;
} /* strord_ */
static int intsort(char* fname)
{
integer ix1;
integer lind;
integer tops, lszi;
integer ix, l, m, n, lindi;
integer l1, l2;
integer il, mn, ls, lw;
integer id1, il1;
integer idi, inc, sel, ilr, vol, lsz, id1r;
Scierror(999,"sort to be done \r\n");
/* Function Body */
if (Rhs > 2) {
Error(42);
return 0;
}
if (Lhs > 2) {
Error(41);
return 0;
}
tops = Top;
/* select type of sort to perform */
sel = 0;
if (Rhs == 2) {
C2F(getorient)(&Top, &sel);
if (Err > 0) {
return 0;
}
--Top;
}
if (sel == 2) {
Top = tops;
C2F(com).fun = -1;
ix1 = iadr(*Lstk(Top + 1 - Rhs ));
C2F(funnam)(&C2F(recu).ids[(C2F(recu).pt + 1) * nsiz - nsiz], "sort", &ix1, 4L);
return 0;
}
if (Rhs == 2) {
--Rhs;
}
C2F(ref2val)();
il1 = iadr(*Lstk(Top ));
ilr = il1;
m = *istk(il1 +1);
n = *istk(il1 + 1 +1);
mn = m * n;
id1 = il1 + 4;
l1 = id1 + mn + 1;
vol = *istk(id1 + mn ) - 1;
id1r = id1;
ls = iadr(*Lstk(Top +1));
lsz = ls + vol;
lind = lsz + mn;
lw = lind + mn;
Err = sadr(lw) - *Lstk(Bot );
if (Err > 0) {
Error(17);
return 0;
}
C2F(icopy)(&vol, istk(l1 ), &cx1, istk(ls ), &cx1);
ix1 = mn - 1;
for (ix = 0; ix <= ix1; ++ix) {
*istk(lsz + ix ) = *istk(id1 + ix +1) - *istk(id1 + ix );
/* L91: */
}
if (sel == 0) {
/* sort(a) <=> sort(a,'*') */
C2F(rcsort)(C2F(strord), istk(lsz ), istk(id1 ), istk(ls ), &mn, istk(lind ));
} else if (sel == 1) {
/* sort(a,'r') <=> sort(a,1) */
lszi = lsz;
idi = id1;
lindi = lind;
ix1 = n - 1;
for (ix = 0; ix <= ix1; ++ix) {
C2F(rcsort)(C2F(strord), istk(lszi ), istk(idi ), istk(ls ), &m, istk(lindi ));
lszi += m;
idi += m;
lindi += m;
/* L95: */
}
}
l2 = ilr + 4 + mn + 1;
ix1 = mn - 1;
for (ix = 0; ix <= ix1; ++ix) {
C2F(icopy)(istk(lsz + ix ), istk(ls - 1 + *istk(id1 + ix )), &cx1, istk(l2 ), &cx1);
l2 += *istk(lsz + ix );
/* L93: */
}
*Lstk(Top +1) = sadr(l2);
*istk(id1 ) = 1;
ix1 = mn - 1;
for (ix = 0; ix <= ix1; ++ix) {
*istk(id1 + ix +1) = *istk(id1 + ix ) + *istk(lsz + ix );
/* L94: */
}
if (Lhs == 1) {
goto L999;
}
++Top;
il = iadr(*Lstk(Top ));
ix1 = il + 4;
l = sadr(ix1);
inc = -1;
if (sadr(lind) > l) {
inc = 1;
}
C2F(int2db)(&mn, istk(lind ), &inc, stk(l ), &inc);
*istk(il ) = 1;
*istk(il +1) = m;
*istk(il + 1 +1) = n;
*istk(il + 2 +1) = 0;
*Lstk(Top +1) = l + mn;
goto L999;
L999:
return 0;
} /* intssort_ */
/*-----------------------------------------------------------
* intstring
*-----------------------------------------------------------*/
static int intlibstring(void);
static int intmacrostring(void);
static int intstring (char* fname)
{
int * data,*info,*header,nstr;
int lr,lc,m,n,it,size;
CheckRhs(1,1);
switch ( VarType(1)) {
case 1 :
/* scalar matrix case */
CheckLhs(1,1);
GetRhsCVar(1,"d",&it,&m,&n,&lr,&lc);
if ( m*n == 0)
{
LhsVar(1)=1;
return 0;
}
size = m * n + 1 ;
size += m * n * ((C2F(iop).lct[6] << 1) + 4);
CreateData(2, (4+size)*sizeof(int));
header = GetData(2);
info = header+4;
data = header+4 + m * n + 1;
if (it == 0)
C2F(cvdm)(stk(lr), &m, &m, &n, &C2F(iop).lct[6],
&C2F(iop).lct[5],data,info);
else
C2F(cvwm)(stk(lr), stk(lc), &m, &m, &n,
&C2F(iop).lct[6], &C2F(iop).lct[5],data,info);
/* the real size */
nstr= info[m*n] -1;
CreateData(2, (4+m*n+1+ nstr)*sizeof(int));
header[0]=10;
header[1]=m;
header[2]=n;
header[3]=0;
LhsVar(1)=2;
break;
case 10:
/* string matrix case
*/
CheckLhs(1,1);
if ( IsRef(1) )
{
/* since the argument must be returned
* we must replace the ref by its value
*/
Ref2val(1,2);
/* just to register 2 in the registered variables */
header = GetData(2);
/* we return 2 */
LhsVar(1)=2;
}
else
{
/* just to register 1 in the registered variables */
header = GetData(1);
/* we return 1 */
LhsVar(1) = 1;
}
break;
case 11 :
case 13 :
CheckLhs(1,3);
intmacrostring();
header = GetData(2);
header = GetData(3);
header = GetData(4);
LhsVar(1)=2;
LhsVar(2)=3;
LhsVar(3)=4;
break;
case 14:
CheckLhs(1,1);
intlibstring();
header = GetData(2);
LhsVar(1)=2;
break;
default :
OverLoad(1);
return 0;
}
return 0;
}
/*-----------------------------------------------------------
* special cases of intstring
* macros
*-----------------------------------------------------------*/
static int C2F(listnames)(integer pos,integer *il);
static int intmacrostring(void)
{
static integer eol = 99;
/*integer ix1;*/
integer ltxt, l, n;
integer il, nl, lw, nch, ilm, ilt, ilp;
/* argument on top */
il = iadr(*Lstk(Top ));
if (*istk(il ) < 0) {
il = iadr(*istk(il +1));
}
ilm = il;
++il;
/* first extract lout */
C2F(listnames)(Top + 1, &il);
/* first extract lin */
C2F(listnames)(Top + 2, &il);
/* now extract function body */
lw = *Lstk(Top + 3);
if (*istk(ilm ) == 13) {
ltxt = lw;
ilt = iadr(ltxt);
*istk(ilt ) = 1;
*istk(ilt + 1 +1) = 0;
*istk(ilt + 2 +1) = 0;
*istk(ilt + 3 +1) = 1;
ilt += 4;
*Lstk(Top + 4) = sadr( ilt + 1);
return 0;
}
ltxt = lw;
ilt = iadr(ltxt);
*istk(ilt ) = 10;
*istk(ilt + 1 +1) = 1;
*istk(ilt + 2 +1) = 0;
*istk(ilt + 3 +1) = 1;
ilp = ilt + 4;
/* compute number of lines of the macro */
nch = *istk(il );
nl = 0;
++il;
l = il - 1;
while (1) {
++l;
if (*istk(l) == eol) {
if (*istk(l +1) == eol) break;
++nl;
}
}
*istk(ilt +1) = nl;
if (nl == 0) {
*istk(ilt ) = 1;
*istk(ilt + 2) = 0;
*Lstk(Top + 4) = sadr( ilt + 4);
return 0;
}
ilt = ilp + nl + 1;
l = il;
while (1)
{
if (*istk(l) != eol) { ++l; continue;}
if (*istk(l+1) == eol) {
*Lstk(Top + 4) = sadr(ilt + 1);
return 0;
}
n = l - il;
++ilp;
*istk(ilp ) = *istk(ilp - 2 +1) + n;
C2F(icopy)(&n, istk(il ), &cx1, istk(ilt ), &cx1);
ilt += n;
il = l + 1;
l = il;
}
return 0;
}
/*-----------------------------------------------------------
* special cases of intstring
* library
*-----------------------------------------------------------*/
static int intlibstring(void)
{
static integer nclas = 29;
integer ix1;
integer k, l, n;
integer l1, n1, il, nn, lw;
integer ilr;
il = iadr(*Lstk(Top ));
ilr = il;
if (*istk(il ) < 0) {
il = iadr(*istk(il +1));
}
lw = iadr(*Lstk(Top +1));
n1 = *istk(il +1);
l1 = il + 2;
il = il + n1 + 2;
n = *istk(il );
il = il + nclas + 2;
ilr = lw;
ix1 = ilr + 6 + n1 + n * (nlgh+1);
Err = sadr(ix1) - *Lstk(Bot );
if (Err > 0) {
Error(17);
return 0;
}
*istk(ilr ) = 10;
*istk(ilr +1) = n + 1;
*istk(ilr + 1 +1) = 1;
*istk(ilr + 2 +1) = 0;
*istk(ilr + 3 +1) = 1;
l = ilr + 6 + n;
C2F(icopy)(&n1, istk(l1 ), &cx1, istk(l ), &cx1);
*istk(ilr + 4 +1) = n1 + 1;
l += n1;
ix1 = n;
for (k = 1; k <= ix1; ++k) {
C2F(namstr)(istk(il ), istk(l ), &nn, &cx1);
*istk(ilr + 5 + k ) = *istk(ilr + 4 + k ) + nn;
l += nn;
il += nsiz;
/* L49: */
}
ix1 = ilr + l - ilr;
*Lstk(Top + 1 +1) = sadr(ix1);
return 0;
}
/*-------------------------------------------------------------
* utility
* extract a set of names coded in istk(il+...)
* and store the result in the stack as a
* string matrix store at position Lstk(pos)
* Note: the value of il is changed by this funtion
*-------------------------------------------------------------*/
static int C2F(listnames)(integer pos,integer *il)
{
integer ix1;
integer ilio;
integer j, l, n, nn;
integer ilp;
n = *istk(*il );
++(*il);
ilio = iadr(*Lstk(pos ));
*istk(ilio ) = 10;
if (n == 0) {
*istk(ilio ) = 1;
}
*istk(ilio +1) = Min(1,n);
*istk(ilio + 1 +1) = n;
*istk(ilio + 2 +1) = 0;
ilp = ilio + 4;
*istk(ilp ) = 1;
l = ilp + n;
if (n != 0) {
ix1 = n;
for (j = 1; j <= ix1; ++j) {
C2F(namstr)(istk(*il ), istk(l +1), &nn, &cx1);
l += nn;
*istk(ilp + j ) = l + 1 - (ilp + n);
*il += nsiz;
/* L34: */
}
}
ix1 = l + 1;
*Lstk(pos +1) = sadr(ix1);
return 0;
}
/*-----------------------------------------------------------
* Interface for strings functions
*-----------------------------------------------------------*/
typedef int (*des_interf) __PARAMS((char *fname));
typedef struct table_struct {
des_interf f; /** function **/
char *name; /** its name **/
} StrelmTable;
static StrelmTable Tab[]={
{intlength,"length"},
{intpart,"part"},
{intstring,"string"},
{intconvstr,"convstr"},
{intemptystr,"emptystr"},
{intstr2code,"str2code"},
{intcode2str,"code2str"},
{intsort,"sort"},
{intstrcat,"strcat "},
{intstrindex,"strindex"},
{intstrsubst,"strsubst"},
{intascii,"ascii"},
{intgrep,"grep"},
};
int C2F(cstrelm)()
{
Rhs = Max(0, Rhs);
#if WIN32
#ifndef _DEBUG
_try
{
(*(Tab[Fin-1].f)) (Tab[Fin-1].name);
}
_except (EXCEPTION_EXECUTE_HANDLER)
{
char *ExceptionString=GetExceptionString(GetExceptionCode());
sciprint("Warning !!!\nScilab has found a critical error (%s)\nwith \"%s\" function.\nScilab may become unstable.\n",ExceptionString,Tab[Fin-1].name);
if (ExceptionString) {FREE(ExceptionString);ExceptionString=NULL;}
}
#else
(*(Tab[Fin-1].f)) (Tab[Fin-1].name);
#endif
#else
(*(Tab[Fin-1].f)) (Tab[Fin-1].name);
#endif
C2F(putlhsvar)();
return 0;
}
syntax highlighted by Code2HTML, v. 0.9.1