void check_attribute_compatibility(SEXP left, SEXP right) {
SEXP att_left = ATTRIB(left);
SEXP att_right = ATTRIB(right);
int n_left = count_attributes(att_left);
int n_right = count_attributes(att_right);
if (Rf_inherits(left, "POSIXct") && Rf_inherits(right, "POSIXct")) {
return;
}
if (n_left != n_right)
stop("attributes of different sizes");
List list_left(n_left), list_right(n_left);
SEXP p_left = att_left;
int i = 0;
while (!Rf_isNull(p_left)) {
SEXP name = TAG(p_left);
if (name != R_NamesSymbol && name != R_DimSymbol) {
list_left[i] = CAR(p_left);
list_right[i] = grab_attribute(name, att_right);
}
p_left = CDR(p_left);
}
RObject test = Language("all.equal", list_left, list_right).fast_eval();
if (!is<bool>(test) || !as<bool>(test)) {
stop("attributes are different");
}
}
/* & | ! */
SEXP attribute_hidden do_logic(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP ans, arg1, arg2;
int argc;
if (args == R_NilValue)
argc = 0;
else if (CDR(args) == R_NilValue)
argc = 1;
else if (CDDR(args) == R_NilValue)
argc = 2;
else
argc = length(args);
arg1 = CAR(args);
arg2 = CADR(args);
if (ATTRIB(arg1) != R_NilValue || ATTRIB(arg2) != R_NilValue) {
if (DispatchGroup("Ops",call, op, args, env, &ans))
return ans;
}
else if (argc == 1 && IS_SCALAR(arg1, LGLSXP)) {
/* directly handle '!' operator for simple logical scalars. */
int v = LOGICAL(arg1)[0];
return ScalarLogical(v == NA_LOGICAL ? v : ! v);
}
if (argc == 1)
return lunary(call, op, arg1);
else if (argc == 2)
return lbinary(call, op, args);
else
error(_("binary operations require two arguments"));
return R_NilValue; /* for -Wall */
}
/*
* Kernel C code entry point.
* Initializes kernel subsystems, mounts filesystems,
* and spawns init process.
*/
void Main(struct Boot_Info* bootInfo)
{
Init_BSS();
Init_Screen();
Init_Mem(bootInfo);
Init_CRC32();
Init_TSS();
Init_Interrupts();
Init_Scheduler();
Init_Traps();
Init_Timer();
Init_Keyboard();
Set_Current_Attr(ATTRIB(BLACK, GREEN|BRIGHT));
Print("Welcome to GeekOS!\n");
Set_Current_Attr(ATTRIB(BLACK, GRAY));
/* TODO("Start a kernel thread to echo pressed keys and print counts");*/
Start_Kernel_Thread(&funct_eigen, 0, PRIORITY_NORMAL, false);
/* Now this thread is done. */
Exit(0);
}
/* & | ! */
SEXP attribute_hidden do_logic(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP arg1 = CAR(args); //, arg2 = CADR(args)
Rboolean attr1 = ATTRIB(arg1) != R_NilValue;
if (attr1 || ATTRIB(CADR(args)) != R_NilValue) {
SEXP ans;
if (DispatchGroup("Ops", call, op, args, env, &ans))
return ans;
}
/* The above did dispatch to valid S3/S4 methods, including those with
* "wrong" number of arguments.
* Now require binary calls to `&` and `|` or unary calls to `!` : */
checkArity(op, args);
if (CDR(args) == R_NilValue) { // one argument <==> !(arg1)
if (!attr1 && IS_SCALAR(arg1, LGLSXP)) {
/* directly handle '!' operator for simple logical scalars. */
int v = LOGICAL(arg1)[0];
return ScalarLogical(v == NA_LOGICAL ? v : ! v);
}
return lunary(call, op, arg1);
}
// else : two arguments
return lbinary(call, op, args);
}
/*
* Kernel C code entry point.
* Initializes kernel subsystems, mounts filesystems,
* and spawns init process.
*/
void Main(struct Boot_Info* bootInfo)
{
Init_BSS();
Init_Screen();
Init_Mem(bootInfo);
Init_CRC32();
Init_TSS();
Init_Interrupts();
Init_Scheduler();
Init_Traps();
Init_Timer();
Init_Keyboard();
Init_DMA();
Init_Floppy();
Init_IDE();
Init_PFAT();
Mount_Root_Filesystem();
Set_Current_Attr(ATTRIB(BLACK, GREEN|BRIGHT));
Print("Welcome to GeekOS!\n");
Set_Current_Attr(ATTRIB(BLACK, GRAY));
Spawn_Init_Process();
/* Now this thread is done. */
Exit(0);
}
void Main(struct Boot_Info *bootInfo) {
Init_BSS();
Init_Screen();
Init_Mem(bootInfo);
Init_CRC32();
Init_TSS();
lockKernel();
Init_Interrupts(0);
Init_SMP();
TODO_P(PROJECT_VIRTUAL_MEMORY_A,
"initialize virtual memory page tables.");
Init_Scheduler(0, (void *)KERN_STACK);
Init_Traps();
Init_Local_APIC(0);
Init_Timer();
Init_Keyboard();
Init_DMA();
/* Init_Floppy(); *//* floppy initialization hangs on virtualbox */
Init_IDE();
Init_PFAT();
Init_GFS2();
Init_GOSFS();
Init_CFS();
Init_Alarm();
Release_SMP();
/* Initialize Networking */
Init_Network_Devices();
Init_ARP_Protocol();
Init_IP();
Init_Routing();
Init_Sockets();
Init_RIP();
/* End networking subsystem init */
/* Initialize Sound */
Init_Sound_Devices();
/* End sound init */
Mount_Root_Filesystem();
TODO_P(PROJECT_VIRTUAL_MEMORY_A, "initialize page file.");
Set_Current_Attr(ATTRIB(BLACK, GREEN | BRIGHT));
Print("Welcome to GeekOS!\n");
Set_Current_Attr(ATTRIB(BLACK, GRAY));
TODO_P(PROJECT_SOUND, "play startup sound");
Spawn_Init_Process();
/* it's time to shutdown the system */
Hardware_Shutdown();
/* we should not get here */
}
SEXP getAttrib(SEXP vec, SEXP name)
{
if(TYPEOF(vec) == CHARSXP)
error("cannot have attributes on a CHARSXP");
/* pre-test to avoid expensive operations if clearly not needed -- LT */
if (ATTRIB(vec) == R_NilValue &&
! (TYPEOF(vec) == LISTSXP || TYPEOF(vec) == LANGSXP))
return R_NilValue;
if (isString(name)) name = install(translateChar(STRING_ELT(name, 0)));
/* special test for c(NA, n) rownames of data frames: */
if (name == R_RowNamesSymbol) {
SEXP s = getAttrib0(vec, R_RowNamesSymbol);
if(isInteger(s) && LENGTH(s) == 2 && INTEGER(s)[0] == NA_INTEGER) {
int i, n = abs(INTEGER(s)[1]);
PROTECT(s = allocVector(INTSXP, n));
for(i = 0; i < n; i++)
INTEGER(s)[i] = i+1;
UNPROTECT(1);
}
return s;
} else
return getAttrib0(vec, name);
}
SEXP d2q(SEXP foo)
{
if (! isReal(foo))
error("argument must be real");
int n = LENGTH(foo);
int i;
for (i = 0; i < n; i++)
if (! R_finite(REAL(foo)[i]))
error("argument not finite-valued");
SEXP bar, bark;
PROTECT(bar = allocVector(STRSXP, n));
PROTECT(bark = ATTRIB(foo));
if (bark != R_NilValue)
SET_ATTRIB(bar, duplicate(bark));
UNPROTECT(1);
mpq_t value;
mpq_init(value);
int k;
for (k = 0; k < n; k++) {
double z = REAL(foo)[k];
mpq_set_d(value, z);
char *zstr = NULL;
zstr = mpq_get_str(zstr, 10, value);
SET_STRING_ELT(bar, k, mkChar(zstr));
free(zstr);
}
mpq_clear(value);
UNPROTECT(1);
return(bar);
}
void isr_handler(registers_t regs)
{
// Dummy interrupt handler just dumps a status message to the screen
ubyte attribute = ATTRIB(VGA_BLK, VGA_WHI);
if(interrupt_handlers[regs.interrupt_number] != 0)
{
isr_t handler = interrupt_handlers[regs.interrupt_number];
handler(regs);
}
else
{
console_putstr(attribute, "Interrupt encountered: ");
if (regs.interrupt_number >= 19)
{
console_putstr(attribute, "System reserved interrupt ");
}
else
{
console_putstr(attribute, interrupt_types[regs.interrupt_number]);
}
console_putstr(attribute, "(");
console_putint(attribute, regs.interrupt_number);
console_putstr(attribute, ")\n");
console_putstr(attribute, "Error code supplied: ");
console_putint(attribute, regs.error_code);
console_putchar(attribute, '\n');
}
}
/**
* Initialize an EGL context for the current display.
*/
EGLContext fghCreateNewContextEGL( SFG_Window* window ) {
EGLContext context;
EGLint ver = -1;
EGLDisplay eglDisplay = fgDisplay.pDisplay.egl.Display;
EGLConfig eglConfig = window->Window.pContext.egl.Config;
/* On GLES, user specifies the target version with glutInitContextVersion */
EGLint attributes[32];
int where = 0;
ATTRIB_VAL(EGL_CONTEXT_CLIENT_VERSION, fgState.MajorVersion);
ATTRIB(EGL_NONE);
context = eglCreateContext(eglDisplay, eglConfig, EGL_NO_CONTEXT, attributes);
if (context == EGL_NO_CONTEXT) {
fgWarning("Cannot initialize EGL context, err=%x\n", eglGetError());
fghContextCreationError();
}
eglQueryContext(fgDisplay.pDisplay.egl.Display, context, EGL_CONTEXT_CLIENT_VERSION, &ver);
if (ver != fgState.MajorVersion)
fgError("Wrong GLES major version: %d\n", ver);
return context;
}
SEXP qsign(SEXP foo)
{
if (! isString(foo))
error("argument must be character");
int n = LENGTH(foo);
SEXP bar, bark;
PROTECT(bar = allocVector(INTSXP, n));
PROTECT(bark = ATTRIB(foo));
if (bark != R_NilValue)
SET_ATTRIB(bar, duplicate(bark));
UNPROTECT(1);
mpq_t value;
mpq_init(value);
for (int k = 0; k < n; k++) {
const char *zstr = CHAR(STRING_ELT(foo, k));
if (mpq_set_str(value, zstr, 10) == -1) {
mpq_clear(value);
error("error converting string to GMP rational");
}
mpq_canonicalize(value);
INTEGER(bar)[k] = mpq_sgn(value);
}
mpq_clear(value);
UNPROTECT(1);
return(bar);
}
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;
}
/* 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;
}
/*
* Kernel C code entry point.
* Initializes kernel subsystems, mounts filesystems,
* and spawns init process.
*/
void Main(struct Boot_Info *bootInfo) {
Init_BSS();
Init_Screen();
Init_Mem(bootInfo);
Init_CRC32();
Init_TSS();
Init_Interrupts();
Init_Scheduler();
Init_Traps();
Init_Timer();
Init_Keyboard();
Init_DMA();
Init_Floppy();
Init_IDE();
Init_PFAT();
Init_GFS2();
Init_GOSFS();
Init_Alarm();
/* Initialize Networking */
Init_Network_Devices();
Init_ARP_Protocol();
Init_IP();
Init_Routing();
Init_Sockets();
Init_RIP();
/* End networking subsystem init */
Mount_Root_Filesystem();
Set_Current_Attr(ATTRIB(BLACK, GREEN | BRIGHT));
Print("Welcome to GeekOS!\n");
Set_Current_Attr(ATTRIB(BLACK, GRAY));
Spawn_Init_Process();
/* Now this thread is done. */
Exit(0);
}
static SEXP
int_vectorSubscript(int nx, SEXP s, int *stretch, AttrGetter dng,
StringEltGetter strg, SEXP x, Rboolean in)
{
int ns;
SEXP ans=R_NilValue, tmp;
ns = length(s);
/* special case for simple indices -- does not duplicate */
if (ns == 1 && TYPEOF(s) == INTSXP && ATTRIB(s) == R_NilValue) {
int i = INTEGER(s)[0];
if (0 < i && i <= nx) {
*stretch = 0;
return s;
}
}
PROTECT(s=duplicate(s));
SET_ATTRIB(s, R_NilValue);
switch (TYPEOF(s)) {
case NILSXP:
*stretch = 0;
ans = allocVector(INTSXP, 0);
break;
case LGLSXP:
/* *stretch = 0; */
ans = logicalSubscript(s, ns, nx, stretch);
break;
case INTSXP:
ans = integerSubscript(s, ns, nx, stretch);
break;
case REALSXP:
PROTECT(tmp = coerceVector(s, INTSXP));
ans = integerSubscript(tmp, ns, nx, stretch);
UNPROTECT(1);
break;
case STRSXP:
{
SEXP names = dng(x, R_NamesSymbol);
/* *stretch = 0; */
ans = stringSubscript(s, ns, nx, names, strg, stretch, in);
}
break;
case SYMSXP:
*stretch = 0;
if (s == R_MissingArg) {
ans = nullSubscript(nx);
break;
}
default:
error(_("invalid subscript type"));
}
UNPROTECT(1);
return ans;
}
inline bool is_bare_vector(SEXP x) {
SEXP att = ATTRIB(x);
// only allow R_Names. as in R's do_isvector
while (att != R_NilValue) {
SEXP tag = TAG(att);
if (!(tag == R_NamesSymbol || tag == Rf_install("comment"))) return false;
att = CDR(att);
}
return true;
}
/*
* Kernel C code entry point.
* Initializes kernel subsystems, mounts filesystems,
* and spawns init process.
*/
void Main(struct Boot_Info* bootInfo)
{
Init_BSS();
Init_Screen();
Init_Mem(bootInfo);
Init_CRC32();
Init_TSS();
Init_Interrupts();
Init_Scheduler();
Init_Traps();
Init_Timer();
Init_Keyboard();
Set_Current_Attr(ATTRIB(BLACK, GREEN|BRIGHT));
Print("Welcome to GeekOS!\n");
Set_Current_Attr(ATTRIB(BLACK, GRAY));
Start_Kernel_Thread(Print_Key_Pressed, 0, PRIORITY_NORMAL, false);
/* Now this thread is done. */
Exit(0);
}
int main(int argc , char ** argv)
{
int i,j ; /* loop index */
int start_sem;
int scr_sem; /* id of screen semaphore */
int time; /* current and start time */
int ping,pong; /* id of semaphores to sync processes b & c */
time = Get_Time_Of_Day();
start_sem = Create_Semaphore ("start" , 1);
scr_sem = Create_Semaphore ("screen" , 1) ; /* register for screen use */
ping = Create_Semaphore ("ping" , 1) ;
pong = Create_Semaphore ("pong" , 0) ;
P (start_sem) ;
V (start_sem) ;
for (i=0; i < 50; i++) {
P(ping);
for (j=0; j < 35; j++);
P(scr_sem);
Set_Attr(ATTRIB(BLACK, BLUE|BRIGHT));
Print("Pong");
Set_Attr(ATTRIB(BLACK, GRAY));
V(scr_sem);
V(pong);
}
time = Get_Time_Of_Day() - time;
P(scr_sem) ;
Print ("\nProcess #Pong is done at time: %d\n", time) ;
V(scr_sem);
return (0);
}
SEXP c_check_vector(SEXP x, SEXP strict, SEXP any_missing, SEXP all_missing, SEXP len, SEXP min_len, SEXP max_len, SEXP unique, SEXP names) {
if (!isVector(x))
return make_type_error(x, "vector");
if (asFlag(strict, "strict")) {
SEXP attr = ATTRIB(x);
if ((length(attr) > 0 && (TAG(attr) != R_NamesSymbol)) || CDR(attr) != R_NilValue)
return make_type_error(x, "vector");
}
assert(check_vector_len(x, len, min_len, max_len));
assert(check_vector_names(x, names));
assert(check_vector_missings(x, any_missing, all_missing));
assert(check_vector_unique(x, unique));
return ScalarLogical(TRUE);
}
/* Tweaks here based in part on PR#14934 */
static SEXP installAttrib(SEXP vec, SEXP name, SEXP val)
{
SEXP t = R_NilValue; /* -Wall */
if(TYPEOF(vec) == CHARSXP)
error("cannot set attribute on a CHARSXP");
/* this does no allocation */
for (SEXP s = ATTRIB(vec); s != R_NilValue; s = CDR(s)) {
if (TAG(s) == name) {
SETCAR(s, val);
return val;
}
t = s; // record last attribute, if any
}
/* The usual convention is that the caller protects,
so this is historical over-cautiousness */
PROTECT(vec); PROTECT(name); PROTECT(val);
SEXP s = CONS(val, R_NilValue);
SET_TAG(s, name);
if (ATTRIB(vec) == R_NilValue) SET_ATTRIB(vec, s); else SETCDR(t, s);
UNPROTECT(3);
return val;
}
/* Detect cycles that would be created by assigning 'child' as a
component of 's' in a complex assignment without duplicating
'child'. This is called quite often but almost always returns
FALSE. Could be made more efficient, at least with partial
inlining, but probably not worth while until it starts showing up
significantly in profiling. Based on code from Michael Lawrence. */
Rboolean R_cycle_detected(SEXP s, SEXP child) {
if (s == child) {
switch (TYPEOF(child)) {
case NILSXP:
case SYMSXP:
case ENVSXP:
case SPECIALSXP:
case BUILTINSXP:
case EXTPTRSXP:
case BCODESXP:
case WEAKREFSXP:
/* it's a cycle but one that is OK */
return FALSE;
default:
return TRUE;
}
}
if (ATTRIB(child) != R_NilValue) {
if (R_cycle_detected(s, ATTRIB(child)))
return TRUE;
}
if (isPairList(child)) {
SEXP el = child;
while(el != R_NilValue) {
if (s == el || R_cycle_detected(s, CAR(el)))
return TRUE;
if (ATTRIB(el) != R_NilValue && R_cycle_detected(s, ATTRIB(el)))
return TRUE;
el = CDR(el);
}
} else if (isVectorList(child)) {
for(int i = 0 ; i < length(child); i++)
if (R_cycle_detected(s, VECTOR_ELT(child, i)))
return TRUE;
}
return FALSE;
}
static R_INLINE R_xlen_t scalarIndex(SEXP s)
{
if (ATTRIB(s) == R_NilValue)
switch (TYPEOF(s)) {
case REALSXP: // treat infinite indices as NA, like asInteger
if (XLENGTH(s) == 1 && R_FINITE(REAL(s)[0]))
return (R_xlen_t) REAL(s)[0];
else return -1;
case INTSXP:
if (XLENGTH(s) == 1 && INTEGER(s)[0] != NA_INTEGER)
return INTEGER(s)[0];
else return -1;
default: return -1;
}
else return -1;
}
static R_INLINE R_xlen_t scalarIndex(SEXP s)
{
if (ATTRIB(s) == R_NilValue)
switch (TYPEOF(s)) {
case REALSXP:
if (XLENGTH(s) == 1 && ! ISNAN(REAL(s)[0]))
return (R_xlen_t) REAL(s)[0];
else return -1;
case INTSXP:
if (XLENGTH(s) == 1 && INTEGER(s)[0] != NA_INTEGER)
return INTEGER(s)[0];
else return -1;
default: return -1;
}
else return -1;
}
int fghChooseConfig(EGLConfig* config) {
EGLint attributes[32];
int where = 0;
ATTRIB_VAL(EGL_SURFACE_TYPE, EGL_WINDOW_BIT);
if (fgState.MajorVersion >= 2) {
/*
* Khronos does not specify a EGL_OPENGL_ES3_BIT outside of the OpenGL extension "EGL_KHR_create_context". There are numerous references on the internet that
* say to use EGL_OPENGL_ES3_BIT, followed by many saying they can't find it in any headers. In fact, the offical updated specification for EGL does not have
* any references to OpenGL ES 3.0. Tests have shown that EGL_OPENGL_ES2_BIT will work with ES 3.0.
*/
ATTRIB_VAL(EGL_RENDERABLE_TYPE, EGL_OPENGL_ES2_BIT);
} else {
ATTRIB_VAL(EGL_RENDERABLE_TYPE, EGL_OPENGL_ES_BIT);
}
/* Technically it's possible to request a standard OpenGL (non-ES)
context, but currently our build system assumes EGL => GLES */
/* attribs[i++] = EGL_RENDERABLE_TYPE; */
/* attribs[i++] = EGL_OPENGL_BIT; */
#ifdef TARGET_HOST_BLACKBERRY
/* Only 888 and 565 seem to work. Based on
http://qt.gitorious.org/qt/qtbase/source/893deb1a93021cdfabe038cdf1869de33a60cbc9:src/plugins/platforms/qnx/qqnxglcontext.cpp and
https://twitter.com/BlackBerryDev/status/380720927475912706 */
ATTRIB_VAL(EGL_BLUE_SIZE, 8);
ATTRIB_VAL(EGL_GREEN_SIZE, 8);
ATTRIB_VAL(EGL_RED_SIZE, 8);
#else
ATTRIB_VAL(EGL_BLUE_SIZE, 1);
ATTRIB_VAL(EGL_GREEN_SIZE, 1);
ATTRIB_VAL(EGL_RED_SIZE, 1);
#endif
ATTRIB_VAL(EGL_ALPHA_SIZE, (fgState.DisplayMode & GLUT_ALPHA) ? 1 : 0);
ATTRIB_VAL(EGL_DEPTH_SIZE, (fgState.DisplayMode & GLUT_DEPTH) ? 1 : 0);
ATTRIB_VAL(EGL_STENCIL_SIZE, (fgState.DisplayMode & GLUT_STENCIL) ? 1 : 0);
ATTRIB_VAL(EGL_SAMPLE_BUFFERS, (fgState.DisplayMode & GLUT_MULTISAMPLE) ? 1 : 0);
ATTRIB_VAL(EGL_SAMPLES, (fgState.DisplayMode & GLUT_MULTISAMPLE) ? fgState.SampleNumber : 0);
ATTRIB(EGL_NONE);
EGLint num_config;
if (!eglChooseConfig(fgDisplay.pDisplay.egl.Display,
attributes, config, 1, &num_config)) {
fgWarning("eglChooseConfig: error %x\n", eglGetError());
return 0;
}
return 1;
}
static SEXP commentgets(SEXP vec, SEXP comment)
{
if (vec == R_NilValue)
error(_("attempt to set an attribute on NULL"));
if (isNull(comment) || isString(comment)) {
if (length(comment) <= 0) {
SET_ATTRIB(vec, stripAttrib(R_CommentSymbol, ATTRIB(vec)));
}
else {
installAttrib(vec, R_CommentSymbol, comment);
}
return R_NilValue;
}
error(_("attempt to set invalid 'comment' attribute"));
return R_NilValue;/*- just for -Wall */
}
/*
#define xts_IndexSymbol install("index")
#define xts_ClassSymbol install(".CLASS")
#define xts_IndexFormatSymbol install(".indexFORMAT")
#define xts_IndexClassSymbol install(".indexCLASS")
#define xts_ATTRIB(x) coerceVector(do_xtsAttributes(x),LISTSXP)
*/
SEXP do_xtsAttributes(SEXP x)
{
SEXP a, values, names;
int i=0, P=0;
a = ATTRIB(x);
if(length(a) <= 0)
return R_NilValue;
PROTECT(a); P++; /* all attributes */
PROTECT(values = allocVector(VECSXP, length(a))); P++;
PROTECT(names = allocVector(STRSXP, length(a))); P++;
/*
CAR gets the first element of the dotted pair list
CDR gets the rest of the dotted pair list
TAG gets the symbol/name of the first element of dotted pair list
*/
for( /* a=ATTRIB(a) */; a != R_NilValue; a = CDR(a) ) {
if(TAG(a) != xts_IndexSymbol &&
TAG(a) != xts_ClassSymbol &&
TAG(a) != xts_IndexFormatSymbol &&
TAG(a) != xts_IndexClassSymbol &&
TAG(a) != xts_IndexTZSymbol &&
TAG(a) != R_ClassSymbol &&
TAG(a) != R_DimSymbol &&
TAG(a) != R_DimNamesSymbol &&
TAG(a) != R_NamesSymbol)
{
SET_VECTOR_ELT(values, i, CAR(a));
SET_STRING_ELT(names, i, PRINTNAME(TAG(a)));
i++;
}
}
if(i == 0) {
UNPROTECT(P);
return R_NilValue;
}
/* truncate list back to i-size */
PROTECT(values = lengthgets(values, i)); P++;
PROTECT(names = lengthgets(names, i)); P++;
setAttrib(values, R_NamesSymbol, names);
UNPROTECT(P);
return values;
}
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;
}
/* 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);
}
void copyAttributes(SEXP x, SEXP y)
{
/* similar to copyMostAttr except that we add index
to the list of attributes to exclude */
SEXP attr;
int P=0;
attr = ATTRIB(x); /* this returns a LISTSXP */
if(length(attr) > 0 || y != R_NilValue) {
PROTECT(attr); P++;
for( ; attr != R_NilValue; attr = CDR(attr) ) {
if( (TAG(attr) != install("index")) &&
(TAG(attr) != R_DimSymbol) &&
(TAG(attr) != R_DimNamesSymbol) &&
(TAG(attr) != R_NamesSymbol) ) {
setAttrib(y, TAG(attr), CAR(attr));
}
}
UNPROTECT(P);
}
}
