bool SimpleArray_UB16_1::typep(Value type) const
{
if (consp(type))
{
Value type_specifier_atom = xcar(type);
Value tail = xcdr(type);
if (type_specifier_atom == S_array || type_specifier_atom == S_simple_array)
{
if (consp(tail))
{
Value element_type = xcar(tail);
if (element_type == UNSPECIFIED)
; // ok
else
{
Value upgraded_element_type = upgraded_array_element_type(element_type);
if (::equal(upgraded_element_type, UB16_TYPE))
; // ok
else if (::equal(upgraded_element_type,
list3(S_integer, FIXNUM_ZERO, make_fixnum(65535))))
; // ok
else if (::equal(upgraded_element_type,
list3(S_integer, FIXNUM_ZERO, list1(make_fixnum(65536)))))
; // ok
else
return false;
}
tail = xcdr(tail);
if (tail == NIL)
return true;
if (cdr(tail) == NIL) // i.e. length(tail) == 1
{
Value dimensions = xcar(tail);
if (dimensions == UNSPECIFIED)
return true;
if (dimensions == FIXNUM_ONE)
return true;
if (::equal(dimensions, list1(UNSPECIFIED)))
return true;
if (::equal(dimensions, list1(make_fixnum(_capacity))))
return true;
}
}
}
}
else if (symbolp(type))
{
if (type == S_vector || type == S_sequence || type == S_simple_array
|| type == S_array || type == S_atom || type == T)
return true;
}
else
{
if (type == C_vector || type == C_array || type == C_sequence || type == C_t)
return true;
}
return false;
}
static Lisp_Object Linteger_decode_float(Lisp_Object nil, Lisp_Object a)
{
double d = float_of_number(a);
#ifdef COMMON
int tag = (int)a & TAG_BITS;
#endif
int x, neg = 0;
int32_t a1, a2;
CSL_IGNORE(nil);
if (!is_float(a)) return aerror("integer-decode-float");
if (d == 0.0)
#ifdef COMMON
{ mv_2 = fixnum_of_int(0);
mv_3 = fixnum_of_int(d<0 ? -1 : 1);
nvalues(fixnum_of_int(0), 3);
}
#else
return list3(fixnum_of_int(0), fixnum_of_int(0),
fixnum_of_int(d<0 ? -1 : 1));
#endif
if (d < 0.0) d = -d, neg = 1;
d = frexp(d, &x);
if (d == 1.0) d = 0.5, x++;
#ifdef COMMON
if (tag == TAG_SFLOAT)
{ d *= TWO_20;
x -= 20;
a1 = (int32_t)d;
a = fixnum_of_int(a1);
}
else if (tag == TAG_BOXFLOAT &&
type_of_header(flthdr(a)) == TYPE_SINGLE_FLOAT)
{ d *= TWO_24;
x -= 24;
a1 = (int32_t)d;
a = fixnum_of_int(a1);
}
else
#endif
{ d *= TWO_22;
a1 = (int32_t)d;
d -= (double)a1;
a2 = (int32_t)(d*TWO_31); /* This conversion should be exact */
x -= 53;
a = make_two_word_bignum(a1, a2);
errexit();
}
#ifdef COMMON
{ mv_2 = fixnum_of_int(x);
mv_3 = neg ? fixnum_of_int(-1) : fixnum_of_int(1);
return nvalues(a, 3);
}
#else
return list3(a, fixnum_of_int(x),
neg ? fixnum_of_int(-1) : fixnum_of_int(1));
#endif
}
INLINE_FUN SEXP lang4(SEXP s, SEXP t, SEXP u, SEXP v)
{
PROTECT(s);
s = LCONS(s, list3(t, u, v));
UNPROTECT(1);
return s;
}
static Lisp_Object Ldecode_float(Lisp_Object nil, Lisp_Object a)
{
double d = float_of_number(a), neg = 1.0;
int x;
Lisp_Object sign;
if (!is_float(a)) return aerror("decode-float");
if (d < 0.0) d = -d, neg = -1.0;
if (d == 0.0) x = 0;
else
{ d = frexp(d, &x);
if (d == 1.0) d = 0.5, x++;
}
#ifdef COMMON
if (is_sfloat(a)) sign = make_sfloat(neg);
else
#endif
sign = make_boxfloat(neg, type_of_header(flthdr(a)));
errexit();
push(sign);
#ifdef COMMON
if (is_sfloat(a)) a = make_sfloat(d);
else
#endif
a = make_boxfloat(d, type_of_header(flthdr(a)));
pop(sign);
errexit();
#ifdef COMMON
mv_2 = fixnum_of_int(x);
mv_3 = sign;
return nvalues(a, 3);
#else
return list3(sign, fixnum_of_int(x), a);
#endif
}
static void
generate_reverse_dimension_expr(TYPE_DESC tp, expr dimSpec) {
if (TYPE_REF(tp) != NULL && IS_ARRAY_TYPE(tp)) {
expr lower = NULL;
expr upper = NULL;
expr step = NULL;
expr dims = NULL;
int n;
if (TYPE_DIM_UPPER(tp) != NULL) {
n = (int)EXPV_INT_VALUE(TYPE_DIM_UPPER(tp));
upper = make_int_enode(n);
}
if (TYPE_DIM_LOWER(tp) != NULL) {
n = (int)EXPV_INT_VALUE(TYPE_DIM_LOWER(tp));
lower = make_int_enode(n);
}
if (TYPE_DIM_STEP(tp) != NULL) {
n = (int)EXPV_INT_VALUE(TYPE_DIM_STEP(tp));
step = make_int_enode(n);
}
dims = list3(F_INDEX_RANGE, lower, upper, step);
set_index_range_type(dims);
list_put_last(dimSpec, dims);
generate_reverse_dimension_expr(TYPE_REF(tp), dimSpec);
}
}
// ### autoload-macro
Value EXT_autoload_macro(unsigned int numargs, Value args[])
{
switch (numargs)
{
case 1:
if (listp(args[0]))
{
Value list = args[0];
while (list != NIL)
{
Value name = car(list);
check_symbol(name)->set_autoload_macro(new Autoload(name));
list = xcdr(list);
}
return T;
}
else if (symbolp(args[0]))
{
the_symbol(args[0])->set_autoload_macro(new Autoload(args[0]));
return T;
}
else
return signal_type_error(args[0], list3(S_or, S_symbol, S_list));
case 2:
if (listp(args[0]))
{
AbstractString * filename = check_string(args[1]);
Value list = args[0];
while (list != NIL)
{
Value name = car(list);
check_symbol(name)->set_autoload_macro(new Autoload(name, filename));
list = xcdr(list);
}
return T;
}
else if (symbolp(args[0]))
{
the_symbol(args[0])->set_autoload_macro(new Autoload(args[0], check_string(args[1])));
return T;
}
else
return signal_type_error(args[0], list3(S_or, S_symbol, S_list));
default:
return wrong_number_of_arguments(S_autoload, numargs, 1, 2);
}
}
static obj func_def(obj name, obj params, obj expr) {
assert(type(name)==tSymbol);
obj* func = lfind_var(name);
if(! *func) {
obj (*fn)(obj) = searchFunc(name, infnbind);
if(fn) let(func, tag(fn));
}
list lam = list3(retain(params), retain(expr), retain(env));
if(*func){
if(type(*func)==tClosure){ // free if complete overload, in the future
lam = merge(lam, retain(ul(*func)));
} else if(type(*func)==tInternalFn){
lam = merge(lam, list3(retain(*func), nil, nil));
}
}
return retain(*let(func, render(tClosure, lam)));
}
static Lisp_Object
gtk_color_instance_rgb_components (struct Lisp_Color_Instance *c)
{
GdkColor *color = COLOR_INSTANCE_GTK_COLOR (c);
return (list3 (make_int (color->red),
make_int (color->green),
make_int (color->blue)));
}
inline SimpleArray_UB32_1 * check_simple_array_ub32_1(Value value)
{
if (simple_array_ub32_1_p(value))
return the_simple_array_ub32_1(value);
Value expected_type = list3(S_simple_array, S_unsigned_byte, list1(make_fixnum(32)));
signal_type_error(value, expected_type);
// Not reached.
return NULL;
}
INDEX Array_T::dimension(unsigned int n) const
{
if (n < _rank)
return _dimensions[n];
signal_type_error(make_unsigned_integer(n),
list3(S_integer, FIXNUM_ZERO, make_unsigned_integer(_rank - 1)));
// not reached
return 0;
}
Layout * PackageError::get_layout_for_class()
{
static Layout * layout;
if (layout == NULL)
layout = new Layout(the_class(C_package_error),
list3(S_format_control,
S_format_arguments,
S_package),
NIL);
return layout;
}
static Lisp_Object
make_dom (xmlNode *node)
{
if (node->type == XML_ELEMENT_NODE)
{
Lisp_Object result = Fcons (intern ((char *) node->name), Qnil);
xmlNode *child;
xmlAttr *property;
Lisp_Object plist = Qnil;
/* First add the attributes. */
property = node->properties;
while (property != NULL)
{
if (property->children &&
property->children->content)
{
char *content = (char *) property->children->content;
plist = Fcons (Fcons (intern ((char *) property->name),
build_string (content)),
plist);
}
property = property->next;
}
result = Fcons (Fnreverse (plist), result);
/* Then add the children of the node. */
child = node->children;
while (child != NULL)
{
result = Fcons (make_dom (child), result);
child = child->next;
}
return Fnreverse (result);
}
else if (node->type == XML_TEXT_NODE || node->type == XML_CDATA_SECTION_NODE)
{
if (node->content)
return build_string ((char *) node->content);
else
return Qnil;
}
else if (node->type == XML_COMMENT_NODE)
{
if (node->content)
return list3 (intern ("comment"), Qnil,
build_string ((char *) node->content));
else
return Qnil;
}
else
return Qnil;
}
Value ZeroRankArray::aref(unsigned long i) const
{
if (i == 0)
{
if (_array)
return _array->aref(_offset);
else
return _data;
}
return signal_type_error(make_unsigned_integer(i),
list3(S_integer, FIXNUM_ZERO, FIXNUM_ZERO));
}
static
obj enclose(obj v){
vto_close = Assoc();
assert(v->type == tArrow);
obj vs = Assoc();
pbind_vars(&vs, em0(v));
penv = op(vs, nil);
enclose0(em1(v));
release(penv);
assert(vto_close->type == tAssoc);
if(! ul(vto_close)) return render(tClosure, list3(retain(em0(v)), retain(em1(v)), nil));
list varlist = nil, vallist = nil;
for(list l = ul(vto_close); l; l=rest(l)){
varlist = cons(retain(car(first(l))), varlist);
vallist = cons(find_var(car(first(l))), vallist);
}
release(vto_close);
obj rr = curry(List2v(varlist), List2v(vallist), retain(em1(v)));
rr = render(tClosure, list3(retain(em0(v)), rr, nil));
return rr;
}
Value ZeroRankArray::aset(unsigned long i, Value new_value)
{
if (i == 0)
{
if (_array)
_array->aset(_offset, new_value);
else
_data = new_value;
return new_value;
}
return signal_type_error(make_unsigned_integer(i),
list3(S_integer, FIXNUM_ZERO, FIXNUM_ZERO));
}
static void
generate_assumed_shape_expr(expr dimSpec, int dim) {
expv dimElm;
if (dim == 1)
return;
dimElm = list3(F_INDEX_RANGE, NULL, NULL, NULL);
set_index_range_type(dimElm);
generate_assumed_shape_expr(dimSpec, dim - 1);
list_put_last(dimSpec, dimElm);
}
void init_coll_functions(void)
{
define_generic_function("element", list2(obj_CollClass, obj_ObjectClass),
false, list1(symbol("default")), false,
list1(obj_ObjectClass), obj_False);
define_generic_function("element-setter",
list3(obj_ObjectClass, obj_CollClass,
obj_ObjectClass),
false, obj_False, false,
list1(obj_ObjectClass), obj_False);
define_generic_function("size", list1(obj_ObjectClass),
false, obj_False, false,
obj_Nil, obj_ObjectClass);
}
void
generate_shape_expr(TYPE_DESC tp, expr dimSpec) {
expv dimElm;
if ((TYPE_REF(tp) == NULL) || !IS_ARRAY_TYPE(tp))
return;
dimElm = list3(F_INDEX_RANGE,
TYPE_DIM_LOWER(tp), TYPE_DIM_UPPER(tp), TYPE_DIM_STEP(tp));
set_index_range_type(dimElm);
generate_shape_expr(TYPE_REF(tp), dimSpec);
if(TYPE_N_DIM(tp) != 0)
list_put_last(dimSpec, dimElm);
}
Value Array_T::aref(unsigned long index) const
{
if (_data)
{
if (index < _total_size)
return _data[index];
else
return signal_type_error(make_unsigned_integer(index),
list3(S_integer, FIXNUM_ZERO, make_unsigned_integer(_total_size)));
}
else
{
// displaced
return _array->aref(index + _offset);
}
}
static void
generate_contracted_shape_expr(TYPE_DESC tp, expr dimSpec, int dim) {
expv dimElm;
if ((TYPE_REF(tp) == NULL) || !IS_ARRAY_TYPE(tp))
return;
dimElm = list3(F_INDEX_RANGE,
TYPE_DIM_LOWER(tp), TYPE_DIM_UPPER(tp), TYPE_DIM_STEP(tp));
set_index_range_type(dimElm);
if (dim == 0) {
generate_shape_expr(TYPE_REF(tp), dimSpec);
} else {
generate_contracted_shape_expr(TYPE_REF(tp), dimSpec, dim - 1);
list_put_last(dimSpec, dimElm);
}
}
/*
void GetAppList(const char *signature, BList *teamIDList) const
@case 3 teamIDList is not NULL and not empty, signature is not
NULL and app(s) with this signature is (are) running
@results Should append the team IDs of all running apps with the
supplied signature to teamIDList.
*/
void GetAppListTester::GetAppListTestB3()
{
const char *signature = "application/x-vnd.obos-app-run-testapp1";
// create a list with some dummy entries
BList list;
list.AddItem((void*)-7);
list.AddItem((void*)-42);
// get a list of running applications for reference
BRoster roster;
BList list1(list);
roster.GetAppList(signature, &list1);
check_list(list1, list);
// run some apps
AppRunner runner1(true);
AppRunner runner2(true);
AppRunner runner3(true);
CHK(runner1.Run("AppRunTestApp1") == B_OK);
CHK(runner2.Run("AppRunTestApp2") == B_OK);
CHK(runner3.Run("BMessengerTestApp1") == B_OK);
BList expectedApps;
expectedApps.AddItem((void*)runner1.Team());
expectedApps.AddItem((void*)runner2.Team());
// get a new app list and check it
BList list2(list);
roster.GetAppList(signature, &list2);
check_list(list2, list, expectedApps);
// quit app 1
runner1.WaitFor(true);
expectedApps.RemoveItem((void*)runner1.Team());
BList list3(list);
roster.GetAppList(signature, &list3);
check_list(list3, list, expectedApps);
// quit app 2
runner2.WaitFor(true);
expectedApps.RemoveItem((void*)runner2.Team());
BList list4(list);
roster.GetAppList(signature, &list4);
check_list(list4, list, expectedApps);
// quit app 3
runner3.WaitFor(true);
BList list5(list);
roster.GetAppList(signature, &list5);
check_list(list5, list, expectedApps);
}
Value Array_T::aset(unsigned long index, Value new_value)
{
if (_data)
{
if (index < _total_size)
{
_data[index] = new_value;
return new_value;
}
else
return signal_type_error(make_unsigned_integer(index),
list3(S_integer, FIXNUM_ZERO, make_unsigned_integer(_total_size)));
}
else
{
// displaced
return _array->aset(index + _offset, new_value);
}
}
/* =========== CompareLists ================*/
TEST(LinkedListExcercisesTestSuite, CompareLists)
{
int data1[5] = { 2, 4, 6, 7, 8 };
LinkedList<int> list1(data1, 5);
//test identical list
LinkedList<int> list2(data1, 5);
EXPECT_TRUE(LinkedListExercises::CompareLists(list1, list2));
//test identical but shorter list
LinkedList<int> list3(data1, 4);
EXPECT_FALSE(LinkedListExercises::CompareLists(list1, list3));
//test diffrent list
int data2[4] = { 1, 3, 6, 7 };
LinkedList<int> list4(data2, 4);
EXPECT_FALSE(LinkedListExercises::CompareLists(list1, list4));
//test empty
LinkedList<int> empty_list1;
LinkedList<int> empty_list2;
EXPECT_TRUE(LinkedListExercises::CompareLists(empty_list1, empty_list2));
}
static Lisp_Object Ldecode_float(Lisp_Object nil, Lisp_Object a)
{
double d, neg = 1.0;
int x;
Lisp_Object sign;
if (!is_float(a)) return aerror("decode-float");
d = float_of_number(a);
if (!(d == d)) return onevalue(nil); /* a NaN */
if (d < 0.0) d = -d, neg = -1.0;
if (d == 0.0) x = 0;
else if (1.0/d == 0.0) /* An infinity */
{ x = 1000000; /* Extreme (arbitrary) value */
}
else
{ d = frexp(d, &x);
if (d == 1.0) d = 0.5, x++;
}
#ifdef COMMON
if (is_sfloat(a)) sign = make_sfloat(neg);
else
#endif
sign = make_boxfloat(neg, type_of_header(flthdr(a)));
errexit();
push(sign);
#ifdef COMMON
if (is_sfloat(a)) a = make_sfloat(d);
else
#endif
a = make_boxfloat(d, type_of_header(flthdr(a)));
pop(sign);
errexit();
#ifdef COMMON
mv_2 = fixnum_of_int(x);
mv_3 = sign;
return nvalues(a, 3);
#else
return list3(sign, fixnum_of_int(x), a);
#endif
}
expv OMP_pragma_list(enum OMP_pragma pragma,expv arg1,expv arg2)
{
return list3(OMP_PRAGMA,expv_int_term(INT_CONSTANT,NULL,(int)pragma),
arg1,arg2);
}
void init_fd_functions(void)
{
define_constant("fd-close",
make_raw_method("fd-close", list1(obj_FixnumClass),
false, obj_False, false,
list2(obj_BooleanClass, obj_ObjectClass),
obj_False, fd_close));
define_method("fd-error-string", list1(obj_FixnumClass), false,
obj_False, false, obj_ObjectClass, fd_error_str);
define_constant("fd-input-available?",
make_raw_method("fd-input-available?",
list1(obj_FixnumClass),
false, obj_False, false,
list2(obj_BooleanClass, obj_ObjectClass),
obj_False, fd_input_available));
define_constant("fd-open",
make_raw_method("fd-open",
list2(obj_ByteStringClass,
obj_FixnumClass),
false, obj_False, false,
list2(obj_ObjectClass, obj_ObjectClass),
obj_False, fd_open));
define_constant("fd-read",
make_raw_method("fd-read",
listn(4, obj_FixnumClass,
obj_BufferClass,
obj_FixnumClass,
obj_FixnumClass),
false, obj_False, false,
list2(obj_ObjectClass, obj_ObjectClass),
obj_False, fd_read));
define_constant("fd-seek",
make_raw_method("fd-seek",
list3(obj_FixnumClass,
obj_FixnumClass,
obj_FixnumClass),
false, obj_False, false,
list2(obj_ObjectClass, obj_ObjectClass),
obj_False, fd_seek));
define_constant("fd-sync-output",
make_raw_method("fd-sync-output",
list1(obj_FixnumClass),
false, obj_False, false,
list2(obj_BooleanClass, obj_ObjectClass),
obj_False, fd_sync_output));
define_constant("fd-write",
make_raw_method("fd-write",
listn(4, obj_FixnumClass,
obj_BufferClass,
obj_FixnumClass,
obj_FixnumClass),
false, obj_False, false,
list2(obj_ObjectClass, obj_ObjectClass),
obj_False, fd_write));
define_constant("fd-exec",
make_raw_method("fd-exec",
list1(obj_ByteStringClass),
false, obj_False, false,
list2(obj_ObjectClass, obj_ObjectClass),
obj_False, fd_exec));
define_function("file-write-date", list1(obj_ByteStringClass), false,
obj_False, false, obj_ObjectClass, file_write_date);
define_constant("SEEK_SET", make_fixnum(SEEK_SET));
define_constant("SEEK_CUR", make_fixnum(SEEK_CUR));
define_constant("SEEK_END", make_fixnum(SEEK_END));
define_constant("O_RDONLY", make_fixnum(O_RDONLY));
define_constant("O_WRONLY", make_fixnum(O_WRONLY));
define_constant("O_RDWR", make_fixnum(O_RDWR));
define_constant("O_APPEND", make_fixnum(O_APPEND));
define_constant("O_CREAT", make_fixnum(O_CREAT));
define_constant("O_EXCL", make_fixnum(O_EXCL));
define_constant("O_TRUNC", make_fixnum(O_TRUNC));
#ifndef _WIN32
define_constant("O_NONBLOCK", make_fixnum(O_NONBLOCK));
#endif
/* This compendium of error numbers comes from Tcl. */
#ifdef E2BIG
define_constant("E2BIG", make_fixnum(E2BIG));
#endif
#ifdef EACCES
define_constant("EACCES", make_fixnum(EACCES));
#endif
#ifdef EADDRINUSE
define_constant("EADDRINUSE", make_fixnum(EADDRINUSE));
#endif
#ifdef EADDRNOTAVAIL
define_constant("EADDRNOTAVAIL", make_fixnum(EADDRNOTAVAIL));
#endif
#ifdef EADV
define_constant("EADV", make_fixnum(EADV));
#endif
#ifdef EAFNOSUPPORT
define_constant("EAFNOSUPPORT", make_fixnum(EAFNOSUPPORT));
#endif
#ifdef EAGAIN
define_constant("EAGAIN", make_fixnum(EAGAIN));
#endif
#ifdef EALIGN
define_constant("EALIGN", make_fixnum(EALIGN));
#endif
#ifdef EALREADY
define_constant("EALREADY", make_fixnum(EALREADY));
#endif
#ifdef EBADE
define_constant("EBADE", make_fixnum(EBADE));
#endif
#ifdef EBADF
define_constant("EBADF", make_fixnum(EBADF));
#endif
#ifdef EBADFD
define_constant("EBADFD", make_fixnum(EBADFD));
#endif
#ifdef EBADMSG
define_constant("EBADMSG", make_fixnum(EBADMSG));
#endif
#ifdef EBADR
define_constant("EBADR", make_fixnum(EBADR));
#endif
#ifdef EBADRPC
define_constant("EBADRPC", make_fixnum(EBADRPC));
#endif
#ifdef EBADRQC
define_constant("EBADRQC", make_fixnum(EBADRQC));
#endif
#ifdef EBADSLT
define_constant("EBADSLT", make_fixnum(EBADSLT));
#endif
#ifdef EBFONT
define_constant("EBFONT", make_fixnum(EBFONT));
#endif
#ifdef EBUSY
define_constant("EBUSY", make_fixnum(EBUSY));
#endif
#ifdef ECHILD
define_constant("ECHILD", make_fixnum(ECHILD));
#endif
#ifdef ECHRNG
define_constant("ECHRNG", make_fixnum(ECHRNG));
#endif
#ifdef ECOMM
define_constant("ECOMM", make_fixnum(ECOMM));
#endif
#ifdef ECONNABORTED
define_constant("ECONNABORTED", make_fixnum(ECONNABORTED));
#endif
#ifdef ECONNREFUSED
define_constant("ECONNREFUSED", make_fixnum(ECONNREFUSED));
#endif
#ifdef ECONNRESET
define_constant("ECONNRESET", make_fixnum(ECONNRESET));
#endif
#if defined(EDEADLK) && (!defined(EWOULDBLOCK) || (EDEADLK != EWOULDBLOCK))
define_constant("EDEADLK", make_fixnum(EDEADLK));
#endif
#ifdef EDEADLOCK
define_constant("EDEADLOCK", make_fixnum(EDEADLOCK));
#endif
#ifdef EDESTADDRREQ
define_constant("EDESTADDRREQ", make_fixnum(EDESTADDRREQ));
#endif
#ifdef EDIRTY
define_constant("EDIRTY", make_fixnum(EDIRTY));
#endif
#ifdef EDOM
define_constant("EDOM", make_fixnum(EDOM));
#endif
#ifdef EDOTDOT
define_constant("EDOTDOT", make_fixnum(EDOTDOT));
#endif
#ifdef EDQUOT
define_constant("EDQUOT", make_fixnum(EDQUOT));
#endif
#ifdef EDUPPKG
define_constant("EDUPPKG", make_fixnum(EDUPPKG));
#endif
#ifdef EEXIST
define_constant("EEXIST", make_fixnum(EEXIST));
#endif
#ifdef EFAULT
define_constant("EFAULT", make_fixnum(EFAULT));
#endif
#ifdef EFBIG
define_constant("EFBIG", make_fixnum(EFBIG));
#endif
#ifdef EHOSTDOWN
define_constant("EHOSTDOWN", make_fixnum(EHOSTDOWN));
#endif
#ifdef EHOSTUNREACH
define_constant("EHOSTUNREACH", make_fixnum(EHOSTUNREACH));
#endif
#ifdef EIDRM
define_constant("EIDRM", make_fixnum(EIDRM));
#endif
#ifdef EINIT
define_constant("EINIT", make_fixnum(EINIT));
#endif
#ifdef EINPROGRESS
define_constant("EINPROGRESS", make_fixnum(EINPROGRESS));
#endif
#ifdef EINTR
define_constant("EINTR", make_fixnum(EINTR));
#endif
#ifdef EINVAL
define_constant("EINVAL", make_fixnum(EINVAL));
#endif
#ifdef EIO
define_constant("EIO", make_fixnum(EIO));
#endif
#ifdef EISCONN
define_constant("EISCONN", make_fixnum(EISCONN));
#endif
#ifdef EISDIR
define_constant("EISDIR", make_fixnum(EISDIR));
#endif
#ifdef EISNAME
define_constant("EISNAM", make_fixnum(EISNAM));
#endif
#ifdef ELBIN
define_constant("ELBIN", make_fixnum(ELBIN));
#endif
#ifdef EL2HLT
define_constant("EL2HLT", make_fixnum(EL2HLT));
#endif
#ifdef EL2NSYNC
define_constant("EL2NSYNC", make_fixnum(EL2NSYNC));
#endif
#ifdef EL3HLT
define_constant("EL3HLT", make_fixnum(EL3HLT));
#endif
#ifdef EL3RST
define_constant("EL3RST", make_fixnum(EL3RST));
#endif
#ifdef ELIBACC
define_constant("ELIBACC", make_fixnum(ELIBACC));
#endif
#ifdef ELIBBAD
define_constant("ELIBBAD", make_fixnum(ELIBBAD));
#endif
#ifdef ELIBEXEC
define_constant("ELIBEXEC", make_fixnum(ELIBEXEC));
#endif
#ifdef ELIBMAX
define_constant("ELIBMAX", make_fixnum(ELIBMAX));
#endif
#ifdef ELIBSCN
define_constant("ELIBSCN", make_fixnum(ELIBSCN));
#endif
#ifdef ELNRNG
define_constant("ELNRNG", make_fixnum(ELNRNG));
#endif
#ifdef ELOOP
define_constant("ELOOP", make_fixnum(ELOOP));
#endif
#ifdef EMFILE
define_constant("EMFILE", make_fixnum(EMFILE));
#endif
#ifdef EMLINK
define_constant("EMLINK", make_fixnum(EMLINK));
#endif
#ifdef EMSGSIZE
define_constant("EMSGSIZE", make_fixnum(EMSGSIZE));
#endif
#ifdef EMULTIHOP
define_constant("EMULTIHOP", make_fixnum(EMULTIHOP));
#endif
#ifdef ENAMETOOLONG
define_constant("ENAMETOOLONG", make_fixnum(ENAMETOOLONG));
#endif
#ifdef ENAVAIL
define_constant("ENAVAIL", make_fixnum(ENAVAIL));
#endif
#ifdef ENET
define_constant("ENET", make_fixnum(ENET));
#endif
#ifdef ENETDOWN
define_constant("ENETDOWN", make_fixnum(ENETDOWN));
#endif
#ifdef ENETRESET
define_constant("ENETRESET", make_fixnum(ENETRESET));
#endif
#ifdef ENETUNREACH
define_constant("ENETUNREACH", make_fixnum(ENETUNREACH));
#endif
#ifdef ENFILE
define_constant("ENFILE", make_fixnum(ENFILE));
#endif
#ifdef ENOANO
define_constant("ENOANO", make_fixnum(ENOANO));
#endif
#if defined(ENOBUFS) && (!defined(ENOSR) || (ENOBUFS != ENOSR))
define_constant("ENOBUFS", make_fixnum(ENOBUFS));
#endif
#ifdef ENOCSI
define_constant("ENOCSI", make_fixnum(ENOCSI));
#endif
#ifdef ENODATA
define_constant("ENODATA", make_fixnum(ENODATA));
#endif
#ifdef ENODEV
define_constant("ENODEV", make_fixnum(ENODEV));
#endif
#ifdef ENOENT
define_constant("ENOENT", make_fixnum(ENOENT));
#endif
#ifdef ENOEXEC
define_constant("ENOEXEC", make_fixnum(ENOEXEC));
#endif
#ifdef ENOLCK
define_constant("ENOLCK", make_fixnum(ENOLCK));
#endif
#ifdef ENOLINK
define_constant("ENOLINK", make_fixnum(ENOLINK));
#endif
#ifdef ENOMEM
define_constant("ENOMEM", make_fixnum(ENOMEM));
#endif
#ifdef ENOMSG
define_constant("ENOMSG", make_fixnum(ENOMSG));
#endif
#ifdef ENONET
define_constant("ENONET", make_fixnum(ENONET));
#endif
#ifdef ENOPKG
define_constant("ENOPKG", make_fixnum(ENOPKG));
#endif
#ifdef ENOPROTOOPT
define_constant("ENOPROTOOPT", make_fixnum(ENOPROTOOPT));
#endif
#ifdef ENOSPC
define_constant("ENOSPC", make_fixnum(ENOSPC));
#endif
#ifdef ENOSR
define_constant("ENOSR", make_fixnum(ENOSR));
#endif
#if defined(ENOSTR) && (!defined(ENOTTY) || (ENOTTY != ENOSTR))
define_constant("ENOSTR", make_fixnum(ENOSTR));
#endif
#ifdef ENOSYM
define_constant("ENOSYM", make_fixnum(ENOSYM));
#endif
#ifdef ENOSYS
define_constant("ENOSYS", make_fixnum(ENOSYS));
#endif
#ifdef ENOTBLK
define_constant("ENOTBLK", make_fixnum(ENOTBLK));
#endif
#ifdef ENOTCONN
define_constant("ENOTCONN", make_fixnum(ENOTCONN));
#endif
#ifdef ENOTDIR
define_constant("ENOTDIR", make_fixnum(ENOTDIR));
#endif
#if defined(ENOTEMPTY) && (!defined(EEXIST) || (ENOTEMPTY != EEXIST))
define_constant("ENOTEMPTY", make_fixnum(ENOTEMPTY));
#endif
#ifdef ENOTNAM
define_constant("ENOTNAM", make_fixnum(ENOTNAM));
#endif
#ifdef ENOTSOCK
define_constant("ENOTSOCK", make_fixnum(ENOTSOCK));
#endif
#ifdef ENOTTY
define_constant("ENOTTY", make_fixnum(ENOTTY));
#endif
#ifdef ENOTUNIQ
define_constant("ENOTUNIQ", make_fixnum(ENOTUNIQ));
#endif
#ifdef ENXIO
define_constant("ENXIO", make_fixnum(ENXIO));
#endif
#ifdef EOPNOTSUPP
define_constant("EOPNOTSUPP", make_fixnum(EOPNOTSUPP));
#endif
#ifdef EPERM
define_constant("EPERM", make_fixnum(EPERM));
#endif
#ifdef EPFNOSUPPORT
define_constant("EPFNOSUPPORT", make_fixnum(EPFNOSUPPORT));
#endif
#ifdef EPIPE
define_constant("EPIPE", make_fixnum(EPIPE));
#endif
#ifdef EPROCLIM
define_constant("EPROCLIM", make_fixnum(EPROCLIM));
#endif
#ifdef EPROCUNAVAIL
define_constant("EPROCUNAVAIL", make_fixnum(EPROCUNAVAIL));
#endif
#ifdef EPROGMISMATCH
define_constant("EPROGMISMATCH", make_fixnum(EPROGMISMATCH));
#endif
#ifdef EPROGUNAVAIL
define_constant("EPROGUNAVAIL", make_fixnum(EPROGUNAVAIL));
#endif
#ifdef EPROTO
define_constant("EPROTO", make_fixnum(EPROTO));
#endif
#ifdef EPROTONOSUPPORT
define_constant("EPROTONOSUPPORT", make_fixnum(EPROTONOSUPPORT));
#endif
#ifdef EPROTOTYPE
define_constant("EPROTOTYPE", make_fixnum(EPROTOTYPE));
#endif
#ifdef ERANGE
define_constant("ERANGE", make_fixnum(ERANGE));
#endif
#if defined(EREFUSED) && (!defined(ECONNREFUSED) || (EREFUSED != ECONNREFUSED))
define_constant("EREFUSED", make_fixnum(EREFUSED));
#endif
#ifdef EREMCHG
define_constant("EREMCHG", make_fixnum(EREMCHG));
#endif
#ifdef EREMDEV
define_constant("EREMDEV", make_fixnum(EREMDEV));
#endif
#ifdef EREMOTE
define_constant("EREMOTE", make_fixnum(EREMOTE));
#endif
#ifdef EREMOTEIO
define_constant("EREMOTEIO", make_fixnum(EREMOTEIO));
#endif
#ifdef EREMOTERELEASE
define_constant("EREMOTERELEASE", make_fixnum(EREMOTERELEASE));
#endif
#ifdef EROFS
define_constant("EROFS", make_fixnum(EROFS));
#endif
#ifdef ERPCMISMATCH
define_constant("ERPCMISMATCH", make_fixnum(ERPCMISMATCH));
#endif
#ifdef ERREMOTE
define_constant("ERREMOTE", make_fixnum(ERREMOTE));
#endif
#ifdef ESHUTDOWN
define_constant("ESHUTDOWN", make_fixnum(ESHUTDOWN));
#endif
#ifdef ESOCKTNOSUPPORT
define_constant("ESOCKTNOSUPPORT", make_fixnum(ESOCKTNOSUPPORT));
#endif
#ifdef ESPIPE
define_constant("ESPIPE", make_fixnum(ESPIPE));
#endif
#ifdef ESRCH
define_constant("ESRCH", make_fixnum(ESRCH));
#endif
#ifdef ESRMNT
define_constant("ESRMNT", make_fixnum(ESRMNT));
#endif
#ifdef ESTALE
define_constant("ESTALE", make_fixnum(ESTALE));
#endif
#ifdef ESUCCESS
define_constant("ESUCCESS", make_fixnum(ESUCCESS));
#endif
#ifdef ETIME
define_constant("ETIME", make_fixnum(ETIME));
#endif
#ifdef ETIMEDOUT
define_constant("ETIMEDOUT", make_fixnum(ETIMEDOUT));
#endif
#ifdef ETOOMANYREFS
define_constant("ETOOMANYREFS", make_fixnum(ETOOMANYREFS));
#endif
#ifdef ETXTBSY
define_constant("ETXTBSY", make_fixnum(ETXTBSY));
#endif
#ifdef EUCLEAN
define_constant("EUCLEAN", make_fixnum(EUCLEAN));
#endif
#ifdef EUNATCH
define_constant("EUNATCH", make_fixnum(EUNATCH));
#endif
#ifdef EUSERS
define_constant("EUSERS", make_fixnum(EUSERS));
#endif
#ifdef EVERSION
define_constant("EVERSION", make_fixnum(EVERSION));
#endif
#if defined(EWOULDBLOCK) && (!defined(EAGAIN) || (EWOULDBLOCK != EAGAIN))
define_constant("EWOULDBLOCK", make_fixnum(EWOULDBLOCK));
#endif
#ifdef EXDEV
define_constant("EXDEV", make_fixnum(EXDEV));
#endif
#ifdef EXFULL
define_constant("EXFULL", make_fixnum(EXFULL));
#endif
#ifdef _WIN32
win32_inits();
#endif
#if 0
#ifdef _WIN32
if (isatty(0)) { /* If stdin is a tty and not redirected */
stdin_buffer_empty = CreateEvent(NULL, true, true, NULL);
stdin_buffer_not_empty = CreateEvent(NULL, true, false, NULL);
/* These are nameless "manual reset" events */
InitializeCriticalSection(&stdin_buffer_mutex);
{
DWORD thread_id;
HANDLE thread_handle;
thread_handle
= CreateThread(NULL, 0,
(LPTHREAD_START_ROUTINE) stdin_producer,
NULL, 0, &thread_id);
if (thread_handle == NULL)
lose("Can't create stdin_producer thread");
}
}
#endif
#endif
}
RcppExport SEXP nniv(SEXP arg1, SEXP arg2, SEXP arg3) {
// 3 arguments
// arg1 for parameters
// arg2 for data
// arg3 for Gibbs
// data
List list2(arg2);
const MatrixXd X=as< Map<MatrixXd> >(list2["X"]),
Z=as< Map<MatrixXd> >(list2["Z"]);
const VectorXd t=as< Map<VectorXd> >(list2["t"]),
y=as< Map<VectorXd> >(list2["y"]);
const int N=X.rows(), p=X.cols(), q=Z.cols(), r=p+q, s=p+r;
// parameters
List list1(arg1),
beta_info=list1["beta"],
Tprec_info=list1["Tprec"],
mu_info=list1["mu"],
theta_info=list1["theta"];
// prior parameters
List beta_prior=beta_info["prior"],
Tprec_prior=Tprec_info["prior"],
mu_prior=mu_info["prior"],
theta_prior=theta_info["prior"];
const double Tprec_prior_nu=as<double>(Tprec_prior["nu"]);
const Matrix2d Tprec_prior_Psi=as< Map<MatrixXd> >(Tprec_prior["Psi"]);
const double beta_prior_mean=as<double>(beta_prior["mean"]);
const double beta_prior_prec=as<double>(beta_prior["prec"]);
const Vector2d mu_prior_mean=as< Map<VectorXd> >(mu_prior["mean"]);
const Matrix2d mu_prior_prec=as< Map<MatrixXd> >(mu_prior["prec"]);
const VectorXd theta_prior_mean=as< Map<VectorXd> >(theta_prior["mean"]);
const MatrixXd theta_prior_prec=as< Map<MatrixXd> >(theta_prior["prec"]);
// initialize parameters
double beta=as<double>(beta_info["init"]);
Matrix2d Tprec=as< Map<MatrixXd> >(Tprec_info["init"]);
Vector2d mu =as< Map<VectorXd> >(mu_info["init"]);
VectorXd theta=as< Map<VectorXd> >(theta_info["init"]);
// Gibbs
List list3(arg3); //, save=list3["save"];
const int burnin=as<int>(list3["burnin"]), M=as<int>(list3["M"]),
thin=as<int>(list3["thin"]), m=7+s;
MatrixXd GS(M, m);
// prior parameter intermediate values
double beta_prior_prod=beta_prior_prec * beta_prior_mean;
VectorXd theta_prior_prod=theta_prior_prec * theta_prior_mean;
Vector2d mu_prior_prod=mu_prior_prec*mu_prior_mean;
// parameter intermediate values
Matrix2d Sigma, B_inverse;
Sigma=Tprec.inverse();
B_inverse.setIdentity();
VectorXd gamma=theta.segment(0, p),
delta=theta.segment(p, q),
eta =theta.segment(r, p);
/*
MatrixXd Theta(2, r);
Theta.row(0)=theta.segment(0, r);
Theta.bottomLeftCorner(1, q)=RowVectorXd::Zero(q);
Theta.bottomRightCorner(1, p)=eta.transpose();
*/
Vector2d eps, eps_sum;
MatrixXd D(N, 2), theta_cond_var_root(s, s), W(2, s);
W.setZero();
MatrixXd theta_cond_prec(s, s);
VectorXd theta_cond_prod(s), w(r);
Matrix2d mu_cond_prec, mu_cond_var_root, E;
Vector2d u, R, mu_cond_prod, mu_u;
double beta_scale, beta_prec, beta_prod, beta_cond_var, beta_cond_mean;
int h=0, i, l;
// Gibbs loop
//for(int l=-burnin; l<=(M-1)*thin; ++l) {
l=-burnin;
do{
// sample beta
D.col(0).setConstant(-mu[0]);
D.col(1).setConstant(-mu[1]);
D.col(0) += (t - X*gamma - Z*delta);
D.col(1) += (y - X*eta);
beta_scale=1./(Sigma(0, 0)*t.dot(t));
beta_prec=1./(beta_scale*Sigma.determinant());
beta_prod=beta_prec*beta_scale
*((Sigma(0, 0)*D.col(1)-Sigma(0, 1)*D.col(0)).array()*t.array()).sum();
beta_cond_var=1./(beta_prec+beta_prior_prec);
beta_cond_mean=beta_cond_var*(beta_prod+beta_prior_prod);
beta=rnorm1d(beta_cond_mean, sqrt(beta_cond_var));
B_inverse(1, 0)=-beta;
// sample theta
theta_cond_prec=theta_prior_prec;
theta_cond_prod=theta_prior_prod;
for(i=0; i<N; ++i) {
/*
W.topLeftCorner(1, p)=X.row(i);
W.block(0, p, 1, q)=Z.row(i);
W.bottomRightCorner(1, p)=X.row(i);
*/
W.block(0, 0, 1, p)=X.row(i);
W.block(0, p, 1, q)=Z.row(i);
W.block(1, r, 1, p)=X.row(i);
theta_cond_prec += (W.transpose() * Tprec * W);
u[0]=t[i];
u[1]=y[i];
R=B_inverse*u-mu;
theta_cond_prod += (W.transpose() * Tprec * R);
}
theta_cond_var_root=inv_root_chol(theta_cond_prec);
// theta_cond_var_root=inv_root_svd(theta_cond_prec); // for validation only
theta=theta_cond_var_root*(rnormXd(s)+theta_cond_var_root.transpose()*theta_cond_prod);
gamma=theta.segment(0, p);
delta=theta.segment(p, q);
eta =theta.segment(r, p);
/*
Theta.topRows(1)=theta.segment(0, r).transpose();
Theta.bottomRightCorner(1, p)=eta.transpose();
*/
// sample mu
eps_sum.setZero();
//W.setZero();
E.setZero();
for(i=0; i<N; ++i) {
/*
W.topLeftCorner(1, p)=X.row(i);
W.block(0, p, 1, q)=Z.row(i);
W.bottomRightCorner(1, p)=X.row(i);
*/
W.block(0, 0, 1, p)=X.row(i);
W.block(0, p, 1, q)=Z.row(i);
W.block(1, r, 1, p)=X.row(i);
/*
w.segment(0, q)=Z.row(i);
w.segment(q, p)=X.row(i);
*/
u[0]=t[i];
u[1]=y[i];
//eps += B_inverse*u - Theta*w;
eps = B_inverse*u - W*theta;
eps_sum += eps;
eps -= mu;
E += eps*eps.transpose();
}
mu_cond_prod=Tprec*eps_sum+mu_prior_prod;
mu_cond_prec=(N*Tprec+mu_prior_prec);
mu_cond_var_root=inv_root_chol(mu_cond_prec);
// mu_cond_var_root=inv_root_svd(mu_cond_prec); // for validation only
mu=mu_cond_var_root*(rnormXd(2)+mu_cond_var_root.transpose()*mu_cond_prod);
// sample Tprec
Tprec = rwishart((E+Tprec_prior_Psi).inverse(), N+Tprec_prior_nu);
Sigma = Tprec.inverse();
if(l>=0 && l%thin == 0) {
h = (l/thin);
GS.block(h, 0, 1, s)=theta.transpose();
GS(h, s)=beta;
GS(h, s+1)=mu[0];
GS(h, s+2)=mu[1];
GS(h, s+3)=Tprec(0, 0);
GS(h, s+4)=Tprec(0, 1);
GS(h, s+5)=Tprec(0, 1);
GS(h, s+6)=Tprec(1, 1);
}
l++;
} while (l<=(M-1)*thin && beta==beta);
if(beta != beta) GS.conservativeResize(h+1, m);
return wrap(GS);
}
void compile_OMP_directive(expr x)
{
expr dir;
expr c = NULL;
expv pclause,dclause;
if(x == NULL) return; /* error */
if (debug_flag) {
fprintf(stderr, "OMP_directive:\n");
expv_output(x, stderr);
fprintf(stderr, "\n");
}
check_for_OMP_pragma(x);
check_for_XMP_pragma(-1, x);
if(OMP_do_required){
error("OpenMP DO directived must be followed by do statement");
OMP_do_required = FALSE;
return;
}
if(OMP_st_required != OMP_ST_NONE){
error("OpenMP ATOMIC directives must be followed by assignment");
return;
}
dir = EXPR_ARG1(x);
if (EXPR_INT(dir) == OMP_F_THREADPRIVATE) {
check_INDCL();
} else {
check_INEXEC();
}
if (EXPR_INT(dir) != OMP_F_END_DO &&
EXPR_INT(dir) != OMP_F_END_PARALLEL_DO &&
EXPR_INT(dir) != OMP_F_ATOMIC) {
check_for_OMP_pragma(NULL); /* close DO directives if any */
}
switch(EXPR_INT(dir)){
case OMP_F_PARALLEL:
push_ctl(CTL_OMP);
compile_OMP_pragma_clause(EXPR_ARG2(x),OMP_PARALLEL,TRUE,
&pclause,&dclause);
CTL_OMP_ARG(ctl_top) = list3(LIST,dir,pclause,dclause);
EXPR_LINE(CTL_OMP_ARG(ctl_top)) = current_line;
return;
case OMP_F_END_PARALLEL:
if(CTL_TYPE(ctl_top) == CTL_OMP &&
CTL_OMP_ARG_DIR(ctl_top) == OMP_F_PARALLEL){
CTL_BLOCK(ctl_top) =
OMP_pragma_list(OMP_PARALLEL,CTL_OMP_ARG_PCLAUSE(ctl_top),
CURRENT_STATEMENTS);
EXPR_LINE(CTL_BLOCK(ctl_top)) = EXPR_LINE(CTL_OMP_ARG(ctl_top));
pop_ctl();
} else error("OpenMP PARALLEL block is not closed");
return;
case OMP_F_PARALLEL_DO:
push_ctl(CTL_OMP);
compile_OMP_pragma_clause(EXPR_ARG2(x),OMP_FOR,TRUE,
&pclause,&dclause);
CTL_OMP_ARG(ctl_top) = list3(LIST,dir,pclause,dclause);
EXPR_LINE(CTL_OMP_ARG(ctl_top)) = current_line;
OMP_do_required = TRUE;
return;
case OMP_F_END_PARALLEL_DO:
/* if(CTL_TYPE(ctl_top) == CTL_OMP && */
/* CTL_OMP_ARG_DIR(ctl_top) == OMP_F_PARALLEL_DO){ */
/* CTL_BLOCK(ctl_top) = */
/* OMP_pragma_list(OMP_PARALLEL,CTL_OMP_ARG_PCLAUSE(ctl_top), */
/* OMP_FOR_pragma_list( */
/* CTL_OMP_ARG_DCLAUSE(ctl_top), */
/* CURRENT_STATEMENTS)); */
/* EXPR_LINE(CTL_BLOCK(ctl_top)) = EXPR_LINE(CTL_OMP_ARG(ctl_top)); */
/* pop_ctl(); */
/* } else error("OpenMP PARALLEL DO block is not closed"); */
return;
case OMP_F_DO:
push_ctl(CTL_OMP);
compile_OMP_pragma_clause(EXPR_ARG2(x),OMP_FOR,FALSE,
&pclause,&dclause);
CTL_OMP_ARG(ctl_top) = list3(LIST,dir,pclause,dclause);
EXPR_LINE(CTL_OMP_ARG(ctl_top)) = current_line;
OMP_do_required = TRUE;
return;
case OMP_F_END_DO:
/* OMP_F_DO has been already closed at F_ENDDO */
/* Here, only the nowait clause is handled. */
if (ctl_top_saved){
dclause = CTL_OMP_ARG_DCLAUSE(ctl_top_saved);
if (EXPR_ARG2(x) != NULL) list_put_last(dclause, EXPR_ARG2(x));
CTL_BLOCK(ctl_top_saved) = OMP_FOR_pragma_list(dclause, CURRENT_STATEMENTS_saved);
EXPR_LINE(CTL_BLOCK(ctl_top_saved)) = EXPR_LINE(CTL_OMP_ARG(ctl_top_saved));
ctl_top_saved = NULL;
}
/* if(CTL_TYPE(ctl_top) == CTL_OMP && */
/* CTL_OMP_ARG_DIR(ctl_top) == OMP_F_DO){ */
/* dclause = CTL_OMP_ARG_DCLAUSE(ctl_top); */
/* if(EXPR_ARG2(x) != NULL) list_put_last(dclause,EXPR_ARG2(x)); */
/* CTL_BLOCK(ctl_top) = */
/* OMP_FOR_pragma_list(dclause,CURRENT_STATEMENTS); */
/* EXPR_LINE(CTL_BLOCK(ctl_top)) = EXPR_LINE(CTL_OMP_ARG(ctl_top)); */
/* pop_ctl(); */
/* } else error("OpenMP DO block is not closed"); */
return;
case OMP_F_PARALLEL_SECTIONS:
push_ctl(CTL_OMP);
compile_OMP_pragma_clause(EXPR_ARG2(x),OMP_SECTIONS,TRUE,
&pclause,&dclause);
CTL_OMP_ARG(ctl_top) = list3(LIST,dir,pclause,dclause);
EXPR_LINE(CTL_OMP_ARG(ctl_top)) = current_line;
return;
case OMP_F_END_PARALLEL_SECTIONS:
if(CTL_TYPE(ctl_top) == CTL_OMP &&
CTL_OMP_ARG_DIR(ctl_top) == OMP_F_PARALLEL_SECTIONS){
CURRENT_STATEMENTS = OMP_check_SECTION(CURRENT_STATEMENTS);
CTL_BLOCK(ctl_top) =
OMP_pragma_list(OMP_PARALLEL,CTL_OMP_ARG_PCLAUSE(ctl_top),
OMP_pragma_list(OMP_SECTIONS,
CTL_OMP_ARG_DCLAUSE(ctl_top),
CURRENT_STATEMENTS));
EXPR_LINE(CTL_BLOCK(ctl_top)) = EXPR_LINE(CTL_OMP_ARG(ctl_top));
pop_ctl();
} else error("OpenMP PARALLEL SECTIONS block is not closed");
return;
case OMP_F_SECTIONS:
push_ctl(CTL_OMP);
compile_OMP_pragma_clause(EXPR_ARG2(x),OMP_SECTIONS,FALSE,
&pclause,&dclause);
CTL_OMP_ARG(ctl_top) = list3(LIST,dir,pclause,dclause);
EXPR_LINE(CTL_OMP_ARG(ctl_top)) = current_line;
return;
case OMP_F_END_SECTIONS:
if(CTL_TYPE(ctl_top) == CTL_OMP &&
CTL_OMP_ARG_DIR(ctl_top) == OMP_F_SECTIONS){
CURRENT_STATEMENTS = OMP_check_SECTION(CURRENT_STATEMENTS);
dclause = CTL_OMP_ARG_DCLAUSE(ctl_top);
if(EXPR_ARG2(x) != NULL) list_put_last(dclause,EXPR_ARG2(x));
CTL_BLOCK(ctl_top) =
OMP_pragma_list(OMP_SECTIONS,dclause,CURRENT_STATEMENTS);
EXPR_LINE(CTL_BLOCK(ctl_top)) = EXPR_LINE(CTL_OMP_ARG(ctl_top));
pop_ctl();
} else error("OpenMP SECTIONS block is not closed");
return;
case OMP_F_SECTION:
if(CTL_TYPE(ctl_top) == CTL_OMP &&
(CTL_OMP_ARG_DIR(ctl_top) == OMP_F_SECTIONS ||
CTL_OMP_ARG_DIR(ctl_top) == OMP_F_PARALLEL_SECTIONS)){
output_statement(OMP_pragma_list(OMP_SECTION,NULL,NULL));
} else error("OpenMP SECTION appears outside SECTOINS");
return;
case OMP_F_SINGLE:
push_ctl(CTL_OMP);
compile_OMP_pragma_clause(EXPR_ARG2(x),OMP_SINGLE,FALSE,
&pclause,&dclause);
CTL_OMP_ARG(ctl_top) = list3(LIST,dir,pclause,dclause);
EXPR_LINE(CTL_OMP_ARG(ctl_top)) = current_line;
return;
case OMP_F_END_SINGLE:
if(CTL_TYPE(ctl_top) == CTL_OMP &&
CTL_OMP_ARG_DIR(ctl_top) == OMP_F_SINGLE){
dclause = CTL_OMP_ARG_DCLAUSE(ctl_top);
//if(EXPR_ARG2(x) != NULL) list_put_last(dclause,EXPR_ARG2(x));
if (EXPR_ARG2(x) != NULL){
list lp;
FOR_ITEMS_IN_LIST(lp, EXPR_ARG2(x)){
list_put_last(dclause, LIST_ITEM(lp));
}
}
virtual Value type_of() const
{
return list3(S_array, _element_type, dimensions());
}
int
handle_file_notifications (struct input_event *hold_quit)
{
BYTE *p = file_notifications;
FILE_NOTIFY_INFORMATION *fni = (PFILE_NOTIFY_INFORMATION)p;
const DWORD min_size
= offsetof (FILE_NOTIFY_INFORMATION, FileName) + sizeof(wchar_t);
struct input_event inev;
int nevents = 0;
/* We cannot process notification before Emacs is fully initialized,
since we need the UTF-16LE coding-system to be set up. */
if (!initialized)
{
notification_buffer_in_use = 0;
return nevents;
}
enter_crit ();
if (notification_buffer_in_use)
{
DWORD info_size = notifications_size;
Lisp_Object cs = Qutf_16le;
Lisp_Object obj = w32_get_watch_object (notifications_desc);
/* notifications_size could be zero when the buffer of
notifications overflowed on the OS level, or when the
directory being watched was itself deleted. Do nothing in
that case. */
if (info_size
&& !NILP (obj) && CONSP (obj))
{
Lisp_Object callback = XCDR (obj);
EVENT_INIT (inev);
while (info_size >= min_size)
{
Lisp_Object utf_16_fn
= make_unibyte_string ((char *)fni->FileName,
fni->FileNameLength);
/* Note: mule-conf is preloaded, so utf-16le must
already be defined at this point. */
Lisp_Object fname
= code_convert_string_norecord (utf_16_fn, cs, 0);
Lisp_Object action = lispy_file_action (fni->Action);
inev.kind = FILE_NOTIFY_EVENT;
inev.timestamp = GetTickCount ();
inev.modifiers = 0;
inev.frame_or_window = callback;
inev.arg = Fcons (action, fname);
inev.arg = list3 (make_pointer_integer (notifications_desc),
action, fname);
kbd_buffer_store_event_hold (&inev, hold_quit);
nevents++;
if (!fni->NextEntryOffset)
break;
p += fni->NextEntryOffset;
fni = (PFILE_NOTIFY_INFORMATION)p;
info_size -= fni->NextEntryOffset;
}
}
notification_buffer_in_use = 0;
}
leave_crit ();
return nevents;
}
