// Finds the length of a cons cell
// Returns 0 if list is empty
// -1 if list is circular
// n if list's length is n
// -2-n if list's length is n and is dotted
int32_t cons_len(value_t val) {
int32_t len = 0;
// Uses Floyd's cycle finding algorithm
value_t fast, slow;
fast = slow = val;
while (true) {
if (IS_NIL(fast)) {
return len;
}
if (IS_CONS(fast) && !IS_NIL(AS_CONS(fast)->cdr) &&
!IS_CONS(AS_CONS(fast)->cdr)) {
return -2 - len;
}
fast = AS_CONS(fast)->cdr;
++len;
if (IS_NIL(fast)) {
return len;
}
if (IS_CONS(fast) && !IS_NIL(AS_CONS(fast)->cdr) &&
!IS_CONS(AS_CONS(fast)->cdr)) {
return -2 - len;
}
fast = AS_CONS(fast)->cdr;
slow = AS_CONS(slow)->cdr;
++len;
if (IS_EQ(fast, slow)) {
return -1;
}
}
}
static node_t *node_remove(tree_t *tree, node_t *p, const int key)
{
if (!IS_NIL(p)) {
int d = tree->compare(key, p->key);
if (d == 0) {
if (IS_NIL(p->left)) {
node_t *q = p->right;
node_destroy(tree, p);
return q;
} else if (IS_NIL(p->right)) {
node_t *q = p->left;
node_destroy(tree, p);
return q;
} else {
node_t *q = p;
node_t *r = node_remove_swap(tree, p->right,
&q);
p = q;
p->right = r;
}
} else if (d < 0)
p->left = node_remove(tree, p->left, key);
else
p->right = node_remove(tree, p->right, key);
p = node_rebalance(p);
}
return p;
}
/* rb_tree_rotate_right - a left rotate implementation as shown in the book */
static void rb_tree_rotate_right(rb_tree_t *tree, rb_tree_node_t *x)
{
rb_tree_node_t *y = NULL;
y = x->left;
x->left = y->right;
if (!IS_NIL(tree, y->right)) {
y->right->parent = x;
}
y->parent = x->parent;
if (IS_NIL(tree, x->parent)) {
tree->head = y;
} else {
if (x == x->parent->right) {
x->parent->right = y;
} else {
x->parent->left = y;
}
}
y->right = x;
x->parent = y;
}
mst_Boolean
check_against_policy (OOP policyOOP,
OOP ownerOOP,
OOP nameOOP,
OOP targetOOP,
OOP actionOOP)
{
gst_security_policy policy;
OOP *first, *last;
OOP ocOOP;
mst_Boolean result;
if (IS_NIL (policyOOP))
return (true);
policy = (gst_security_policy) OOP_TO_OBJ (policyOOP);
ocOOP = dictionary_at (policy->dictionary, nameOOP);
result = !IS_OOP_UNTRUSTED (ownerOOP);
if (IS_NIL (ocOOP))
return result;
first = ordered_collection_begin (ocOOP);
last = ordered_collection_end (ocOOP);
for (; first < last; first++)
if (check_against_permission (*first, nameOOP, targetOOP, actionOOP))
result = permission_is_allowing (*first);
return result;
}
bool rb_tree_insert(rb_tree_t *tree, void *key, bool *exists)
{
rb_tree_node_t *x = NULL;
rb_tree_node_t *y = NULL;
rb_tree_node_t *z = NULL;
*exists = false;
/* First, search for the key. If it is present, all we need to do is to increase its count. */
x = rb_tree_search_from(tree, tree->head, key);
if (NULL != x) {
*exists = true;
x->count += 1;
return true;
}
/* If the key doesn't exist, we need to allocate a new node for the key, and actually insert it */
z = (rb_tree_node_t *) calloc(sizeof(rb_tree_node_t), 1);
if (NULL == z) {
return false;
}
z->key = key;
z->count = 1;
y = &(tree->nil);
x = tree->head;
while (!IS_NIL(tree, x)) {
y = x;
/* z->key < x->key */
if (tree->key_cmp(z->key, x->key) < 0) {
x = x->left;
} else {
x = x->right;
}
}
z->parent = y;
if (IS_NIL(tree, y)) {
tree->head = z;
} else {
/* z->key < y->key */
if (tree->key_cmp(z->key, y->key) < 0) {
y->left = z;
} else {
y->right = z;
}
}
z->left = &(tree->nil);
z->right = &(tree->nil);
z->color = RED;
rb_tree_insert_fixup(tree, z);
/* In this case, a unique key is add to the tree */
tree->count++;
tree->max = rb_tree_find_max(tree);
return true;
}
void printlist(int addr){
if(IS_NIL(addr))
printf(")");
else {
print(GET_CAR(addr));
if(! (IS_NIL(GET_CDR(addr))))
printf(" ");
printlist(GET_CDR(addr));
}
}
rb_tree_node_t* rb_tree_find_max(rb_tree_t *tree)
{
rb_tree_node_t *node = tree->head;
if (IS_NIL(tree, node)){
return node;
}
while (!IS_NIL(tree, node->right)){
node = node->right;
}
return node;
}
static node_t *node_put(tree_t *tree, node_t *p, node_t *child)
{
if (IS_NIL(p))
p = child;
else {
int d = tree->compare(child->key, p->key);
if (d == 0)
return NULL;
if (d < 0) {
node_t *q = node_put(tree, p->left, child);
if (!q)
return NULL;
p->left = q;
} else {
node_t *q = node_put(tree, p->right, child);
if (!q)
return NULL;
p->right = q;
}
p = node_split(node_skew(p));
}
return p;
}
const char *typeStr(Value v) {
const char *s = "?";
if (IS_NIL(v)) {
s = "nil";
} else if (IS_NUM(v)) {
s = "number";
} else if (IS_STRING(v)) {
s = "string";
} else if (IS_ARRAY(v)) {
s = "array";
} else if (IS_MAP(v)) {
s = "map";
} else if (IS_FUNC(v)) {
s = "func";
} else if (IS_CFUNC(v)) {
s = "cfunc";
} else if (IS_CF(v)) {
s = "cf";
} else if (IS_CP(v)) {
s = "cp";
} else if (IS_PROTO(v)) {
s = "proto";
} else if (IS_REG(v)) {
s = "reg";
}
return s;
}
uptr_t eval(uptr_t *env, uptr_t form) {
if (IS_INT(form) || IS_NIL(form))
return form;
if (IS_SYM(form))
return get(*env, form);
if (IS_CONS(form)) {
uptr_t *form_p = refer(form),
*fn_p = refer(eval(env, CAR(*form_p))),
rval;
if (IS_SYM(*fn_p)) {
rval = exec_special(env, *form_p);
} else if (IS_CONS(*fn_p) && SVAL(CAR(*fn_p)) == S_FN) {
rval = _fn(env, *fn_p, eval_list(env, CDR(*form_p)));
} else {
printf_P(PSTR("ERROR: "));
print_form(CAR(*form_p));
printf_P(PSTR(" cannot be in function position.\n"));
rval = NIL;
}
release(2); // form_p, fn_p
return rval;
}
return NIL;
}
static YogVal
end(YogEnv* env, YogVal self, YogVal pkg, YogVal args, YogVal kw, YogVal block)
{
SAVE_ARGS5(env, self, pkg, args, kw, block);
YogVal group = YNIL;
YogVal retval = YUNDEF;
PUSH_LOCALS2(env, group, retval);
YogCArg params[] = { { "|", NULL }, { "group", &group }, { NULL, NULL } };
YogGetArgs_parse_args(env, "end", params, args, kw);
CHECK_SELF_MATCH(env, self);
if (IS_FIXNUM(group)) {
retval = end_num(env, self, VAL2INT(group));
}
else if (IS_NIL(group)) {
retval = end_num(env, self, 0);
}
else if (IS_PTR(group) && (BASIC_OBJ_TYPE(group) == TYPE_STRING)) {
retval = end_str(env, self, group);
}
else {
raise_invalid_group(env, group);
}
RETURN(env, retval);
}
void rb_tree_in_order(rb_tree_t *tree, rb_tree_node_t *node, void (*callback)(rb_tree_t *tree, rb_tree_node_t *node))
{
if (IS_NIL(tree, node)) {
return;
}
if (!IS_NIL(tree, node->left)) {
rb_tree_in_order(tree, node->left, callback);
}
callback(tree, node);
if (!IS_NIL(tree, node->right)) {
rb_tree_in_order(tree, node->right, callback);
}
}
mst_Boolean
check_against_permission (OOP permissionOOP,
OOP nameOOP,
OOP targetOOP,
OOP actionOOP)
{
gst_permission perm = (gst_permission) OOP_TO_OBJ (permissionOOP);
gst_object actionArray = OOP_TO_OBJ (perm->actions);
if (perm->name != nameOOP)
return (false);
if (!IS_NIL (perm->target) && !IS_NIL (targetOOP))
{
mst_Boolean match_target;
match_target = (targetOOP == perm->target);
if (!match_target
&& (OOP_CLASS (targetOOP) != _gst_symbol_class
|| OOP_CLASS (perm->target) != _gst_symbol_class)
&& (OOP_CLASS (targetOOP) == _gst_string_class
|| OOP_CLASS (targetOOP) == _gst_symbol_class)
&& (OOP_CLASS (perm->target) == _gst_string_class
|| OOP_CLASS (perm->target) == _gst_symbol_class))
match_target = string_match ((char *) OOP_TO_OBJ (perm->target)->data,
(char *) OOP_TO_OBJ (targetOOP)->data,
oop_num_fields (perm->target),
oop_num_fields (targetOOP));
if (!match_target)
return (false);
}
if (!IS_NIL (perm->actions) && !IS_NIL (actionOOP))
{
int n = oop_num_fields (perm->actions);
int i;
for (i = 0; ;)
{
if (actionArray->data[i] == actionOOP)
break;
if (++i == n)
return (false);
}
}
return (true);
}
void printlist(int addr){
if(IS_NIL(addr))
printf(")");
else
if((!(listp(cdr(addr)))) && (! (nullp(cdr(addr))))){
print(car(addr));
printf(" . ");
print(cdr(addr));
printf(")");
}
else {
print(GET_CAR(addr));
if(! (IS_NIL(GET_CDR(addr))))
printf(" ");
printlist(GET_CDR(addr));
}
}
int isnumlis(int arg){
while(!(IS_NIL(arg)))
if(numberp(car(arg)))
arg = cdr(arg);
else
return(0);
return(1);
}
//nilを空リストと解釈している。
int listp(int x){
if(IS_LIST(x) && (!(improperp(x))))
return(1);
else
if(IS_NIL(x))
return(1);
else
return(0);
}
uptr_t eval_list(uptr_t *env, uptr_t list) {
if (IS_NIL(list))
return NIL;
uptr_t *list_p = refer(list), rval;
rval = build_cons(eval(env, CAR(*list_p)), eval_list(env, CDR(*list_p)));
release(1); // list_p
return rval;
}
static void rb_tree_delete(rb_tree_t *tree, rb_tree_node_t *z)
{
rb_tree_node_t *y = NULL;
rb_tree_node_t *x = NULL;
if (IS_NIL(tree, z->left) || IS_NIL(tree, z->right)) {
y = z;
} else {
y = rb_tree_successor(tree, z);
}
if (IS_NIL(tree, y->left)) {
x = y->right;
} else {
x = y->left;
}
x->parent = y->parent;
if (IS_NIL(tree, y->parent)) {
tree->head = x;
} else {
if (y == y->parent->left) {
y->parent->left = x;
} else {
y->parent->right = x;
}
}
if (y != z) {
/* z->left = y->left; */
/* z->right = y->right; */
/* z->parent = y->parent; */
/* z->color = y->color; */
z->key = y->key;
z->count = y->count;
}
if (y->color == BLACK) {
rb_tree_delete_fixup(tree, x);
}
free(y);
}
void dechunk (uclptr_t starting_chunk)
{
uclptr_t chunk, next;
for (chunk = starting_chunk; !IS_NIL(chunk); chunk = next)
{
next = _CAR(chunk);
cell_release(chunk);
}
}
static QSE_INLINE qse_rbt_walk_t walk_recursively (
rbt_t* rbt, walker_t walker, void* ctx, qse_rbt_pair_t* pair)
{
if (!IS_NIL(rbt,pair->left))
{
if (walk_recursively (rbt, walker, ctx, pair->left) == QSE_RBT_WALK_STOP)
return QSE_RBT_WALK_STOP;
}
if (walker (rbt, pair, ctx) == QSE_RBT_WALK_STOP) return QSE_RBT_WALK_STOP;
if (!IS_NIL(rbt,pair->right))
{
if (walk_recursively (rbt, walker, ctx, pair->right) == QSE_RBT_WALK_STOP)
return QSE_RBT_WALK_STOP;
}
return QSE_RBT_WALK_FORWARD;
}
void unchop (void *dstdata, int size, uclptr_t starting_chunk)
{
int i, num_of_chunks = size / sizeof(uclptr_t);
uclptr_t chunk;
uclptr_t *vdata = (uclptr_t *)dstdata;
for (i=0, chunk = starting_chunk; !IS_NIL(chunk); chunk = _CAR(chunk), i++) /* !!! */
{
uclptr_t d = _CDR(chunk);
vdata[num_of_chunks - i - 1] = d;
}
}
static naRef f_setfld(naContext c, naRef me, int argc, naRef* args)
{
naRef s = argc > 0 ? args[0] : naNil();
int bit = argc > 1 ? (int)naNumValue(args[1]).num : -1;
int len = argc > 2 ? (int)naNumValue(args[2]).num : -1;
naRef val = argc > 3 ? naNumValue(args[3]) : naNil();
if(!argc || !MUTABLE(args[0])|| bit < 0 || len < 0 || IS_NIL(val))
naRuntimeError(c, "missing/bad argument to setfld");
setfld(c, (void*)naStr_data(s), naStr_len(s), bit, len, (unsigned int)val.num);
return naNil();
}
int f_minus(int arglist){
int arg,res;
res = GET_NUMBER(car(arglist));
while(!(IS_NIL(arglist))){
arg = GET_NUMBER(car(arglist));
arglist = cdr(arglist);
res = res - arg;
}
return(makenum(res));
}
int evlis(int addr){
int car_addr,cdr_addr;
if(IS_NIL(addr))
return(addr);
else{
car_addr = eval(car(addr));
cdr_addr = evlis(cdr(addr));
return(cons(car_addr,cdr_addr));
}
}
int type_debug(unsigned int id)
{
if (IS_NIL(id))/*(id == nil.car.index)*/ { printf ("nil"); return 0; }
if (id > TYPES_TOTAL) { printf ("Unknown type 0x"PTR_FORMAT, id); return 0; }
else
{
ucltype_t* t = type(id);
printf ("%s", t->name );
}
return 1;
}
static rb_tree_node_t* rb_tree_search_smallest_node(rb_tree_t *tree, rb_tree_node_t *node, void *key)
{
rb_tree_node_t *found = NULL;
int compare = 0;
if (IS_NIL(tree, node)) {
return NULL;
}
compare = tree->key_cmp(key, node->key);
/* key == node->key */
if (compare == 0) {
return node;
}
/* key < node->key */
if (compare < 0) {
if (IS_NIL(tree, node->left)) {
return node;
}
found = rb_tree_search_smallest_node(tree, node->left, key);
/* If no smaller key than the current key was found, and the current key is greater than the
given key, return the current key.
*/
if (NULL == found) {
return node;
} else {
return found;
}
} else {
/* key > node->key */
if (IS_NIL(tree, node->right)) {
/* The searched key is too large, and there are no more nodes to search for,
so we have to return NULL */
return NULL;
}
return rb_tree_search_smallest_node(tree, node->right, key);
}
}
void bind(int lambda, int arglist){
int arg1,arg2;
EP = E;
while(!(IS_NIL(lambda))){
arg1 = car(lambda);
arg2 = car(arglist);
bindsym(arg1,arg2);
lambda = cdr(lambda);
arglist = cdr(arglist);
}
}
rb_tree_node_t* rb_tree_successor(rb_tree_t *tree, rb_tree_node_t *node)
{
rb_tree_node_t *y = NULL;
y = node->right;
if (!IS_NIL(tree, y)) {
while (!IS_NIL(tree, y->left)) {
y = y->left;
}
return IS_NIL(tree, y) ? NULL : y;
} else {
y = node->parent;
while (node == y->right) {
node = y;
y = y->parent;
}
return IS_NIL(tree, y) ? NULL : y;
}
}
void bindarg(int varlist, int arglist){
int arg1,arg2;
push(ep);
while(!(IS_NIL(varlist))){
arg1 = car(varlist);
arg2 = car(arglist);
assocsym(arg1,arg2);
varlist = cdr(varlist);
arglist = cdr(arglist);
}
}
int f_plus(int arglist){
int arg,res;
checkarg(NUMLIST_TEST, "+", arglist);
res = 0;
while(!(IS_NIL(arglist))){
arg = GET_NUMBER(car(arglist));
arglist = cdr(arglist);
res = res + arg;
}
return(makenum(res));
}