static Rcomplex
strtoc(const char *nptr, char **endptr, Rboolean NA, LocalData *d)
{
Rcomplex z;
double x, y;
char *s, *endp;
x = Strtod(nptr, &endp, NA, d);
if (isBlankString(endp)) {
z.r = x; z.i = 0;
} else if (*endp == 'i') {
z.r = 0; z.i = x;
endp++;
} else {
s = endp;
y = Strtod(s, &endp, NA, d);
if (*endp == 'i') {
z.r = x; z.i = y;
endp++;
} else {
z.r = 0; z.i = 0;
endp = (char *) nptr; /* -Wall */
}
}
*endptr = endp;
return z;
}
/* Sets fields of typeInfo, ruling out possible types based on s.
*
* The typeInfo struct should be initialized with all fields TRUE.
*/
static void ruleout_types(const char *s, Typecvt_Info *typeInfo, LocalData *data)
{
int res;
char *endp;
if (typeInfo->islogical) {
if (strcmp(s, "F") == 0 || strcmp(s, "FALSE") == 0
|| strcmp(s, "T") == 0 || strcmp(s, "TRUE") == 0) {
typeInfo->isinteger = FALSE;
typeInfo->isreal = FALSE;
typeInfo->iscomplex = FALSE;
} else {
typeInfo->islogical = TRUE;
}
}
if (typeInfo->isinteger) {
res = Strtoi(s, 10);
if (res == NA_INTEGER)
typeInfo->isinteger = FALSE;
}
if (typeInfo->isreal) {
Strtod(s, &endp, TRUE, data);
if (!isBlankString(endp))
typeInfo->isreal = FALSE;
}
if (typeInfo->iscomplex) {
strtoc(s, &endp, TRUE, data);
if (!isBlankString(endp))
typeInfo->iscomplex = FALSE;
}
}
/* Works with digits, but OK in UTF-8 */
SEXP menu(SEXP choices)
{
int c, j;
double first;
char buffer[MAXELTSIZE], *bufp = buffer;
LocalData data = {NULL, 0, 0, '.', NULL, NO_COMCHAR, 0, NULL, FALSE,
FALSE, 0, FALSE, FALSE};
data.NAstrings = R_NilValue;
if (!isString(choices))
error(_("invalid '%s' argument"), "choices");
sprintf(ConsolePrompt, _("Selection: "));
while ((c = ConsoleGetchar()) != '\n' && c != R_EOF) {
if (bufp >= &buffer[MAXELTSIZE - 2]) continue;
*bufp++ = (char) c;
}
*bufp++ = '\0';
ConsolePrompt[0] = '\0';
bufp = buffer;
while (Rspace((int)*bufp)) bufp++;
first = LENGTH(choices) + 1;
if (isdigit((int)*bufp)) {
first = Strtod(buffer, NULL, TRUE, &data);
} else {
for (j = 0; j < LENGTH(choices); j++) {
if (streql(translateChar(STRING_ELT(choices, j)), buffer)) {
first = j + 1;
break;
}
}
}
return ScalarInteger((int)first);
}
gboolean
readgm( char *gm, int *i1, int *i2, double *x1,
double *y1, double *z1, double *x2,
double *y2, double *z2, double *rad )
{
char
*line_buf = NULL,
*startptr = NULL,
*endptr = NULL;
int len, i, idx;
int nint = 2, nflt = 7;
int iarr[2] = { 0, 0 };
double rarr[7] = { 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 };
int eof; /* EOF error flag */
/* Clear return values */
*i1 = *i2 = 0;
*x1 = *y1 = *z1 = *x2 = *y2 = *z2 = *rad = 0.0;
/* read a line from input file */
mem_alloc((void **)&line_buf, LINE_LEN, "in readgm()");
if( line_buf == NULL ) return( FALSE );
startptr = line_buf;
eof = Load_Line( line_buf, input_fp );
if( eof == EOF )
{
Strlcpy( gm, "GE", 3 );
fprintf( stderr,
"xnec2c: readgm(): geometry data card error\n"
"Unexpected EOF while reading input file - appending GE card\n" );
stop( _("readgm(): Geometry data card error\n"\
"Unexpected EOF while reading input file\n"\
"Uppending a default GE card"), ERR_OK );
free_ptr( (void **)&startptr );
return( FALSE );
}
/* get line length */
len = (int)strlen( line_buf );
/* abort if card's mnemonic too short or missing */
if( len < 2 )
{
Strlcpy( gm, "XX", 3 );
fprintf( stderr,
"xnec2c: readgm(): geometry data card error\n"
"card's mnemonic code too short or missing\n" );
stop( _("readgm(): Geometry data card error\n"\
"Card's mnemonic code too short or missing"), ERR_OK );
free_ptr( (void **)&startptr );
return( FALSE );
}
/* extract card's mnemonic code */
Strlcpy( gm, line_buf, 3 );
/* Return if only mnemonic on card */
if( len == 2 )
{
free_ptr( (void **)&startptr );
return( TRUE );
}
/* Compatibility with NEC4,
* comments between data cards */
if( strcmp(gm, "CM") == 0 )
{
free_ptr( (void **)&startptr );
return( TRUE );
}
/* check line for spurious characters */
for( idx = 2; idx < len; idx++ )
{
if( ((line_buf[idx] >= '0') &&
(line_buf[idx] <= '9')) ||
(line_buf[idx] == ' ') ||
(line_buf[idx] == '.') ||
(line_buf[idx] == ',') ||
(line_buf[idx] == '+') ||
(line_buf[idx] == '-') ||
(line_buf[idx] == 'E') ||
(line_buf[idx] == 'e') ||
(line_buf[idx] == '\t') ||
(line_buf[idx] == '\0') )
continue;
else
break;
}
if( idx < len )
{
fprintf( stderr,
"xnec2c: readgm(): geometry data card \"%s\" error\n"
"Spurious character '%c' at column %d\n",
gm, line_buf[idx], idx+1 );
stop( _("readmn(): Geometry data card error\n"\
"Spurious character in command card"), ERR_OK );
free_ptr( (void **)&startptr );
return( FALSE );
}
/* read integers from line */
line_buf += 2;
for( i = 0; i < nint; i++ )
{
/* read an integer from line, reject spurious chars */
iarr[i] = (int)strtol( line_buf, &endptr, 10 );
if( *endptr == '\0' ) break;
line_buf = endptr + 1;
} /* for( i = 0; i < nint; i++ ) */
/* Return if no floats are specified in the card */
if( *endptr == '\0' )
{
*i1 = iarr[0];
*i2 = iarr[1];
*x1 = rarr[0];
*y1 = rarr[1];
*z1 = rarr[2];
*x2 = rarr[3];
*y2 = rarr[4];
*z2 = rarr[5];
*rad= rarr[6];
free_ptr( (void **)&startptr );
return( TRUE );
}
/* read doubles from line */
for( i = 0; i < nflt; i++ )
{
/* read a double from line */
rarr[i] = Strtod( line_buf, &endptr );
if( *endptr == '\0' ) break;
line_buf = endptr + 1;
} /* for( i = 0; i < nflt; i++ ) */
/* Return values on normal exit */
*i1 = iarr[0];
*i2 = iarr[1];
*x1 = rarr[0];
*y1 = rarr[1];
*z1 = rarr[2];
*x2 = rarr[3];
*y2 = rarr[4];
*z2 = rarr[5];
*rad = rarr[6];
free_ptr( (void **)&startptr );
return( TRUE );
} /* readgm() */
SEXP typeconvert(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP cvec, a, dup, levs, dims, names, dec;
SEXP rval = R_NilValue; /* -Wall */
int i, j, len, asIs;
Rboolean done = FALSE;
char *endp;
const char *tmp = NULL;
LocalData data = {NULL, 0, 0, '.', NULL, NO_COMCHAR, 0, NULL, FALSE,
FALSE, 0, FALSE, FALSE};
Typecvt_Info typeInfo; /* keep track of possible types of cvec */
typeInfo.islogical = TRUE; /* we can't rule anything out initially */
typeInfo.isinteger = TRUE;
typeInfo.isreal = TRUE;
typeInfo.iscomplex = TRUE;
data.NAstrings = R_NilValue;
args = CDR(args);
if (!isString(CAR(args)))
error(_("the first argument must be of mode character"));
data.NAstrings = CADR(args);
if (TYPEOF(data.NAstrings) != STRSXP)
error(_("invalid '%s' argument"), "na.strings");
asIs = asLogical(CADDR(args));
if (asIs == NA_LOGICAL) asIs = 0;
dec = CADDDR(args);
if (isString(dec) || isNull(dec)) {
if (length(dec) == 0)
data.decchar = '.';
else
data.decchar = translateChar(STRING_ELT(dec, 0))[0];
}
cvec = CAR(args);
len = length(cvec);
/* save the dim/dimnames attributes */
PROTECT(dims = getAttrib(cvec, R_DimSymbol));
if (isArray(cvec))
PROTECT(names = getAttrib(cvec, R_DimNamesSymbol));
else
PROTECT(names = getAttrib(cvec, R_NamesSymbol));
/* Use the first non-NA to screen */
for (i = 0; i < len; i++) {
tmp = CHAR(STRING_ELT(cvec, i));
if (!(STRING_ELT(cvec, i) == NA_STRING || strlen(tmp) == 0
|| isNAstring(tmp, 1, &data) || isBlankString(tmp)))
break;
}
if (i < len) { /* not all entries are NA */
ruleout_types(tmp, &typeInfo, &data);
}
if (typeInfo.islogical) {
PROTECT(rval = allocVector(LGLSXP, len));
for (i = 0; i < len; i++) {
tmp = CHAR(STRING_ELT(cvec, i));
if (STRING_ELT(cvec, i) == NA_STRING || strlen(tmp) == 0
|| isNAstring(tmp, 1, &data) || isBlankString(tmp))
LOGICAL(rval)[i] = NA_LOGICAL;
else {
if (strcmp(tmp, "F") == 0 || strcmp(tmp, "FALSE") == 0)
LOGICAL(rval)[i] = 0;
else if(strcmp(tmp, "T") == 0 || strcmp(tmp, "TRUE") == 0)
LOGICAL(rval)[i] = 1;
else {
typeInfo.islogical = FALSE;
ruleout_types(tmp, &typeInfo, &data);
break;
}
}
}
if (typeInfo.islogical) done = TRUE; else UNPROTECT(1);
}
if (!done && typeInfo.isinteger) {
PROTECT(rval = allocVector(INTSXP, len));
for (i = 0; i < len; i++) {
tmp = CHAR(STRING_ELT(cvec, i));
if (STRING_ELT(cvec, i) == NA_STRING || strlen(tmp) == 0
|| isNAstring(tmp, 1, &data) || isBlankString(tmp))
INTEGER(rval)[i] = NA_INTEGER;
else {
INTEGER(rval)[i] = Strtoi(tmp, 10);
if (INTEGER(rval)[i] == NA_INTEGER) {
typeInfo.isinteger = FALSE;
ruleout_types(tmp, &typeInfo, &data);
break;
}
}
}
if(typeInfo.isinteger) done = TRUE; else UNPROTECT(1);
}
if (!done && typeInfo.isreal) {
PROTECT(rval = allocVector(REALSXP, len));
for (i = 0; i < len; i++) {
tmp = CHAR(STRING_ELT(cvec, i));
if (STRING_ELT(cvec, i) == NA_STRING || strlen(tmp) == 0
|| isNAstring(tmp, 1, &data) || isBlankString(tmp))
REAL(rval)[i] = NA_REAL;
else {
REAL(rval)[i] = Strtod(tmp, &endp, FALSE, &data);
if (!isBlankString(endp)) {
typeInfo.isreal = FALSE;
ruleout_types(tmp, &typeInfo, &data);
break;
}
}
}
if(typeInfo.isreal) done = TRUE; else UNPROTECT(1);
}
if (!done && typeInfo.iscomplex) {
PROTECT(rval = allocVector(CPLXSXP, len));
for (i = 0; i < len; i++) {
tmp = CHAR(STRING_ELT(cvec, i));
if (STRING_ELT(cvec, i) == NA_STRING || strlen(tmp) == 0
|| isNAstring(tmp, 1, &data) || isBlankString(tmp))
COMPLEX(rval)[i].r = COMPLEX(rval)[i].i = NA_REAL;
else {
COMPLEX(rval)[i] = strtoc(tmp, &endp, FALSE, &data);
if (!isBlankString(endp)) {
typeInfo.iscomplex = FALSE;
/* this is not needed, unless other cases are added */
ruleout_types(tmp, &typeInfo, &data);
break;
}
}
}
if(typeInfo.iscomplex) done = TRUE; else UNPROTECT(1);
}
if (!done) {
if (asIs) {
PROTECT(rval = duplicate(cvec));
for (i = 0; i < len; i++)
if(isNAstring(CHAR(STRING_ELT(rval, i)), 1, &data))
SET_STRING_ELT(rval, i, NA_STRING);
}
else {
PROTECT(dup = duplicated(cvec, FALSE));
j = 0;
for (i = 0; i < len; i++) {
/* <NA> is never to be a level here */
if (STRING_ELT(cvec, i) == NA_STRING) continue;
if (LOGICAL(dup)[i] == 0 && !isNAstring(CHAR(STRING_ELT(cvec, i)), 1, &data))
j++;
}
PROTECT(levs = allocVector(STRSXP,j));
j = 0;
for (i = 0; i < len; i++) {
if (STRING_ELT(cvec, i) == NA_STRING) continue;
if (LOGICAL(dup)[i] == 0 && !isNAstring(CHAR(STRING_ELT(cvec, i)), 1, &data))
SET_STRING_ELT(levs, j++, STRING_ELT(cvec, i));
}
/* We avoid an allocation by reusing dup,
* a LGLSXP of the right length
*/
rval = dup;
SET_TYPEOF(rval, INTSXP);
/* put the levels in lexicographic order */
sortVector(levs, FALSE);
PROTECT(a = matchE(levs, cvec, NA_INTEGER, env));
for (i = 0; i < len; i++)
INTEGER(rval)[i] = INTEGER(a)[i];
setAttrib(rval, R_LevelsSymbol, levs);
PROTECT(a = mkString("factor"));
setAttrib(rval, R_ClassSymbol, a);
UNPROTECT(3);
}
}
setAttrib(rval, R_DimSymbol, dims);
setAttrib(rval, isArray(cvec) ? R_DimNamesSymbol : R_NamesSymbol, names);
UNPROTECT(3);
return rval;
}
static void extractItem(char *buffer, SEXP ans, int i, LocalData *d)
{
char *endp;
switch(TYPEOF(ans)) {
case NILSXP:
break;
case LGLSXP:
if (isNAstring(buffer, 0, d))
LOGICAL(ans)[i] = NA_INTEGER;
else {
int tr = StringTrue(buffer), fa = StringFalse(buffer);
if(tr || fa) LOGICAL(ans)[i] = tr;
else expected("a logical", buffer, d);
}
break;
case INTSXP:
if (isNAstring(buffer, 0, d))
INTEGER(ans)[i] = NA_INTEGER;
else {
INTEGER(ans)[i] = Strtoi(buffer, 10);
if (INTEGER(ans)[i] == NA_INTEGER)
expected("an integer", buffer, d);
}
break;
case REALSXP:
if (isNAstring(buffer, 0, d))
REAL(ans)[i] = NA_REAL;
else {
REAL(ans)[i] = Strtod(buffer, &endp, TRUE, d);
if (!isBlankString(endp))
expected("a real", buffer, d);
}
break;
case CPLXSXP:
if (isNAstring(buffer, 0, d))
COMPLEX(ans)[i].r = COMPLEX(ans)[i].i = NA_REAL;
else {
COMPLEX(ans)[i] = strtoc(buffer, &endp, TRUE, d);
if (!isBlankString(endp))
expected("a complex", buffer, d);
}
break;
case STRSXP:
if (isNAstring(buffer, 1, d))
SET_STRING_ELT(ans, i, NA_STRING);
else
SET_STRING_ELT(ans, i, insertString(buffer, d));
break;
case RAWSXP:
if (isNAstring(buffer, 0, d))
RAW(ans)[i] = 0;
else {
RAW(ans)[i] = strtoraw(buffer, &endp);
if (!isBlankString(endp))
expected("a raw", buffer, d);
}
break;
default:
UNIMPLEMENTED_TYPE("extractItem", ans);
}
}
