void ObjectNodeInstance::removeFromOldProperty(QObject *object, QObject *oldParent, const PropertyName &oldParentProperty)
{
QQmlProperty property(oldParent, oldParentProperty, context());
if (!property.isValid())
return;
if (isList(property)) {
removeObjectFromList(property, object, nodeInstanceServer()->engine());
} else if (isObject(property)) {
if (nodeInstanceServer()->hasInstanceForObject(oldParent)) {
nodeInstanceServer()->instanceForObject(oldParent).resetProperty(oldParentProperty);
}
}
if (object && object->parent())
object->setParent(0);
}
QVariant QGpgMECryptoConfigEntry::stringToValue( const QString& str, bool unescape ) const
{
const bool isString = isStringType();
if ( isList() ) {
if ( argType() == ArgType_None ) {
bool ok = true;
const QVariant v = str.isEmpty() ? 0U : str.toUInt( &ok ) ;
if ( !ok )
kWarning(5150) << "list-of-none should have an unsigned int as value:" << str;
return v;
}
QList<QVariant> lst;
QStringList items = str.split( ',', QString::SkipEmptyParts );
for( QStringList::const_iterator valit = items.constBegin(); valit != items.constEnd(); ++valit ) {
QString val = *valit;
if ( isString ) {
if ( val.isEmpty() ) {
lst << QVariant( QString() );
continue;
}
else if ( unescape ) {
if( val[0] != '"' ) // see README.gpgconf
kWarning(5150) <<"String value should start with '\"' :" << val;
val = val.mid( 1 );
}
}
lst << QVariant( unescape ? gpgconf_unescape( val ) : val );
}
return lst;
} else { // not a list
QString val( str );
if ( isString ) {
if ( val.isEmpty() )
return QVariant( QString() ); // not set [ok with lists too?]
else if ( unescape ) {
if( val[0] != '"' ) // see README.gpgconf
kWarning(5150) <<"String value should start with '\"' :" << val;
val = val.mid( 1 );
}
}
return QVariant( unescape ? gpgconf_unescape( val ) : val );
}
}
static SEXP removeAttrib(SEXP vec, SEXP name)
{
SEXP t;
if(TYPEOF(vec) == CHARSXP)
error("cannot set attribute on a CHARSXP");
if (name == R_NamesSymbol && isList(vec)) {
for (t = vec; t != R_NilValue; t = CDR(t))
SET_TAG(t, R_NilValue);
return R_NilValue;
}
else {
if (name == R_DimSymbol)
SET_ATTRIB(vec, stripAttrib(R_DimNamesSymbol, ATTRIB(vec)));
SET_ATTRIB(vec, stripAttrib(name, ATTRIB(vec)));
if (name == R_ClassSymbol)
SET_OBJECT(vec, 0);
}
return R_NilValue;
}
KUrl::List ConfigEntry::urlValueList() const
{
assert( m_argType == Path || m_argType == Url || m_argType == LdapUrl );
assert( isList() );
const QStringList lst = m_value.toStringList();
KUrl::List ret;
Q_FOREACH( const QString &i, lst )
{
if ( m_argType == Path ) {
KUrl url;
url.setPath( i );
ret << url;
} else {
ret << parseUrl( m_argType, i );
}
}
return ret;
}
INLINE_FUN Rboolean isVectorizable(SEXP s)
{
if (s == R_NilValue) return TRUE;
else if (isNewList(s)) {
R_xlen_t i, n;
n = XLENGTH(s);
for (i = 0 ; i < n; i++)
if (!isVector(VECTOR_ELT(s, i)) || XLENGTH(VECTOR_ELT(s, i)) > 1)
return FALSE;
return TRUE;
}
else if (isList(s)) {
for ( ; s != R_NilValue; s = CDR(s))
if (!isVector(CAR(s)) || LENGTH(CAR(s)) > 1) return FALSE;
return TRUE;
}
else return FALSE;
}
Var& Var::getAt(std::size_t n)
{
if (isVector())
return holderImpl<std::vector<Var>,
InvalidAccessException>("Not a vector.")->operator[](n);
else if (isList())
return holderImpl<std::list<Var>,
InvalidAccessException>("Not a list.")->operator[](n);
else if (isDeque())
return holderImpl<std::deque<Var>,
InvalidAccessException>("Not a deque.")->operator[](n);
else if (isStruct())
return structIndexOperator(holderImpl<Struct<int>,
InvalidAccessException>("Not a struct."), static_cast<int>(n));
else if (!isString() && !isEmpty() && (n == 0))
return *this;
throw RangeException("Index out of bounds.");
}
CELL * p_append(CELL * params)
{
CELL * list = NULL;
CELL * firstCell = NULL;
CELL * copy = NULL;
CELL * cell;
while(params != nilCell)
{
params = getEvalDefault(params, &cell);
if(!isList(cell->type))
{
if(copy == NULL)
{
if(cell->type == CELL_STRING)
return(appendString(cell, params, NULL, 0, FALSE, TRUE));
else if(cell->type == CELL_ARRAY)
return(appendArray(cell, params));
return(errorProcExt(ERR_ARRAY_LIST_OR_STRING_EXPECTED, cell));
}
return(errorProcExt(ERR_LIST_EXPECTED, cell));
}
if(list == NULL)
list = getCell(cell->type);
copy = copyList((CELL *)cell->contents);
if(copy == nilCell) continue;
if(firstCell == NULL) list->contents = (UINT)copy;
else firstCell->next = copy;
firstCell = lastCellCopied;
}
if(list == NULL)
return(getCell(CELL_EXPRESSION));
return(list);
}
sExpression *evalIf(sList *arguments, sEnvironment *env){
sExpression *temp = cdr(arguments);
if(isList(temp)){
sList *args = toList(temp);
sExpression *predicate;
if(LAZY_EVAL){
predicate = actualValue(car(args), env);
}else{
predicate = eval(car(args), env);
}
sExpression *trueExp = car(toList(cdr(args)));
sExpression *falseExp = car(toList(cdr(toList(cdr(args)))));
if(isTrue(predicate)){
return eval(trueExp, env);
}else{
return eval(falseExp, env);
}
}
return &sNull;
}
////////////////////////////////////////////////////////////////////////////////
// When a Lexer object is constructed with a string, this method walks through
// the stream of low-level tokens.
bool Lexer::token (std::string& token, Lexer::Type& type)
{
// Eat white space.
while (isWhitespace (_text[_cursor]))
utf8_next_char (_text, _cursor);
// Terminate at EOS.
if (isEOS ())
return false;
// The sequence is specific, and must follow these rules:
// - date < duration < uuid < identifier
// - uuid < hex < number
// - url < pair < identifier
// - hex < number
// - separator < tag < operator
// - path < substitution < pattern
// - word last
if (isString (token, type, '\'') ||
isString (token, type, '"') ||
isDate (token, type) ||
isDuration (token, type) ||
isURL (token, type) ||
isPair (token, type) ||
isDOM (token, type) ||
isUUID (token, type) ||
isHexNumber (token, type) ||
isNumber (token, type) ||
isSeparator (token, type) ||
isList (token, type) ||
isTag (token, type) ||
isPath (token, type) ||
isSubstitution (token, type) ||
isPattern (token, type) ||
isOperator (token, type) ||
isIdentifier (token, type) ||
isWord (token, type))
return true;
return false;
}
vector<ofxPythonObject> ofxPythonObject::asVector() const
{
std::vector<ofxPythonObject> v;
if(isList())
{
int len = PyList_Size(get()->obj);
for (int i = 0; i<len; ++i)
{
v.push_back(make_object_borrowed(PyList_GetItem(get()->obj,i)));
}
}
else if(isTuple())
{
int len = PyTuple_Size(get()->obj);
for (int i = 0; i<len; ++i)
{
v.push_back(make_object_borrowed(PyTuple_GetItem(get()->obj,i)));
}
}
return v;
}
void ObjectNodeInstance::addToNewProperty(QObject *object, QObject *newParent, const QString &newParentProperty)
{
QDeclarativeProperty property(newParent, newParentProperty, context());
if (isList(property)) {
QDeclarativeListReference list = qvariant_cast<QDeclarativeListReference>(property.read());
if (!hasFullImplementedListInterface(list)) {
qWarning() << "Property list interface not fully implemented for Class " << property.property().typeName() << " in property " << property.name() << "!";
return;
}
list.append(object);
} else if (isObject(property)) {
property.write(objectToVariant(object));
}
object->setParent(newParent);
Q_ASSERT(objectToVariant(object).isValid());
}
CELL * p_chop(CELL * params)
{
size_t number = 1;
size_t length = 0;
CELL * next;
#ifdef SUPPORT_UTF8
char * ptr;
#endif
next = getEvalDefault(params, ¶ms);
if(next != nilCell)
getInteger(next, (UINT *)&number);
if(params->type == CELL_STRING)
{
#ifndef SUPPORT_UTF8
length = params->aux - 1;
if(number > length) number = length;
length = length - number;
return stuffStringN((char *)params->contents, length);
#else
length = utf8_wlen((char *)params->contents);
if(number > length) number = length;
length = length - number;
ptr = (char *)params->contents;
while(length--)
ptr += utf8_1st_len(ptr);
return stuffStringN((char *)params->contents, ptr - (char *)params->contents);
#endif
}
if(!isList(params->type))
return(errorProc(ERR_LIST_OR_STRING_EXPECTED));
length = listlen((CELL *)params->contents);
if(number > length) number = length;
return(sublist((CELL *)params->contents, 0, length - number));
}
Handle_ptr LambdaCommand::execute( Context &ctx, Environment *env, Handle_ptr expr)
{
MCAssertValidInstance();
assert( 0 != env && 0 != ctx.eval && 0 != expr);
Handle_ptr args = expr->cdr();
if (!isList( args->car())) {
throw TypeException( "list", __FILE__, __LINE__);
}
// collect argument names and check if argument specification is valid
std::list<Handle_ptr> argumentList;
if (!eq( args->car(), ctx.NIL)) {
std::back_insert_iterator<std::list<Handle_ptr> > iiter( argumentList);
copyList( args->car(), iiter);
std::list<Handle_ptr>::iterator pos;
for (pos=argumentList.begin(); pos!=argumentList.end(); ++pos) {
if (!(*pos)->hasType( Handle::ntSYMBOL)) {
throw TypeException( "symbol", __FILE__, __LINE__);
}
}
} else {
// empty argument list
std::cerr << "lambda: empty argument list" << std::endl;
}
#if defined( DEBUG) && DEBUG > 3
std::cerr << "create closure with " << argumentList.size() << " arguments."
<< std::endl;
std::cerr << " body: ";
printList( args->cdr(), std::cerr); std::cerr << std::endl;
std::cerr << " args: ";
std::list<Handle_ptr>::iterator pos;
for (pos=argumentList.begin(); pos!=argumentList.end(); ++pos)
std::cerr << *(*pos) << ' ';
std::cerr << std::endl;
#endif
return ctx.factory->makeClosure( argumentList, env, args->cdr());
}
Tree addElement(Tree e, Tree l)
{
if(isList(l))
{
if(e < hd(l))
{
return cons(e, l);
}
else if(e == hd(l))
{
return l;
}
else
{
return cons(hd(l), addElement(e, tl(l)));
}
}
else
{
return cons(e, nil);
}
}
CELL * p_slice(CELL * params)
{
CELL * cell;
ssize_t offset;
ssize_t length;
params = getEvalDefault(params, &cell);
params = getInteger(params, (UINT *)&offset);
if(params != nilCell)
getInteger(params, (UINT *)&length);
else
length = MAX_LONG;
if(isList(cell->type))
return(sublist((CELL *)cell->contents, offset, length));
else if(cell->type == CELL_STRING)
return(substring((char *)cell->contents, cell->aux - 1, offset, length));
else if(cell->type == CELL_ARRAY)
return(subarray(cell, offset, length));
return(errorProcExt(ERR_LIST_OR_STRING_EXPECTED, params));
}
Tree remElement(Tree e, Tree l)
{
if(isList(l))
{
if(e < hd(l))
{
return l;
}
else if(e == hd(l))
{
return tl(l);
}
else
{
return cons(hd(l), remElement(e, tl(l)));
}
}
else
{
return nil;
}
}
SEXP attribute_hidden mkCLOSXP(SEXP formals, SEXP body, SEXP rho)
{
SEXP c;
PROTECT(formals);
PROTECT(body);
PROTECT(rho);
c = allocSExp(CLOSXP);
#ifdef not_used_CheckFormals
if(isList(formals))
SET_FORMALS(c, formals);
else
error(_("invalid formal arguments for 'function'"));
#else
SET_FORMALS(c, formals);
#endif
switch (TYPEOF(body)) {
case CLOSXP:
case BUILTINSXP:
case SPECIALSXP:
case DOTSXP:
case ANYSXP:
error(_("invalid body argument for 'function'"));
break;
default:
SET_BODY(c, body);
break;
}
if(rho == R_NilValue)
SET_CLOENV(c, R_GlobalEnv);
else
SET_CLOENV(c, rho);
UNPROTECT(3);
return c;
}
static void *applySyntaxToRule(sExpression *key, sExpression *value, sExpression *rule){
if(isList(key) && isList(cdr(toList(key))) && isSymbol(cadr(toList(key))) && (strcmp(toSymb(cadr(toList(key)))->name, "...") == 0) &&
isList(rule) && isList(cdr(toList(rule))) && isSymbol(cadr(toList(rule))) && (strcmp(toSymb(cadr(toList(rule)))->name, "...") == 0))
{
if(isList(value)){
if(isSymbol(car(toList(rule)))){
sExpression *tempRule = newSymbol(toSymb(car(toList(rule)))->name);
evalSyntaxRuleIter(car(toList(key)), car(toList(value)), tempRule);
if(isSymbol(tempRule) && strcmp(toSymb(tempRule)->name, toSymb(car(toList(rule)))->name) == 0){
//printExp(rule);
}
else{
if(isNull(cdr(toList(value)))){
rule->value = cons(tempRule, &sNull)->value;
}
else{
rule->value = cons(tempRule,
cons(car(toList(rule)),
cdr(toList(rule))))->value;
rule->type = LIST_TAG;
applySyntaxToRule(key, cdr(toList(value)), cdr(toList(rule)));
}
}
}
}
}
else if(isList(rule)){
applySyntaxToRule(key, value, car(toList(rule)));
applySyntaxToRule(key, value, cdr(toList(rule)));
}
else if(isSymbol(rule) && strcmp(toSymb(key)->name, toSymb(rule)->name) == 0){
rule->value = value->value;
rule->type = value->type;
}
}
/* ========================================================================
* This function will analyze expression and fill in EXPRESSION structure
* holding:
* left part (lp)
* right part (rp)
* If right part isn't a signal name signal flag = false, number = true
* otherwise flags are assigned other way round
* If signal name is in MDD then set inMDD = true;
* If anything goes wrong set error = TRUE and give up
* IMPORTATNT: function assumes all blanks are stripped from expr arg
* UPD: however we call RemoveSpace again to sleep better
* ======================================================================== */
int ParseExpression(char *expr, EXPRESSION *exprData)
{
char *ch = NULL;
char buf[1024] = "";
if (!expr)
return -1;
// Do cleanup
memset(exprData, '\x0', sizeof(EXPRESSION));
strcpy(buf, expr);
// Strip spaces if any
RemoveSpace(buf);
ch = strstr(buf, "=");
if (ch) // There's equal sign, treat expr as an Y = X style expression
{
// Get right part, then terminate at '='
strcpy(exprData->rp, ch + 1);
*ch = '\x0';
// Get left part
strcpy(exprData->lp, buf);
// Check if the right part is a list (for OR, AND etc)
// If it is not:
// 1. Check if the right part is numeric
// 2. If it is not then treat it as a signal name
if ((isList(exprData->rp)) == RP_LIST) // right part is comma-sep list
{
exprData->list = true;
exprData->signal = false;
exprData->number = false;
// That's it for the list - we already have it in rp member, no further processing needed
}
else // right part is an individual signal or number
{
if ((isNumeric(exprData->rp)) == RP_SIGNAL) // signal - we'll make MDD name of it
{
// make MDD point name and store it to mddname, separately from rp
memset(buf, '\x0', sizeof(buf));
// set flag if negation needed that is '!' stands in front of signal name
if (exprData->rp[0] == '!')
{
exprData->Not = true;
sprintf(buf, "ra%s%s", (exprData->rp) + 1, conf.suffix);
fprintf(stderr, "ParseExpression: negation found: rp = %s buf = %s\n", exprData->rp, buf);
}
else
{
exprData->Not = false;
sprintf(buf, "ra%s%s", exprData->rp, conf.suffix);
}
strcpy(exprData->mddname, buf);
exprData->list = false;
exprData->signal = true;
exprData->number = false;
} // number on the right part - set flags and that's it
else
{
exprData->signal = false;
exprData->list = false;
exprData->number = true;
}
}
return IAM_EXPRESSION;
}
// expr isn't an expression in fact
exprData->error = true;
return IAMNOT_EXPRESSION;
}
ostream& boxpp::print (ostream& fout) const
{
int i, id;
double r;
prim0 p0;
prim1 p1;
prim2 p2;
prim3 p3;
prim4 p4;
prim5 p5;
Tree t1, t2, t3, ff, label, cur, min, max, step, type, name, file, arg,
body, fun, args, abstr, genv, vis, lenv, ldef, slot,
ident, rules;
const char* str;
xtended* xt = (xtended*) getUserData(box);
// primitive elements
if (xt) fout << xt->name();
else if (isBoxInt(box, &i)) fout << i;
else if (isBoxReal(box, &r)) fout << T(r);
else if (isBoxCut(box)) fout << '!';
else if (isBoxWire(box)) fout << '_';
else if (isBoxIdent(box, &str)) fout << str;
else if (isBoxPrim0(box, &p0)) fout << prim0name(p0);
else if (isBoxPrim1(box, &p1)) fout << prim1name(p1);
else if (isBoxPrim2(box, &p2)) fout << prim2name(p2);
else if (isBoxPrim3(box, &p3)) fout << prim3name(p3);
else if (isBoxPrim4(box, &p4)) fout << prim4name(p4);
else if (isBoxPrim5(box, &p5)) fout << prim5name(p5);
else if (isBoxAbstr(box,arg,body)) fout << "\\" << boxpp(arg) << ".(" << boxpp(body) << ")";
else if (isBoxAppl(box, fun, args)) fout << boxpp(fun) << boxpp(args) ;
else if (isBoxWithLocalDef(box, body, ldef)) fout << boxpp(body) << " with { " << envpp(ldef) << " }";
// foreign elements
else if (isBoxFFun(box, ff)) {
fout << "ffunction(" << type2str(ffrestype(ff));
Tree namelist = nth(ffsignature(ff),1);
char sep = ' ';
for (int i = 0; i < gFloatSize; i++) {
fout << sep << tree2str(nth(namelist,i));
sep = '|';
}
sep = '(';
for (int i = 0; i < ffarity(ff); i++) {
fout << sep << type2str(ffargtype(ff, i));
sep = ',';
}
fout << ')';
fout << ',' << ffincfile(ff) << ',' << fflibfile(ff) << ')';
} else if (isBoxFConst(box, type, name, file))
fout << "fconstant(" << type2str(tree2int(type)) << ' ' << tree2str(name) << ", " << tree2str(file) << ')';
else if (isBoxFVar(box, type, name, file))
fout << "fvariable(" << type2str(tree2int(type)) << ' ' << tree2str(name) << ", " << tree2str(file) << ')';
// block diagram binary operator
else if (isBoxSeq(box, t1, t2)) streambinop(fout, t1, " : ", t2, 1, priority);
else if (isBoxSplit(box, t1, t2)) streambinop(fout, t1, "<:", t2, 1, priority);
else if (isBoxMerge(box, t1, t2)) streambinop(fout, t1, ":>", t2, 1, priority);
else if (isBoxPar(box, t1, t2)) streambinop(fout, t1,",",t2, 2, priority);
else if (isBoxRec(box, t1, t2)) streambinop(fout, t1,"~",t2, 4, priority);
// iterative block diagram construction
else if (isBoxIPar(box, t1, t2, t3)) fout << "par(" << boxpp(t1) << ", " << boxpp(t2) << ") {" << boxpp(t3) << "}";
else if (isBoxISeq(box, t1, t2, t3)) fout << "seq(" << boxpp(t1) << ", " << boxpp(t2) << ") {" << boxpp(t3) << "}";
else if (isBoxISum(box, t1, t2, t3)) fout << "sum(" << boxpp(t1) << ", " << boxpp(t2) << ") {" << boxpp(t3) << "}";
else if (isBoxIProd(box, t1, t2, t3)) fout << "prod(" << boxpp(t1) << ", " << boxpp(t2) << ") {" << boxpp(t3) << "}";
else if (isBoxInputs(box, t1)) fout << "inputs(" << boxpp(t1) << ")";
else if (isBoxOutputs(box, t1)) fout << "outputs(" << boxpp(t1) << ")";
// user interface
else if (isBoxButton(box, label)) fout << "button(" << tree2quotedstr(label) << ')';
else if (isBoxCheckbox(box, label)) fout << "checkbox(" << tree2quotedstr(label) << ')';
else if (isBoxVSlider(box, label, cur, min, max, step)) {
fout << "vslider("
<< tree2quotedstr(label) << ", "
<< boxpp(cur) << ", "
<< boxpp(min) << ", "
<< boxpp(max) << ", "
<< boxpp(step)<< ')';
}
else if (isBoxHSlider(box, label, cur, min, max, step)) {
fout << "hslider("
<< tree2quotedstr(label) << ", "
<< boxpp(cur) << ", "
<< boxpp(min) << ", "
<< boxpp(max) << ", "
<< boxpp(step)<< ')';
}
else if (isBoxVGroup(box, label, t1)) {
fout << "vgroup(" << tree2quotedstr(label) << ", " << boxpp(t1, 0) << ')';
}
else if (isBoxHGroup(box, label, t1)) {
fout << "hgroup(" << tree2quotedstr(label) << ", " << boxpp(t1, 0) << ')';
}
else if (isBoxTGroup(box, label, t1)) {
fout << "tgroup(" << tree2quotedstr(label) << ", " << boxpp(t1, 0) << ')';
}
else if (isBoxHBargraph(box, label, min, max)) {
fout << "hbargraph("
<< tree2quotedstr(label) << ", "
<< boxpp(min) << ", "
<< boxpp(max) << ')';
}
else if (isBoxVBargraph(box, label, min, max)) {
fout << "vbargraph("
<< tree2quotedstr(label) << ", "
<< boxpp(min) << ", "
<< boxpp(max) << ')';
}
else if (isBoxNumEntry(box, label, cur, min, max, step)) {
fout << "nentry("
<< tree2quotedstr(label) << ", "
<< boxpp(cur) << ", "
<< boxpp(min) << ", "
<< boxpp(max) << ", "
<< boxpp(step)<< ')';
}
else if (isNil(box)) {
fout << "()" ;
}
else if (isList(box)) {
Tree l = box;
char sep = '(';
do {
fout << sep << boxpp(hd(l));
sep = ',';
l = tl(l);
} while (isList(l));
fout << ')';
} else if (isBoxWaveform(box)) {
fout << "waveform";
char sep = '{';
for (int i=0; i<box->arity(); i++) {
fout << sep << boxpp(box->branch(i));
sep = ',';
}
fout << '}';
/*
size_t n = box->arity();
if (n < 6) {
// small waveform, print all data
fout << "waveform";
char sep = '{';
for (size_t i=0; i<n; i++) {
fout << sep << boxpp(box->branch(i));
sep = ',';
}
fout << '}';
} else {
// large waveform print only first and last values
fout << "waveform{" << box->branch(0) << ", ..<" << n-2 << ">..," << box->branch(n-1) << "}";
}
*/
} else if (isBoxEnvironment(box)) {
fout << "environment";
} else if (isClosure(box, abstr, genv, vis, lenv)) {
fout << "closure[" << boxpp(abstr)
<< ", genv = " << envpp(genv)
<< ", lenv = " << envpp(lenv)
<< "]";
}
else if (isBoxComponent(box, label)) {
fout << "component("
<< tree2quotedstr(label) << ')';
}
else if (isBoxAccess(box, t1, t2)) {
fout << boxpp(t1) << '.' << boxpp(t2);
}
else if (isImportFile(box, label)) {
fout << "import("
<< tree2quotedstr(label) << ')';
}
else if (isBoxSlot(box, &id)) {
//fout << "#" << id;
fout << "x" << id;
}
else if (isBoxSymbolic(box, slot, body)) {
fout << "\\(" << boxpp(slot) << ").(" << boxpp(body) << ")";
}
// Pattern Matching Extensions
else if (isBoxCase(box, rules)) {
fout << "case {";
while (!isNil(rules)) {
printRule(fout, hd(rules));
rules = tl(rules);
}
fout << "}";
}
#if 1
// more useful for debugging output
else if (isBoxPatternVar(box, ident)) {
fout << "<" << boxpp(ident) << ">";
}
#else
// beautify messages involving lhs patterns
else if (isBoxPatternVar(box, ident)) {
fout << boxpp(ident);
}
#endif
else if (isBoxPatternMatcher(box)) {
fout << "PM[" << box << "]";
}
else if (isBoxError(box)) {
fout << "ERROR";
}
//else if (isImportFile(box, filename)) {
// printf("filename %s\n", tree2str(filename));
// fout << tree2quotedstr(filename);
//}
// None of the previous tests succeded, then it is not a valid box
else {
cerr << "Error in box::print() : " << *box << " is not a valid box" << endl;
exit(1);
}
return fout;
}
SEXP attribute_hidden do_subset2_dflt(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP ans, dims, dimnames, indx, subs, x;
int i, ndims, nsubs;
int drop = 1, pok, exact = -1;
int named_x;
R_xlen_t offset = 0;
PROTECT(args);
ExtractDropArg(args, &drop);
/* Is partial matching ok? When the exact arg is NA, a warning is
issued if partial matching occurs.
*/
exact = ExtractExactArg(args);
if (exact == -1)
pok = exact;
else
pok = !exact;
x = CAR(args);
/* This code was intended for compatibility with S, */
/* but in fact S does not do this. Will anyone notice? */
if (x == R_NilValue) {
UNPROTECT(1); /* args */
return x;
}
/* Get the subscripting and dimensioning information */
/* and check that any array subscripting is compatible. */
subs = CDR(args);
if(0 == (nsubs = length(subs)))
errorcall(call, _("no index specified"));
dims = getAttrib(x, R_DimSymbol);
ndims = length(dims);
if(nsubs > 1 && nsubs != ndims)
errorcall(call, _("incorrect number of subscripts"));
/* code to allow classes to extend environment */
if(TYPEOF(x) == S4SXP) {
x = R_getS4DataSlot(x, ANYSXP);
if(x == R_NilValue)
errorcall(call, _("this S4 class is not subsettable"));
}
PROTECT(x);
/* split out ENVSXP for now */
if( TYPEOF(x) == ENVSXP ) {
if( nsubs != 1 || !isString(CAR(subs)) || length(CAR(subs)) != 1 )
errorcall(call, _("wrong arguments for subsetting an environment"));
ans = findVarInFrame(x, installTrChar(STRING_ELT(CAR(subs), 0)));
if( TYPEOF(ans) == PROMSXP ) {
PROTECT(ans);
ans = eval(ans, R_GlobalEnv);
UNPROTECT(1); /* ans */
} else SET_NAMED(ans, 2);
UNPROTECT(2); /* args, x */
if(ans == R_UnboundValue)
return(R_NilValue);
if (NAMED(ans))
SET_NAMED(ans, 2);
return ans;
}
/* back to the regular program */
if (!(isVector(x) || isList(x) || isLanguage(x)))
errorcall(call, R_MSG_ob_nonsub, type2char(TYPEOF(x)));
named_x = NAMED(x); /* x may change below; save this now. See PR#13411 */
if(nsubs == 1) { /* vector indexing */
SEXP thesub = CAR(subs);
int len = length(thesub);
if (len > 1) {
#ifdef SWITCH_TO_REFCNT
if (IS_GETTER_CALL(call)) {
/* this is (most likely) a getter call in a complex
assighment so we duplicate as needed. The original
x should have been duplicated if it might be
shared */
if (MAYBE_SHARED(x))
error("getter call used outside of a complex assignment.");
x = vectorIndex(x, thesub, 0, len-1, pok, call, TRUE);
}
else
x = vectorIndex(x, thesub, 0, len-1, pok, call, FALSE);
#else
x = vectorIndex(x, thesub, 0, len-1, pok, call, FALSE);
#endif
named_x = NAMED(x);
UNPROTECT(1); /* x */
PROTECT(x);
}
SEXP xnames = PROTECT(getAttrib(x, R_NamesSymbol));
offset = get1index(thesub, xnames,
xlength(x), pok, len > 1 ? len-1 : -1, call);
UNPROTECT(1); /* xnames */
if (offset < 0 || offset >= xlength(x)) {
/* a bold attempt to get the same behaviour for $ and [[ */
if (offset < 0 && (isNewList(x) ||
isExpression(x) ||
isList(x) ||
isLanguage(x))) {
UNPROTECT(2); /* args, x */
return R_NilValue;
}
else errorcall(call, R_MSG_subs_o_b);
}
} else { /* matrix indexing */
/* Here we use the fact that: */
/* CAR(R_NilValue) = R_NilValue */
/* CDR(R_NilValue) = R_NilValue */
int ndn; /* Number of dimnames. Unlikely to be anything but
0 or nsubs, but just in case... */
PROTECT(indx = allocVector(INTSXP, nsubs));
dimnames = getAttrib(x, R_DimNamesSymbol);
ndn = length(dimnames);
for (i = 0; i < nsubs; i++) {
INTEGER(indx)[i] = (int)
get1index(CAR(subs),
(i < ndn) ? VECTOR_ELT(dimnames, i) : R_NilValue,
INTEGER(indx)[i], pok, -1, call);
subs = CDR(subs);
if (INTEGER(indx)[i] < 0 ||
INTEGER(indx)[i] >= INTEGER(dims)[i])
errorcall(call, R_MSG_subs_o_b);
}
offset = 0;
for (i = (nsubs - 1); i > 0; i--)
offset = (offset + INTEGER(indx)[i]) * INTEGER(dims)[i - 1];
offset += INTEGER(indx)[0];
UNPROTECT(1); /* indx */
}
if(isPairList(x)) {
#ifdef LONG_VECTOR_SUPPORT
if (offset > R_SHORT_LEN_MAX)
error("invalid subscript for pairlist");
#endif
ans = CAR(nthcdr(x, (int) offset));
if (named_x > NAMED(ans))
SET_NAMED(ans, named_x);
} else if(isVectorList(x)) {
/* did unconditional duplication before 2.4.0 */
ans = VECTOR_ELT(x, offset);
if (named_x > NAMED(ans))
SET_NAMED(ans, named_x);
} else {
ans = allocVector(TYPEOF(x), 1);
switch (TYPEOF(x)) {
case LGLSXP:
case INTSXP:
INTEGER(ans)[0] = INTEGER(x)[offset];
break;
case REALSXP:
REAL(ans)[0] = REAL(x)[offset];
break;
case CPLXSXP:
COMPLEX(ans)[0] = COMPLEX(x)[offset];
break;
case STRSXP:
SET_STRING_ELT(ans, 0, STRING_ELT(x, offset));
break;
case RAWSXP:
RAW(ans)[0] = RAW(x)[offset];
break;
default:
UNIMPLEMENTED_TYPE("do_subset2", x);
}
}
UNPROTECT(2); /* args, x */
return ans;
}
Obj_ptr Quasiquote(const ParseTree_ptr &root, env_ptr & env)
{
if (root == nullptr)
return nullptr;
std::string token = root->getToken();
bool numberFlag = true, rationalFlag = false, realFlag = false, idenFlag = true;
checkToken(token, numberFlag, rationalFlag, realFlag, idenFlag);
if ( numberFlag==true ) // numerical constant
{
//----integer-----
if (!rationalFlag && !realFlag)
return Obj_ptr( new IntegerObj( bigInteger(token) ) );
//----rational----
else if (rationalFlag)
return Obj_ptr( new RationalObj( bigRational(token) ) );
//----real--------
else
return Obj_ptr( new RealObj( bigReal(token) ) );
}
else if (token[0]=='\"') // string constant
return Obj_ptr( new StringObj(token.substr(1, token.size()-2)) );
else if (token[0]=='#')
{
// character constant
if (token[1]=='\\')
{
if (token=="#\\newline")
return Obj_ptr( new CharObj('\n') );
else if (token=="#\\space")
return Obj_ptr( new CharObj(' ') );
else if (token=="#\\tab")
return Obj_ptr( new CharObj('\t') );
else
return Obj_ptr( new CharObj(token[2]) );
}
// boolean constant
else
{
if (token[1]=='t')
return Obj_ptr( new BoolObj(true) );
else
return Obj_ptr( new BoolObj(false) );
}
}
else if (token=="\'")
return Quote(root->getSon());
else if (token=="`")
return Quasiquote(root->getSon(), env);
else if (token=="()")
return quasiquoteMakeList(root->getSon(), env);
else if (token==",")
return evaluate(root->getSon(), env);
else if (token==",@")
{
Obj_ptr obj(evaluate(root->getSon(), env));
if (!isList(obj))
throw syntaxError("there must be a list after \',@\'"); //W.T.F.
throw syntaxError("sorry for no support of \',@\' now");
}
else
return Obj_ptr( new SymbolObj( token ) );
}
static SEXP rep(SEXP s, SEXP ncopy)
{
int i, ns, na, nc;
SEXP a, t;
if (!isVector(ncopy))
error(_("rep() incorrect type for second argument"));
if (!isVector(s) && (!isList(s)))
error(_("attempt to replicate non-vector"));
if ((length(ncopy) == length(s)))
return rep2(s, ncopy);
if ((length(ncopy) != 1))
error(_("invalid number of copies in rep()"));
if ((nc = asInteger(ncopy)) == NA_INTEGER || nc < 0)/* nc = 0 ok */
error(_("invalid number of copies in rep()"));
ns = length(s);
na = nc * ns;
if (isVector(s))
a = allocVector(TYPEOF(s), na);
else
a = allocList(na);
PROTECT(a);
switch (TYPEOF(s)) {
case LGLSXP:
for (i = 0; i < na; i++)
LOGICAL(a)[i] = LOGICAL(s)[i % ns];
break;
case INTSXP:
for (i = 0; i < na; i++)
INTEGER(a)[i] = INTEGER(s)[i % ns];
break;
case REALSXP:
for (i = 0; i < na; i++)
REAL(a)[i] = REAL(s)[i % ns];
break;
case CPLXSXP:
for (i = 0; i < na; i++)
COMPLEX(a)[i] = COMPLEX(s)[i % ns];
break;
case STRSXP:
for (i = 0; i < na; i++)
SET_STRING_ELT(a, i, STRING_ELT(s, i% ns));
break;
case LISTSXP:
i = 0;
for (t = a; t != R_NilValue; t = CDR(t), i++)
SETCAR(t, duplicate(CAR(nthcdr(s, (i % ns)))));
break;
case VECSXP:
i = 0;
for (i = 0; i < na; i++)
SET_VECTOR_ELT(a, i, duplicate(VECTOR_ELT(s, i% ns)));
break;
case RAWSXP:
for (i = 0; i < na; i++)
RAW(a)[i] = RAW(s)[i % ns];
break;
default:
UNIMPLEMENTED_TYPE("rep", s);
}
if (inherits(s, "factor")) {
SEXP tmp;
if(inherits(s, "ordered")) {
PROTECT(tmp = allocVector(STRSXP, 2));
SET_STRING_ELT(tmp, 0, mkChar("ordered"));
SET_STRING_ELT(tmp, 1, mkChar("factor"));
}
else {
PROTECT(tmp = allocVector(STRSXP, 1));
SET_STRING_ELT(tmp, 0, mkChar("factor"));
}
setAttrib(a, R_ClassSymbol, tmp);
UNPROTECT(1);
setAttrib(a, R_LevelsSymbol, getAttrib(s, R_LevelsSymbol));
}
UNPROTECT(1);
return a;
}
ostream& ppsig::print (ostream& fout) const
{
int i;
double r;
Tree c, sel, x, y, z, u, var, le, label, id, ff, largs, type, name, file;
if ( isList(sig) ) {
printlist(fout, sig);
}
else if ( isProj(sig, &i, x) ) {
fout << "proj" << i << '(' << ppsig(x, fEnv) << ')';
}
else if ( isRec(sig, var, le) ) {
printrec(fout, var, le, fHideRecursion /*&& (getRecursivness(sig)==0)*/ );
}
// debruinj notation
else if ( isRec(sig, le) ) {
printrec(fout, le, fHideRecursion );
}
else if ( isRef(sig, i) ) {
fout << "REF[" << i << "]";
}
else if ( getUserData(sig) ) {
printextended(fout, sig);
}
else if ( isSigInt(sig, &i) ) {
fout << i;
}
else if ( isSigReal(sig, &r) ) {
fout << T(r);
}
else if ( isSigWaveform(sig) ) {
fout << "waveform{...}";
}
else if ( isSigInput(sig, &i) ) {
fout << "IN[" << i << "]";
}
else if ( isSigOutput(sig, &i, x) ) {
printout(fout, i, x) ;
}
else if ( isSigDelay1(sig, x) ) {
fout << ppsig(x, fEnv, 9) << "'";
}
//else if ( isSigFixDelay(sig, x, y) ) { printinfix(fout, "@", 8, x, y); }
else if ( isSigFixDelay(sig, x, y) ) {
printFixDelay(fout, x, y);
}
else if ( isSigPrefix(sig, x, y) ) {
printfun(fout, "prefix", x, y);
}
else if ( isSigIota(sig, x) ) {
printfun(fout, "iota", x);
}
else if ( isSigBinOp(sig, &i, x, y) ) {
printinfix(fout, gBinOpTable[i]->fName, gBinOpTable[i]->fPriority, x, y);
}
else if ( isSigFFun(sig, ff, largs) ) {
printff(fout, ff, largs);
}
else if ( isSigFConst(sig, type, name, file) ) {
fout << tree2str(name);
}
else if ( isSigFVar(sig, type, name, file) ) {
fout << tree2str(name);
}
else if ( isSigTable(sig, id, x, y) ) {
printfun(fout, "TABLE", x, y);
}
else if ( isSigWRTbl(sig, id, x, y, z) ) {
printfun(fout, "write", x, y, z);
}
else if ( isSigRDTbl(sig, x, y) ) {
printfun(fout, "read", x, y);
}
else if ( isSigGen(sig, x) ) {
fout << ppsig(x, fEnv, fPriority);
}
else if ( isSigDocConstantTbl(sig, x, y) ) {
printfun(fout, "docConstantTbl", x, y);
}
else if ( isSigDocWriteTbl(sig, x, y, z, u) ) {
printfun(fout, "docWriteTbl", x, y, z, u);
}
else if ( isSigDocAccessTbl(sig, x, y) ) {
printfun(fout, "docAccessTbl", x, y);
}
else if ( isSigSelect2(sig, sel, x, y) ) {
printfun(fout, "select2", sel, x, y);
}
else if ( isSigSelect3(sig, sel, x, y, z) ) {
printfun(fout, "select3", sel, x, y, z);
}
else if ( isSigIntCast(sig, x) ) {
printfun(fout, "int", x);
}
else if ( isSigFloatCast(sig, x) ) {
printfun(fout, "float", x);
}
else if ( isSigButton(sig, label) ) {
printui(fout, "button", label);
}
else if ( isSigCheckbox(sig, label) ) {
printui(fout, "checkbox", label);
}
else if ( isSigVSlider(sig, label,c,x,y,z) ) {
printui(fout, "vslider", label, c, x, y, z);
}
else if ( isSigHSlider(sig, label,c,x,y,z) ) {
printui(fout, "hslider", label, c, x, y, z);
}
else if ( isSigNumEntry(sig, label,c,x,y,z) ) {
printui(fout, "nentry", label, c, x, y, z);
}
else if ( isSigVBargraph(sig, label,x,y,z) ) {
printui(fout, "vbargraph", label, x, y, z);
}
else if ( isSigHBargraph(sig, label,x,y,z) ) {
printui(fout, "hbargraph", label, x, y, z);
}
else if ( isSigAttach(sig, x, y) ) {
printfun(fout, "attach", x, y);
}
else {
cerr << "NOT A SIGNAL : " << *sig << endl;
//exit(1);
}
return fout;
}
/**
* Prepare a "pattern" by replacing variables x by special
* pattern variables ?x.
*
* P[x] -> ?x
* P[x(e)] -> x(P[e])
* P[e(f)] -> P[e](P[f])
* P[e:f] -> P[e]:P[f]
* etc.
*/
static Tree preparePattern(Tree box)
{
// cerr << "preparePattern(" << boxpp(box) << ")" << endl;
int id;
double r;
prim0 p0;
prim1 p1;
prim2 p2;
prim3 p3;
prim4 p4;
prim5 p5;
Tree t1, t2, t3, ff, label, cur, min, max, step, type, name, file, arg,
body, fun, args, ldef, slot,
ident, rules;
xtended* xt = (xtended*)getUserData(box);
// primitive elements
if(xt)
return box;
else if(isBoxIdent(box))
return boxPatternVar(box);
else if(isBoxAppl(box, fun, args))
{
if(isBoxIdent(fun))
return boxAppl(fun, lmap(preparePattern, args));
else
return boxAppl(preparePattern(fun), lmap(preparePattern, args));
}
else if(isBoxAbstr(box, arg, body))
return box;
else if(isBoxInt(box))
return box;
else if(isBoxReal(box, &r))
return box;
else if(isBoxWaveform(box))
return box;
else if(isBoxCut(box))
return box;
else if(isBoxWire(box))
return box;
else if(isBoxPrim0(box, &p0))
return box;
else if(isBoxPrim1(box, &p1))
return box;
else if(isBoxPrim2(box, &p2))
return box;
else if(isBoxPrim3(box, &p3))
return box;
else if(isBoxPrim4(box, &p4))
return box;
else if(isBoxPrim5(box, &p5))
return box;
else if(isBoxWithLocalDef(box, body, ldef))
return boxWithLocalDef(preparePattern(body), ldef);
// foreign elements
else if(isBoxFFun(box, ff))
return box;
else if(isBoxFConst(box, type, name, file))
return box;
else if(isBoxFVar(box, type, name, file))
return box;
// block diagram binary operator
else if(isBoxSeq(box, t1, t2))
return boxSeq(preparePattern(t1), preparePattern(t2));
else if(isBoxSplit(box, t1, t2))
return boxSplit(preparePattern(t1), preparePattern(t2));
else if(isBoxMerge(box, t1, t2))
return boxMerge(preparePattern(t1), preparePattern(t2));
else if(isBoxPar(box, t1, t2))
return boxPar(preparePattern(t1), preparePattern(t2));
else if(isBoxRec(box, t1, t2))
return boxRec(preparePattern(t1), preparePattern(t2));
// iterative block diagram construction
else if(isBoxIPar(box, t1, t2, t3))
return boxIPar(t1, t2, preparePattern(t3));
else if(isBoxISeq(box, t1, t2, t3))
return boxISeq(t1, t2, preparePattern(t3));
else if(isBoxISum(box, t1, t2, t3))
return boxISum(t1, t2, preparePattern(t3));
else if(isBoxIProd(box, t1, t2, t3))
return boxIProd(t1, t2, preparePattern(t3));
// static information
else if(isBoxInputs(box, t1))
return boxInputs(preparePattern(t1));
else if(isBoxOutputs(box, t1))
return boxOutputs(preparePattern(t1));
// user interface
else if(isBoxButton(box, label))
return box;
else if(isBoxCheckbox(box, label))
return box;
else if(isBoxVSlider(box, label, cur, min, max, step))
return box;
else if(isBoxHSlider(box, label, cur, min, max, step))
return box;
else if(isBoxVGroup(box, label, t1))
return boxVGroup(label, preparePattern(t1));
else if(isBoxHGroup(box, label, t1))
return boxHGroup(label, preparePattern(t1));
else if(isBoxTGroup(box, label, t1))
return boxTGroup(label, preparePattern(t1));
else if(isBoxHBargraph(box, label, min, max))
return box;
else if(isBoxVBargraph(box, label, min, max))
return box;
else if(isBoxNumEntry(box, label, cur, min, max, step))
return box;
else if(isNil(box))
return box;
else if(isList(box))
return lmap(preparePattern, box);
else if(isBoxEnvironment(box))
return box;
/* not expected
else if (isClosure(box, abstr, genv, vis, lenv)) {
fout << "closure[" << boxpp(abstr)
<< ", genv = " << envpp(genv)
<< ", lenv = " << envpp(lenv)
<< "]";
}
*/
else if(isBoxComponent(box, label))
return box;
else if(isBoxAccess(box, t1, t2))
return box;
/* not expected
else if (isImportFile(box, label)) {
fout << "import("
<< tree2str(label) << ')';
}
*/
else if(isBoxSlot(box, &id))
return box;
else if(isBoxSymbolic(box, slot, body))
return box;
// Pattern Matching Extensions
else if(isBoxCase(box, rules))
return box;
else if(isBoxPatternVar(box, ident))
return box;
// None of the previous tests succeded, then it is not a valid box
else
{
cerr << "Error in preparePattern() : " << *box << " is not a valid box" << endl;
exit(1);
}
return box;
}
void loop(
const boost::shared_ptr<FunctionCall> &functionCall,
LoopFunction &loopFunction,
OPER *xIn,
XLOPER &xOut) {
// FIXME - xTemp may not be cleaned up properly in the event of an exception.
OPER xTemp, *xMulti;
bool excelToFree = false;
bool xllToFree = false;
// If the input is an array then take its address & carry on
if (xIn->xltype == xltypeMulti) {
xMulti = xIn;
// If the input is a list then call split on it
} else if (isList(xIn)) {
splitOper(xIn, &xTemp);
xMulti = &xTemp;
xllToFree = true;
// If the input is a scalar then just call the function once & return
} else if (xIn->xltype == xltypeNum
|| xIn->xltype == xltypeBool
|| xIn->xltype == xltypeStr) {
LoopIteration<LoopFunction, InputType, OutputType>()(
loopFunction, *xIn, xOut, true);
return;
// Some other input (e.g. a reference) - try to convert to an array
} else {
Excel(xlCoerce, &xTemp, 2, xIn, TempInt(xltypeMulti));
xMulti = &xTemp;
excelToFree = true;
}
xOut.val.array.rows = xMulti->val.array.rows;
xOut.val.array.columns = xMulti->val.array.columns;
int numCells = xMulti->val.array.rows * xMulti->val.array.columns;
xOut.val.array.lparray = new XLOPER[numCells];
xOut.xltype = xltypeMulti | xlbitDLLFree;
int errorCount = 0;
std::ostringstream err;
LoopIteration<LoopFunction, InputType, OutputType> loopIteration;
for (int i=0; i<numCells; ++i) {
try {
loopIteration(loopFunction,
xMulti->val.array.lparray[i],
xOut.val.array.lparray[i],
false);
} catch (const std::exception &e) {
xOut.val.array.lparray[i].xltype = xltypeErr;
xOut.val.array.lparray[i].val.err = xlerrNum;
if (errorCount > ERROR_LIMIT) {
// Limit exceeded. Take no action. For performance reasons we test
// this case first since it's most common on big loop w/many errors
;
} else if (errorCount < ERROR_LIMIT) {
err << std::endl << std::endl
<< "iteration #" << i << " - " << e.what();
errorCount++;
} else { // errorCount == ERROR_LIMIT
err << std::endl << std::endl
<< "iteration #" << i << " - " << e.what()
<< std::endl << std::endl
<< "Count of failed iterations in looping function hit "
<< "limit of " << ERROR_LIMIT + 1 << " - logging discontinued";
errorCount++;
}
}
}
if (errorCount)
RepositoryXL::instance().logError(err.str(), functionCall);
// Free memory
if (excelToFree) {
Excel(xlFree, 0, 1, &xTemp);
} else if (xllToFree) {
freeOper(&xTemp);
}
}
Tree reverse (Tree l)
{
Tree r = gGlobal->nil;
while (isList(l)) { r = cons(hd(l),r); l = tl(l); }
return r;
}
Tree reverseall (Tree l)
{
return isList(l) ? rmap(reverseall, l) : l;
}
void printSignal(Tree sig, FILE* out, int prec)
{
int i;
double r;
Tree x, y, z, u, le, id;
if ( isSigInt(sig, &i) ) { fprintf(out, "%d", i); }
else if ( isSigReal(sig, &r) ) { fprintf(out, "%f", r); }
else if ( isSigInput(sig, &i) ) { fprintf(out, "IN%d", i); }
else if ( isSigOutput(sig, &i, x) ) { fprintf(out, "OUT%d := ", i); printSignal(x, out, 0); }
else if ( isSigBinOp(sig, &i, x, y) ) {
if (prec > binopprec[i]) fputs("(", out);
printSignal(x,out,binopprec[i]); fputs(binopname[i], out); printSignal(y, out, binopprec[i]);
if (prec > binopprec[i]) fputs(")", out);
}
else if ( isSigDelay1(sig, x) ) { fputs("mem(", out); printSignal(x,out,0); fputs(")", out); }
else if ( isSigPrefix(sig, x, y) ) { fputs("prefix(", out); printSignal(x,out,0); fputs(",", out); printSignal(y,out,0); fputs(")", out); }
else if ( isSigAttach(sig, x, y) ) { fputs("attach(", out); printSignal(x,out,0); fputs(",", out); printSignal(y,out,0); fputs(")", out); }
else if ( isSigFixDelay(sig, x, y) ) {
if (prec > 4) fputs("(", out);
printSignal(x,out,4); fputs("@", out); printSignal(y, out, 4);
if (prec > 4) fputs(")", out);
}
else if ( isProj(sig, &i, x) ) { printSignal(x,out,prec); fprintf(out, "#%d", i); }
else if ( isRef(sig, i) ) { fprintf(out, "$%d", i); }
else if ( isRef(sig, x) ) { print(x, out); }
else if ( isRec(sig, le)) { fputs("\\_.", out); printSignal(le, out, prec); }
else if ( isRec(sig, x, le)) { fputs("\\", out); print(x,out); fputs(".", out); printSignal(le, out, prec); }
else if ( isSigTable(sig, id, x, y) ) { fputs("table(", out); printSignal(x,out,0); fputc(',', out); printSignal(y,out,0); fputc(')', out); }
else if ( isSigWRTbl(sig, id, x, y, z) ){ printSignal(x,out,0); fputc('[',out); printSignal(y,out,0); fputs("] := (", out); printSignal(z,out,0); fputc(')', out); }
else if ( isSigRDTbl(sig, x, y) ) { printSignal(x,out,0); fputc('[', out); printSignal(y,out,0); fputc(']', out); }
else if (isSigDocConstantTbl(sig,x,y)) { fputs("sigDocConstantTbl(", out); printSignal(x,out,0); fputc(',', out);
printSignal(y,out,0); fputc(')', out); }
else if (isSigDocWriteTbl(sig,x,y,z,u)) { fputs("sigDocWriteTbl(", out); printSignal(x,out,0); fputc(',', out);
printSignal(y,out,0); fputc(',', out);
printSignal(z,out,0); fputc(',', out);
printSignal(u,out,0); fputc(')', out); }
else if (isSigDocAccessTbl(sig,x,y)) { fputs("sigDocAccessTbl(", out); printSignal(x,out,0); fputc(',', out);
printSignal(y,out,0); fputc(')', out); }
else if ( isSigGen(sig, x) ) { printSignal(x,out,prec); }
else if ( isSigIntCast(sig, x) ) { fputs("int(", out); printSignal(x,out,0); fputs(")", out); }
else if ( isSigFloatCast(sig, x) ) { fputs("float(", out); printSignal(x,out,0); fputs(")", out); }
else if (isList(sig)) {
char sep = '{';
do {
fputc(sep, out);
printSignal(hd(sig), out, 0);
sep=',';
sig = tl(sig);
} while (isList(sig));
fputc('}', out);
}
else
print(sig, out);
}
/* complete.cases(.) */
SEXP compcases(SEXP args)
{
SEXP s, t, u, rval;
int i, len;
args = CDR(args);
len = -1;
for (s = args; s != R_NilValue; s = CDR(s)) {
if (isList(CAR(s))) {
for (t = CAR(s); t != R_NilValue; t = CDR(t))
if (isMatrix(CAR(t))) {
u = getAttrib(CAR(t), R_DimSymbol);
if (len < 0)
len = INTEGER(u)[0];
else if (len != INTEGER(u)[0])
goto bad;
}
else if (isVector(CAR(t))) {
if (len < 0)
len = LENGTH(CAR(t));
else if (len != LENGTH(CAR(t)))
goto bad;
}
else
error(R_MSG_type, type2char(TYPEOF(CAR(t))));
}
/* FIXME : Need to be careful with the use of isVector() */
/* since this includes lists and expressions. */
else if (isNewList(CAR(s))) {
int it, nt;
t = CAR(s);
nt = length(t);
/* 0-column data frames are a special case */
if(nt) {
for (it = 0 ; it < nt ; it++) {
if (isMatrix(VECTOR_ELT(t, it))) {
u = getAttrib(VECTOR_ELT(t, it), R_DimSymbol);
if (len < 0)
len = INTEGER(u)[0];
else if (len != INTEGER(u)[0])
goto bad;
}
else if (isVector(VECTOR_ELT(t, it))) {
if (len < 0)
len = LENGTH(VECTOR_ELT(t, it));
else if (len != LENGTH(VECTOR_ELT(t, it)))
goto bad;
}
else
error(R_MSG_type, "unknown");
}
} else {
u = getAttrib(t, R_RowNamesSymbol);
if (!isNull(u)) {
if (len < 0)
len = LENGTH(u);
else if (len != INTEGER(u)[0])
goto bad;
}
}
}
else if (isMatrix(CAR(s))) {
u = getAttrib(CAR(s), R_DimSymbol);
if (len < 0)
len = INTEGER(u)[0];
else if (len != INTEGER(u)[0])
goto bad;
}
else if (isVector(CAR(s))) {
if (len < 0)
len = LENGTH(CAR(s));
else if (len != LENGTH(CAR(s)))
goto bad;
}
else
error(R_MSG_type, type2char(TYPEOF(CAR(s))));
}
if (len < 0)
error(_("no input has determined the number of cases"));
PROTECT(rval = allocVector(LGLSXP, len));
for (i = 0; i < len; i++) INTEGER(rval)[i] = 1;
/* FIXME : there is a lot of shared code here for vectors. */
/* It should be abstracted out and optimized. */
for (s = args; s != R_NilValue; s = CDR(s)) {
if (isList(CAR(s))) {
/* Now we only need to worry about vectors */
/* since we use mod to handle arrays. */
/* FIXME : using mod like this causes */
/* a potential performance hit. */
for (t = CAR(s); t != R_NilValue; t = CDR(t)) {
u = CAR(t);
for (i = 0; i < LENGTH(u); i++) {
switch (TYPEOF(u)) {
case INTSXP:
case LGLSXP:
if (INTEGER(u)[i] == NA_INTEGER)
INTEGER(rval)[i % len] = 0;
break;
case REALSXP:
if (ISNAN(REAL(u)[i]))
INTEGER(rval)[i % len] = 0;
break;
case CPLXSXP:
if (ISNAN(COMPLEX(u)[i].r) || ISNAN(COMPLEX(u)[i].i))
INTEGER(rval)[i % len] = 0;
break;
case STRSXP:
if (STRING_ELT(u, i) == NA_STRING)
INTEGER(rval)[i % len] = 0;
break;
default:
UNPROTECT(1);
error(R_MSG_type, type2char(TYPEOF(u)));
}
}
}
}
if (isNewList(CAR(s))) {
int it, nt;
t = CAR(s);
nt = length(t);
for (it = 0 ; it < nt ; it++) {
u = VECTOR_ELT(t, it);
for (i = 0; i < LENGTH(u); i++) {
switch (TYPEOF(u)) {
case INTSXP:
case LGLSXP:
if (INTEGER(u)[i] == NA_INTEGER)
INTEGER(rval)[i % len] = 0;
break;
case REALSXP:
if (ISNAN(REAL(u)[i]))
INTEGER(rval)[i % len] = 0;
break;
case CPLXSXP:
if (ISNAN(COMPLEX(u)[i].r) || ISNAN(COMPLEX(u)[i].i))
INTEGER(rval)[i % len] = 0;
break;
case STRSXP:
if (STRING_ELT(u, i) == NA_STRING)
INTEGER(rval)[i % len] = 0;
break;
default:
UNPROTECT(1);
error(R_MSG_type, type2char(TYPEOF(u)));
}
}
}
}
else {
for (i = 0; i < LENGTH(CAR(s)); i++) {
u = CAR(s);
switch (TYPEOF(u)) {
case INTSXP:
case LGLSXP:
if (INTEGER(u)[i] == NA_INTEGER)
INTEGER(rval)[i % len] = 0;
break;
case REALSXP:
if (ISNAN(REAL(u)[i]))
INTEGER(rval)[i % len] = 0;
break;
case CPLXSXP:
if (ISNAN(COMPLEX(u)[i].r) || ISNAN(COMPLEX(u)[i].i))
INTEGER(rval)[i % len] = 0;
break;
case STRSXP:
if (STRING_ELT(u, i) == NA_STRING)
INTEGER(rval)[i % len] = 0;
break;
default:
UNPROTECT(1);
error(R_MSG_type, type2char(TYPEOF(u)));
}
}
}
}
UNPROTECT(1);
return rval;
bad:
error(_("not all arguments have the same length"));
return R_NilValue; /* -Wall */
}
