*/ static void Ret_Query_Net(REBSER *port, REBREQ *sock, REBVAL *ret)
/*
***********************************************************************/
{
REBVAL *info = In_Object(port, STD_PORT_SCHEME, STD_SCHEME_INFO, 0);
REBSER *obj;
if (!info || !IS_OBJECT(info)) Trap_Port(RE_INVALID_SPEC, port, -10);
obj = CLONE_OBJECT(VAL_OBJ_FRAME(info));
SET_OBJECT(ret, obj);
Set_Tuple(
OFV(obj, STD_NET_INFO_LOCAL_IP),
cast(REBYTE*, &sock->special.net.local_ip),
4
);
Set_Tuple(
OFV(obj, STD_NET_INFO_REMOTE_IP),
cast(REBYTE*, &sock->special.net.remote_ip),
4
);
SET_INTEGER(OFV(obj, STD_NET_INFO_LOCAL_PORT), sock->special.net.local_port);
SET_INTEGER(OFV(obj, STD_NET_INFO_REMOTE_PORT), sock->special.net.remote_port);
}
*/ void Ret_Query_File(REBSER *port, REBREQ *file, REBVAL *ret)
/*
** Query file and set RET value to resulting STD_FILE_INFO object.
**
***********************************************************************/
{
REBVAL *info = In_Object(port, STD_PORT_SCHEME, STD_SCHEME_INFO, 0);
REBSER *obj;
REBSER *ser;
if (!info || !IS_OBJECT(info)) Trap_Port(RE_INVALID_SPEC, port, -10);
obj = CLONE_OBJECT(VAL_OBJ_FRAME(info));
SET_OBJECT(ret, obj);
Init_Word_Unbound(
OFV(obj, STD_FILE_INFO_TYPE),
REB_WORD,
GET_FLAG(file->modes, RFM_DIR) ? SYM_DIR : SYM_FILE
);
SET_INTEGER(OFV(obj, STD_FILE_INFO_SIZE), file->special.file.size);
Set_File_Date(file, OFV(obj, STD_FILE_INFO_DATE));
ser = To_REBOL_Path(file->special.file.path, 0, OS_WIDE, 0);
Set_Series(REB_FILE, OFV(obj, STD_FILE_INFO_NAME), ser);
}
*/ void Init_Errors(REBVAL *errors)
/*
***********************************************************************/
{
REBSER *errs;
REBVAL *val;
// Create error objects and error type objects:
*ROOT_ERROBJ = *Get_System(SYS_STANDARD, STD_ERROR);
errs = Construct_Object(0, VAL_BLK(errors), 0);
Set_Object(Get_System(SYS_CATALOG, CAT_ERRORS), errs);
Set_Root_Series(TASK_ERR_TEMPS, Make_Block(3));
// Create objects for all error types:
for (val = BLK_SKIP(errs, 1); NOT_END(val); val++) {
errs = Construct_Object(0, VAL_BLK(val), 0);
SET_OBJECT(val, errs);
}
// Catch top level errors, to provide decent output:
PUSH_STATE(Top_State, Saved_State);
if (SET_JUMP(Top_State)) {
POP_STATE(Top_State, Saved_State);
DSP++; // Room for return value
Catch_Error(DS_TOP); // Stores error value here
Print_Value(DS_TOP, 0, FALSE);
Crash(RP_NO_CATCH);
}
SET_STATE(Top_State, Saved_State);
}
*/ void Init_Obj_Value(REBVAL *value, REBSER *frame)
/*
***********************************************************************/
{
ASSERT(frame, RP_BAD_SET_CONTEXT);
CLEARS(value);
SET_OBJECT(value, frame);
}
bool KvsObject_vBox::init(KviKvsRunTimeContext * pContext,KviKvsVariantList *pParams)
{
Q_UNUSED(pContext);
Q_UNUSED(pParams);
SET_OBJECT(KviTalVBox);
return true;
}
bool KvsObject_lineEdit::init(KviKvsRunTimeContext *, KviKvsVariantList *)
{
SET_OBJECT(QLineEdit)
connect(widget(), SIGNAL(returnPressed()), this, SLOT(slotreturnPressed()));
connect(widget(), SIGNAL(editingFinished()), this, SLOT(slotlostFocus()));
connect(widget(), SIGNAL(textChanged(const QString &)), this, SLOT(slottextChanged(const QString &)));
return true;
}
/* R function qsort(x, index.return) */
SEXP attribute_hidden do_qsort(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP x, sx;
int indx_ret, n;
double *vx = NULL;
int *ivx = NULL;
Rboolean x_real, x_int;
checkArity(op, args);
x = CAR(args);
if (!isNumeric(x))
error(_("argument is not a numeric vector"));
x_real= TYPEOF(x) == REALSXP;
x_int = !x_real && (TYPEOF(x) == INTSXP || TYPEOF(x) == LGLSXP);
PROTECT(sx = (x_real || x_int) ? duplicate(x) : coerceVector(x, REALSXP));
SET_ATTRIB(sx, R_NilValue);
SET_OBJECT(sx, 0);
/* if x has names, drop them, since they won't be ordered
if (!isNull(getAttrib(sx, R_NamesSymbol)))
setAttrib(sx, R_NamesSymbol, R_NilValue); */
indx_ret = asLogical(CADR(args));
n = LENGTH(x);
if(x_int) ivx = INTEGER(sx); else vx = REAL(sx);
if(indx_ret) {
SEXP ans, ansnames, indx;
int i, *ix;
/* answer will have x = sorted x , ix = index :*/
PROTECT(ans = allocVector(VECSXP, 2));
PROTECT(ansnames = allocVector(STRSXP, 2));
PROTECT(indx = allocVector(INTSXP, n));
ix = INTEGER(indx);
for(i = 0; i < n; i++)
ix[i] = i+1;
if(x_int)
R_qsort_int_I(ivx, ix, 1, n);
else
R_qsort_I(vx, ix, 1, n);
SET_VECTOR_ELT(ans, 0, sx);
SET_VECTOR_ELT(ans, 1, indx);
SET_STRING_ELT(ansnames, 0, mkChar("x"));
SET_STRING_ELT(ansnames, 1, mkChar("ix"));
setAttrib(ans, R_NamesSymbol, ansnames);
UNPROTECT(4);
return ans;
}
else {
if(x_int)
R_qsort_int(ivx, 1, n);
else
R_qsort(vx, 1, n);
UNPROTECT(1);
return sx;
}
}
/* This is allowed to change 'out' */
attribute_hidden
SEXP do_copyDFattr(SEXP call, SEXP op, SEXP args, SEXP env)
{
checkArity(op, args);
SEXP in = CAR(args), out = CADR(args);
SET_ATTRIB(out, ATTRIB(in));
IS_S4_OBJECT(in) ? SET_S4_OBJECT(out) : UNSET_S4_OBJECT(out);
SET_OBJECT(out, OBJECT(in));
return out;
}
SEXP classgets(SEXP vec, SEXP klass)
{
if (isNull(klass) || isString(klass)) {
if (length(klass) <= 0) {
SET_ATTRIB(vec, stripAttrib(R_ClassSymbol, ATTRIB(vec)));
SET_OBJECT(vec, 0);
}
else {
/* When data frames were a special data type */
/* we had more exhaustive checks here. Now that */
/* use JMCs interpreted code, we don't need this */
/* FIXME : The whole "classgets" may as well die. */
/* HOWEVER, it is the way that the object bit gets set/unset */
int i;
Rboolean isfactor = FALSE;
if (vec == R_NilValue)
error(_("attempt to set an attribute on NULL"));
for(i = 0; i < length(klass); i++)
if(streql(CHAR(STRING_ELT(klass, i)), "factor")) { /* ASCII */
isfactor = TRUE;
break;
}
if(isfactor && TYPEOF(vec) != INTSXP) {
/* we cannot coerce vec here, so just fail */
error(_("adding class \"factor\" to an invalid object"));
}
installAttrib(vec, R_ClassSymbol, klass);
SET_OBJECT(vec, 1);
}
return R_NilValue;
}
error(_("attempt to set invalid 'class' attribute"));
return R_NilValue;/*- just for -Wall */
}
*/ void Do_Closure(REBVAL *func)
/*
** Do a closure by cloning its body and binding it to
** a new frame of words/values.
**
** This could be made faster by pre-binding the body,
** then using Rebind_Block to rebind the words in it.
**
***********************************************************************/
{
REBSER *body;
REBSER *frame;
REBVAL *result;
REBVAL *ds;
Eval_Functions++;
//DISABLE_GC;
// Clone the body of the function to allow rebinding to it:
body = Clone_Block(VAL_FUNC_BODY(func));
// Copy stack frame args as the closure object (one extra at head)
frame = Copy_Values(BLK_SKIP(DS_Series, DS_ARG_BASE), SERIES_TAIL(VAL_FUNC_ARGS(func)));
SET_FRAME(BLK_HEAD(frame), 0, VAL_FUNC_ARGS(func));
// Rebind the body to the new context (deeply):
//Rebind_Block(VAL_FUNC_ARGS(func), frame, body);
Bind_Block(frame, BLK_HEAD(body), BIND_DEEP); // | BIND_NO_SELF);
ds = DS_RETURN;
SET_OBJECT(ds, body); // keep it GC safe
result = Do_Blk(body, 0); // GC-OK - also, result returned on DS stack
ds = DS_RETURN;
if (IS_ERROR(result) && IS_RETURN(result)) {
// Value below is kept safe from GC because no-allocation is
// done between point of SET_THROW and here.
if (VAL_ERR_VALUE(result))
*ds = *VAL_ERR_VALUE(result);
else
SET_UNSET(ds);
}
else *ds = *result; // Set return value (atomic)
}
SEXP R_copyTruncate(SEXP x, SEXP R_n) {
if (isNull(x) || TYPEOF(x) != VECSXP)
error("'x' not of type list");
if (isNull(R_n) || TYPEOF(R_n) != INTSXP)
error("'n' not of type integer");
int i, k, n;
SEXP s, r, t = 0;
n = INTEGER(R_n)[0];
if (n < 0)
error("'n' invalid value");
r = PROTECT(allocVector(VECSXP, LENGTH(x)));
for (i = 0; i < LENGTH(x); i++) {
s = VECTOR_ELT(x, i);
if (TYPEOF(s) != STRSXP)
error("component not of type character");
if (LENGTH(s) > n) {
SET_VECTOR_ELT(r, i, (t = allocVector(STRSXP, n)));
for (k = 0; k < n; k++)
SET_STRING_ELT(t, k, STRING_ELT(s, k));
copyMostAttrib(t, s);
if ((s = getAttrib(s, R_NamesSymbol)) != R_NilValue) {
SEXP v;
setAttrib(t, R_NamesSymbol, (v = allocVector(STRSXP, n)));
for (k = 0; k < n; k++)
SET_STRING_ELT(v, k, STRING_ELT(s, k));
}
} else
SET_VECTOR_ELT(r, i, s);
}
UNPROTECT(1);
if (!t)
return x;
SET_ATTRIB(r, ATTRIB(x));
SET_OBJECT(r, OBJECT(x));
if (IS_S4_OBJECT(x))
SET_S4_OBJECT(r);
return r;
}
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;
}
/* version that does not preserve ts information, for subsetting */
void copyMostAttribNoTs(SEXP inp, SEXP ans)
{
SEXP s;
if (ans == R_NilValue)
error(_("attempt to set an attribute on NULL"));
PROTECT(ans);
PROTECT(inp);
for (s = ATTRIB(inp); s != R_NilValue; s = CDR(s)) {
if ((TAG(s) != R_NamesSymbol) &&
(TAG(s) != R_ClassSymbol) &&
(TAG(s) != R_TspSymbol) &&
(TAG(s) != R_DimSymbol) &&
(TAG(s) != R_DimNamesSymbol)) {
installAttrib(ans, TAG(s), CAR(s));
} else if (TAG(s) == R_ClassSymbol) {
SEXP cl = CAR(s);
int i;
Rboolean ists = FALSE;
for (i = 0; i < LENGTH(cl); i++)
if (strcmp(CHAR(STRING_ELT(cl, i)), "ts") == 0) { /* ASCII */
ists = TRUE;
break;
}
if (!ists) installAttrib(ans, TAG(s), cl);
else if(LENGTH(cl) <= 1) {
} else {
SEXP new_cl;
int i, j, l = LENGTH(cl);
PROTECT(new_cl = allocVector(STRSXP, l - 1));
for (i = 0, j = 0; i < l; i++)
if (strcmp(CHAR(STRING_ELT(cl, i)), "ts")) /* ASCII */
SET_STRING_ELT(new_cl, j++, STRING_ELT(cl, i));
installAttrib(ans, TAG(s), new_cl);
UNPROTECT(1);
}
}
}
SET_OBJECT(ans, OBJECT(inp));
IS_S4_OBJECT(inp) ? SET_S4_OBJECT(ans) : UNSET_S4_OBJECT(ans);
UNPROTECT(2);
}
void copyMostAttrib(SEXP inp, SEXP ans)
{
SEXP s;
if (ans == R_NilValue)
error(_("attempt to set an attribute on NULL"));
PROTECT(ans);
PROTECT(inp);
for (s = ATTRIB(inp); s != R_NilValue; s = CDR(s)) {
if ((TAG(s) != R_NamesSymbol) &&
(TAG(s) != R_DimSymbol) &&
(TAG(s) != R_DimNamesSymbol)) {
installAttrib(ans, TAG(s), CAR(s));
}
}
SET_OBJECT(ans, OBJECT(inp));
IS_S4_OBJECT(inp) ? SET_S4_OBJECT(ans) : UNSET_S4_OBJECT(ans);
UNPROTECT(2);
}
*/ static REB_R Loop_Each(struct Reb_Call *call_, REBINT mode)
/*
** Supports these natives (modes):
** 0: foreach
** 1: remove-each
** 2: map
**
***********************************************************************/
{
REBSER *body;
REBVAL *vars;
REBVAL *words;
REBSER *frame;
REBVAL *value;
REBSER *series;
REBSER *out; // output block (for MAP, mode = 2)
REBINT index; // !!!! should these be REBCNT?
REBINT tail;
REBINT windex; // write
REBINT rindex; // read
REBINT err;
REBCNT i;
REBCNT j;
REBVAL *ds;
assert(mode >= 0 && mode < 3);
value = D_ARG(2); // series
if (IS_NONE(value)) return R_NONE;
body = Init_Loop(D_ARG(1), D_ARG(3), &frame); // vars, body
SET_OBJECT(D_ARG(1), frame); // keep GC safe
Set_Block(D_ARG(3), body); // keep GC safe
SET_NONE(D_OUT); // Default result to NONE if the loop does not run
// If it's MAP, create result block:
if (mode == 2) {
out = Make_Block(VAL_LEN(value));
SAVE_SERIES(out);
}
// Get series info:
if (ANY_OBJECT(value)) {
series = VAL_OBJ_FRAME(value);
out = FRM_WORD_SERIES(series); // words (the out local reused)
index = 1;
//if (frame->tail > 3) Trap_Arg_DEAD_END(FRM_WORD(frame, 3));
}
else if (IS_MAP(value)) {
series = VAL_SERIES(value);
index = 0;
//if (frame->tail > 3) Trap_Arg_DEAD_END(FRM_WORD(frame, 3));
}
else {
series = VAL_SERIES(value);
index = VAL_INDEX(value);
if (index >= cast(REBINT, SERIES_TAIL(series))) {
if (mode == 1) {
SET_INTEGER(D_OUT, 0);
} else if (mode == 2) {
Set_Block(D_OUT, out);
UNSAVE_SERIES(out);
}
return R_OUT;
}
}
windex = index;
// Iterate over each value in the series block:
while (index < (tail = SERIES_TAIL(series))) {
rindex = index; // remember starting spot
j = 0;
// Set the FOREACH loop variables from the series:
for (i = 1; i < frame->tail; i++) {
vars = FRM_VALUE(frame, i);
words = FRM_WORD(frame, i);
// var spec is WORD
if (IS_WORD(words)) {
if (index < tail) {
if (ANY_BLOCK(value)) {
*vars = *BLK_SKIP(series, index);
}
else if (ANY_OBJECT(value)) {
if (!VAL_GET_EXT(BLK_SKIP(out, index), EXT_WORD_HIDE)) {
// Alternate between word and value parts of object:
if (j == 0) {
Init_Word(vars, REB_WORD, VAL_WORD_SYM(BLK_SKIP(out, index)), series, index);
if (NOT_END(vars+1)) index--; // reset index for the value part
}
else if (j == 1)
*vars = *BLK_SKIP(series, index);
else
Trap_Arg_DEAD_END(words);
j++;
}
else {
// Do not evaluate this iteration
index++;
goto skip_hidden;
}
}
else if (IS_VECTOR(value)) {
Set_Vector_Value(vars, series, index);
}
else if (IS_MAP(value)) {
REBVAL *val = BLK_SKIP(series, index | 1);
if (!IS_NONE(val)) {
if (j == 0) {
*vars = *BLK_SKIP(series, index & ~1);
if (IS_END(vars+1)) index++; // only words
}
else if (j == 1)
*vars = *BLK_SKIP(series, index);
else
Trap_Arg_DEAD_END(words);
j++;
}
else {
index += 2;
goto skip_hidden;
}
}
else { // A string or binary
if (IS_BINARY(value)) {
SET_INTEGER(vars, (REBI64)(BIN_HEAD(series)[index]));
}
else if (IS_IMAGE(value)) {
Set_Tuple_Pixel(BIN_SKIP(series, index), vars);
}
else {
VAL_SET(vars, REB_CHAR);
VAL_CHAR(vars) = GET_ANY_CHAR(series, index);
}
}
index++;
}
else SET_NONE(vars);
}
// var spec is SET_WORD:
else if (IS_SET_WORD(words)) {
if (ANY_OBJECT(value) || IS_MAP(value)) {
*vars = *value;
} else {
VAL_SET(vars, REB_BLOCK);
VAL_SERIES(vars) = series;
VAL_INDEX(vars) = index;
}
//if (index < tail) index++; // do not increment block.
}
else Trap_Arg_DEAD_END(words);
}
if (index == rindex) index++; //the word block has only set-words: foreach [a:] [1 2 3][]
if (!DO_BLOCK(D_OUT, body, 0)) {
if ((err = Check_Error(D_OUT)) >= 0) {
index = rindex;
break;
}
// else CONTINUE:
if (mode == 1) SET_FALSE(D_OUT); // keep the value (for mode == 1)
} else {
err = 0; // prevent later test against uninitialized value
}
if (mode > 0) {
//if (ANY_OBJECT(value)) Trap_Types_DEAD_END(words, REB_BLOCK, VAL_TYPE(value)); //check not needed
// If FALSE return, copy values to the write location:
if (mode == 1) { // remove-each
if (IS_CONDITIONAL_FALSE(D_OUT)) {
REBCNT wide = SERIES_WIDE(series);
// memory areas may overlap, so use memmove and not memcpy!
memmove(series->data + (windex * wide), series->data + (rindex * wide), (index - rindex) * wide);
windex += index - rindex;
// old: while (rindex < index) *BLK_SKIP(series, windex++) = *BLK_SKIP(series, rindex++);
}
}
else
if (!IS_UNSET(D_OUT)) Append_Value(out, D_OUT); // (mode == 2)
}
skip_hidden: ;
}
// Finish up:
if (mode == 1) {
// Remove hole (updates tail):
if (windex < index) Remove_Series(series, windex, index - windex);
SET_INTEGER(D_OUT, index - windex);
return R_OUT;
}
// If MAP...
if (mode == 2) {
UNSAVE_SERIES(out);
if (err != 2) {
// ...and not BREAK/RETURN:
Set_Block(D_OUT, out);
return R_OUT;
}
}
return R_OUT;
}
bool KvsObject_workspace::init(KviKvsRunTimeContext *, KviKvsVariantList *)
{
SET_OBJECT(QMdiArea);
return true;
}
*/ static REBFLG Get_GOB_Var(REBGOB *gob, REBVAL *word, REBVAL *val)
/*
***********************************************************************/
{
switch (VAL_WORD_CANON(word)) {
case SYM_OFFSET:
SET_PAIR(val, GOB_X(gob), GOB_Y(gob));
break;
case SYM_SIZE:
SET_PAIR(val, GOB_W(gob), GOB_H(gob));
break;
case SYM_IMAGE:
if (GOB_TYPE(gob) == GOBT_IMAGE) {
// image
}
else goto is_none;
break;
case SYM_DRAW:
if (GOB_TYPE(gob) == GOBT_DRAW) {
Set_Block(val, GOB_CONTENT(gob)); // Note: compiler optimizes SET_BLOCKs below
}
else goto is_none;
break;
case SYM_TEXT:
if (GOB_TYPE(gob) == GOBT_TEXT) {
Set_Block(val, GOB_CONTENT(gob));
}
else if (GOB_TYPE(gob) == GOBT_STRING) {
Set_String(val, GOB_CONTENT(gob));
}
else goto is_none;
break;
case SYM_EFFECT:
if (GOB_TYPE(gob) == GOBT_EFFECT) {
Set_Block(val, GOB_CONTENT(gob));
}
else goto is_none;
break;
case SYM_COLOR:
if (GOB_TYPE(gob) == GOBT_COLOR) {
Set_Tuple_Pixel((REBYTE*)&GOB_CONTENT(gob), val);
}
else goto is_none;
break;
case SYM_ALPHA:
SET_INTEGER(val, GOB_ALPHA(gob));
break;
case SYM_PANE:
if (GOB_PANE(gob))
Set_Block(val, Pane_To_Block(gob, 0, -1));
else
Set_Block(val, Make_Block(0));
break;
case SYM_PARENT:
if (GOB_PARENT(gob)) {
SET_GOB(val, GOB_PARENT(gob));
}
else
is_none:
SET_NONE(val);
break;
case SYM_DATA:
if (GOB_DTYPE(gob) == GOBD_OBJECT) {
SET_OBJECT(val, GOB_DATA(gob));
}
else if (GOB_DTYPE(gob) == GOBD_BLOCK) {
Set_Block(val, GOB_DATA(gob));
}
else if (GOB_DTYPE(gob) == GOBD_STRING) {
Set_String(val, GOB_DATA(gob));
}
else if (GOB_DTYPE(gob) == GOBD_BINARY) {
SET_BINARY(val, GOB_DATA(gob));
}
else if (GOB_DTYPE(gob) == GOBD_INTEGER) {
SET_INTEGER(val, (REBIPT)GOB_DATA(gob));
}
else goto is_none;
break;
case SYM_FLAGS:
Set_Block(val, Flags_To_Block(gob));
break;
default:
return FALSE;
}
return TRUE;
}
*/ static REBFLG Get_GOB_Var(REBGOB *gob, REBVAL *word, REBVAL *val)
/*
***********************************************************************/
{
REBSER *data;
switch (VAL_WORD_CANON(word)) {
case SYM_OFFSET:
SET_PAIR(val, GOB_X(gob), GOB_Y(gob));
break;
case SYM_SIZE:
SET_PAIR(val, GOB_W(gob), GOB_H(gob));
break;
case SYM_IMAGE:
if (GOB_TYPE(gob) == GOBT_IMAGE) {
// image
}
else goto is_none;
break;
#ifdef HAS_WIDGET_GOB
case SYM_WIDGET:
data = VAL_SERIES(GOB_WIDGET_SPEC(gob));
Init_Word(val, VAL_WORD_CANON(BLK_HEAD(data)));
VAL_SET(val, REB_LIT_WORD);
break;
#endif
case SYM_DRAW:
if (GOB_TYPE(gob) == GOBT_DRAW) {
Set_Block(val, GOB_CONTENT(gob)); // Note: compiler optimizes SET_BLOCKs below
}
else goto is_none;
break;
case SYM_TEXT:
if (GOB_TYPE(gob) == GOBT_TEXT) {
Set_Block(val, GOB_CONTENT(gob));
}
else if (GOB_TYPE(gob) == GOBT_STRING) {
Set_String(val, GOB_CONTENT(gob));
}
else goto is_none;
break;
case SYM_EFFECT:
if (GOB_TYPE(gob) == GOBT_EFFECT) {
Set_Block(val, GOB_CONTENT(gob));
}
else goto is_none;
break;
case SYM_COLOR:
if (GOB_TYPE(gob) == GOBT_COLOR) {
Set_Tuple_Pixel((REBYTE*)&GOB_CONTENT(gob), val);
}
else goto is_none;
break;
case SYM_ALPHA:
SET_INTEGER(val, GOB_ALPHA(gob));
break;
case SYM_PANE:
if (GOB_PANE(gob))
Set_Block(val, Pane_To_Block(gob, 0, -1));
else
Set_Block(val, Make_Block(0));
break;
case SYM_PARENT:
if (GOB_PARENT(gob)) {
SET_GOB(val, GOB_PARENT(gob));
}
else
is_none:
SET_NONE(val);
break;
case SYM_DATA:
#ifdef HAS_WIDGET_GOB
if (GOB_TYPE(gob) == GOBT_WIDGET) {
return OS_GET_WIDGET_DATA(gob, val);
}
#endif
data = GOB_DATA(gob);
if (GOB_DTYPE(gob) == GOBD_OBJECT) {
SET_OBJECT(val, data);
}
else if (GOB_DTYPE(gob) == GOBD_BLOCK) {
Set_Block(val, data);
}
else if (GOB_DTYPE(gob) == GOBD_STRING) {
Set_String(val, data);
}
else if (GOB_DTYPE(gob) == GOBD_BINARY) {
SET_BINARY(val, data);
}
else if (GOB_DTYPE(gob) == GOBD_INTEGER) {
SET_INTEGER(val, (REBIPT)data);
}
else goto is_none;
break;
case SYM_FLAGS:
Set_Block(val, Flags_To_Block(gob));
break;
default:
return FALSE;
}
return TRUE;
}
/* R function qsort(x, index.return) */
SEXP attribute_hidden do_qsort(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP x, sx;
int indx_ret;
double *vx = NULL;
int *ivx = NULL;
Rboolean x_real, x_int;
checkArity(op, args);
x = CAR(args);
if (!isNumeric(x))
error(_("argument is not a numeric vector"));
x_real= TYPEOF(x) == REALSXP;
x_int = !x_real && (TYPEOF(x) == INTSXP || TYPEOF(x) == LGLSXP);
PROTECT(sx = (x_real || x_int) ? duplicate(x) : coerceVector(x, REALSXP));
SET_ATTRIB(sx, R_NilValue);
SET_OBJECT(sx, 0);
indx_ret = asLogical(CADR(args));
R_xlen_t n = XLENGTH(x);
#ifdef LONG_VECTOR_SUPPORT
Rboolean isLong = n > INT_MAX;
#endif
if(x_int) ivx = INTEGER(sx); else vx = REAL(sx);
if(indx_ret) {
SEXP ans, ansnames, indx;
/* answer will have x = sorted x , ix = index :*/
PROTECT(ans = allocVector(VECSXP, 2));
PROTECT(ansnames = allocVector(STRSXP, 2));
#ifdef LONG_VECTOR_SUPPORT
if (isLong) {
PROTECT(indx = allocVector(REALSXP, n));
double *ix = REAL(indx);
for(R_xlen_t i = 0; i < n; i++) ix[i] = (double) (i+1);
if(x_int) R_qsort_int_R(ivx, ix, 1, n);
else R_qsort_R(vx, ix, 1, n);
} else
#endif
{
PROTECT(indx = allocVector(INTSXP, n));
int *ix = INTEGER(indx);
int nn = (int) n;
for(int i = 0; i < nn; i++) ix[i] = i+1;
if(x_int) R_qsort_int_I(ivx, ix, 1, nn);
else R_qsort_I(vx, ix, 1, nn);
}
SET_VECTOR_ELT(ans, 0, sx);
SET_VECTOR_ELT(ans, 1, indx);
SET_STRING_ELT(ansnames, 0, mkChar("x"));
SET_STRING_ELT(ansnames, 1, mkChar("ix"));
setAttrib(ans, R_NamesSymbol, ansnames);
UNPROTECT(4);
return ans;
} else {
if(x_int)
R_qsort_int(ivx, 1, n);
else
R_qsort(vx, 1, n);
UNPROTECT(1);
return sx;
}
}
static SEXP duplicate1(SEXP s, Rboolean deep)
{
SEXP t;
R_xlen_t i, n;
duplicate1_elts++;
duplicate_elts++;
switch (TYPEOF(s)) {
case NILSXP:
case SYMSXP:
case ENVSXP:
case SPECIALSXP:
case BUILTINSXP:
case EXTPTRSXP:
case BCODESXP:
case WEAKREFSXP:
return s;
case CLOSXP:
PROTECT(s);
PROTECT(t = allocSExp(CLOSXP));
SET_FORMALS(t, FORMALS(s));
SET_BODY(t, BODY(s));
SET_CLOENV(t, CLOENV(s));
DUPLICATE_ATTRIB(t, s, deep);
if (NOJIT(s)) SET_NOJIT(t);
if (MAYBEJIT(s)) SET_MAYBEJIT(t);
UNPROTECT(2);
break;
case LISTSXP:
PROTECT(s);
t = duplicate_list(s, deep);
UNPROTECT(1);
break;
case LANGSXP:
PROTECT(s);
PROTECT(t = duplicate_list(s, deep));
SET_TYPEOF(t, LANGSXP);
DUPLICATE_ATTRIB(t, s, deep);
UNPROTECT(2);
break;
case DOTSXP:
PROTECT(s);
PROTECT(t = duplicate_list(s, deep));
SET_TYPEOF(t, DOTSXP);
DUPLICATE_ATTRIB(t, s, deep);
UNPROTECT(2);
break;
case CHARSXP:
return s;
break;
case EXPRSXP:
case VECSXP:
n = XLENGTH(s);
PROTECT(s);
PROTECT(t = allocVector(TYPEOF(s), n));
for(i = 0 ; i < n ; i++)
SET_VECTOR_ELT(t, i, duplicate_child(VECTOR_ELT(s, i), deep));
DUPLICATE_ATTRIB(t, s, deep);
COPY_TRUELENGTH(t, s);
UNPROTECT(2);
break;
case LGLSXP: DUPLICATE_ATOMIC_VECTOR(int, LOGICAL, t, s, deep); break;
case INTSXP: DUPLICATE_ATOMIC_VECTOR(int, INTEGER, t, s, deep); break;
case REALSXP: DUPLICATE_ATOMIC_VECTOR(double, REAL, t, s, deep); break;
case CPLXSXP: DUPLICATE_ATOMIC_VECTOR(Rcomplex, COMPLEX, t, s, deep); break;
case RAWSXP: DUPLICATE_ATOMIC_VECTOR(Rbyte, RAW, t, s, deep); break;
case STRSXP:
/* direct copying and bypassing the write barrier is OK since
t was just allocated and so it cannot be older than any of
the elements in s. LT */
DUPLICATE_ATOMIC_VECTOR(SEXP, STRING_PTR, t, s, deep);
break;
case PROMSXP:
return s;
break;
case S4SXP:
PROTECT(s);
PROTECT(t = allocS4Object());
DUPLICATE_ATTRIB(t, s, deep);
UNPROTECT(2);
break;
default:
UNIMPLEMENTED_TYPE("duplicate", s);
t = s;/* for -Wall */
}
if(TYPEOF(t) == TYPEOF(s) ) { /* surely it only makes sense in this case*/
SET_OBJECT(t, OBJECT(s));
(IS_S4_OBJECT(s) ? SET_S4_OBJECT(t) : UNSET_S4_OBJECT(t));
}
return t;
}
bool KvsObject_toolButton::init(KviKvsRunTimeContext *,KviKvsVariantList *)
{
SET_OBJECT(QToolButton);
connect(widget(),SIGNAL(clicked()),this,SLOT(slotClicked()));
return true;
}
