int
scheme_proper_list_length (Scheme_Object *list)
{
int len;
Scheme_Object *turtle;
len = 0;
turtle = list;
while (SCHEME_PAIRP(list)) {
len++;
list = SCHEME_CDR(list);
if (!SCHEME_PAIRP(list))
break;
len++;
list = SCHEME_CDR(list);
if (SAME_OBJ(turtle, list))
break;
turtle = SCHEME_CDR(turtle);
}
if (SCHEME_NULLP(list))
return len;
return -1;
}
static Scheme_Object *
list_p_prim (int argc, Scheme_Object *argv[])
{
Scheme_Object *obj1, *obj2;
obj1 = obj2 = argv[0];
do {
if (SCHEME_NULLP(obj1))
return scheme_true;
if (!SCHEME_PAIRP(obj1))
return (scheme_false);
obj1 = SCHEME_CDR (obj1);
if (SCHEME_NULLP(obj1))
return scheme_true;
if (!SCHEME_PAIRP(obj1))
return scheme_false;
obj1 = SCHEME_CDR(obj1);
obj2 = SCHEME_CDR(obj2);
} while (NOT_SAME_OBJ(obj1, obj2));
return scheme_false;
}
static Scheme_Object *read_quote_syntax(Scheme_Object *obj)
{
Scheme_Quote_Syntax *qs;
Scheme_Object *a;
int c, i, p;
if (!SCHEME_PAIRP(obj)) return NULL;
a = SCHEME_CAR(obj);
c = SCHEME_INT_VAL(a);
obj = SCHEME_CDR(obj);
if (!SCHEME_PAIRP(obj)) return NULL;
a = SCHEME_CAR(obj);
i = SCHEME_INT_VAL(a);
a = SCHEME_CDR(obj);
p = SCHEME_INT_VAL(a);
qs = MALLOC_ONE_TAGGED(Scheme_Quote_Syntax);
qs->so.type = scheme_quote_syntax_type;
qs->depth = c;
qs->position = i;
qs->midpoint = p;
return (Scheme_Object *)qs;
}
static Scheme_Object *read_letrec(Scheme_Object *obj)
{
Scheme_Letrec *lr;
int i, c;
Scheme_Object **sa;
lr = MALLOC_ONE_TAGGED(Scheme_Letrec);
lr->so.type = scheme_letrec_type;
if (!SCHEME_PAIRP(obj)) return NULL;
c = lr->count = SCHEME_INT_VAL(SCHEME_CAR(obj));
obj = SCHEME_CDR(obj);
if (!SCHEME_PAIRP(obj)) return NULL;
lr->body = SCHEME_CAR(obj);
obj = SCHEME_CDR(obj);
sa = MALLOC_N(Scheme_Object*, c);
lr->procs = sa;
for (i = 0; i < c; i++) {
if (!SCHEME_PAIRP(obj)) return NULL;
lr->procs[i] = SCHEME_CAR(obj);
obj = SCHEME_CDR(obj);
}
return (Scheme_Object *)lr;
}
static Scheme_Object *make_immutable_hash_table(int argc, Scheme_Object *argv[])
{
Scheme_Object *l = argv[0], *a;
Scheme_Hash_Table *ht;
if (scheme_proper_list_length(l) >= 0) {
for (; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) {
a = SCHEME_CAR(l);
if (!SCHEME_PAIRP(a))
break;
}
}
if (!SCHEME_NULLP(l))
scheme_wrong_type("make-immutable-hash-table", "list of pairs", 0, argc, argv);
if (argc > 1) {
if (!SAME_OBJ(equal_symbol, argv[1]))
scheme_wrong_type("make-immutable-hash-table", "'equal", 1, argc, argv);
ht = scheme_make_hash_table_equal();
} else
ht = scheme_make_hash_table(SCHEME_hash_ptr);
for (l = argv[0]; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) {
a = SCHEME_CAR(l);
scheme_hash_set(ht, SCHEME_CAR(a), SCHEME_CDR(a));
}
SCHEME_SET_IMMUTABLE((Scheme_Object *)ht);
return (Scheme_Object *)ht;
}
static Scheme_Object *read_top(Scheme_Object *obj)
{
Scheme_Compilation_Top *top;
top = MALLOC_ONE_TAGGED(Scheme_Compilation_Top);
top->so.type = scheme_compilation_top_type;
if (!SCHEME_PAIRP(obj)) return NULL;
top->max_let_depth = SCHEME_INT_VAL(SCHEME_CAR(obj));
obj = SCHEME_CDR(obj);
if (!SCHEME_PAIRP(obj)) return NULL;
top->prefix = (Resolve_Prefix *)SCHEME_CAR(obj);
top->code = SCHEME_CDR(obj);
return (Scheme_Object *)top;
}
static Scheme_Object *read_with_cont_mark(Scheme_Object *obj)
{
Scheme_With_Continuation_Mark *wcm;
if (!SCHEME_PAIRP(obj) || !SCHEME_PAIRP(SCHEME_CDR(obj)))
return NULL; /* bad .zo */
wcm = MALLOC_ONE_TAGGED(Scheme_With_Continuation_Mark);
wcm->so.type = scheme_with_cont_mark_type;
wcm->key = SCHEME_CAR(obj);
wcm->val = SCHEME_CADR(obj);
wcm->body = SCHEME_CDR(SCHEME_CDR(obj));
return (Scheme_Object *)wcm;
}
static Scheme_Object *
scheme_append_bang (Scheme_Object *lst1, Scheme_Object *lst2)
{
if (SCHEME_NULLP(lst1))
return lst2;
else {
Scheme_Object *prev, *orig;
orig = lst1;
do {
prev = lst1;
if (!SCHEME_PAIRP(lst1))
scheme_wrong_type("append!", "proper list", -1, 0, &lst1);
lst1 = SCHEME_CDR(lst1);
SCHEME_USE_FUEL(1);
} while (!SCHEME_NULLP(lst1));
if (!SCHEME_MUTABLE_PAIRP(prev))
scheme_wrong_type("append!", "mutable proper list", -1, 0, &lst1);
SCHEME_CDR(prev) = lst2;
return orig;
}
}
Scheme_Object *
scheme_append (Scheme_Object *lst1, Scheme_Object *lst2)
{
Scheme_Object *first, *last, *orig1, *v;
orig1 = lst1;
first = last = NULL;
while (SCHEME_PAIRP(lst1)) {
v = scheme_make_pair(SCHEME_CAR(lst1), scheme_null);
if (!first)
first = v;
else
SCHEME_CDR(last) = v;
last = v;
lst1 = SCHEME_CDR(lst1);
SCHEME_USE_FUEL(1);
}
if (!SCHEME_NULLP(lst1))
scheme_wrong_type("append", "proper list", -1, 0, &orig1);
if (!last)
return lst2;
SCHEME_CDR(last) = lst2;
return first;
}
static Scheme_Object *
car_prim (int argc, Scheme_Object *argv[])
{
if (!SCHEME_PAIRP(argv[0]))
scheme_wrong_type("car", "pair", 0, argc, argv);
return (SCHEME_CAR (argv[0]));
}
static Scheme_Object *read_let_void(Scheme_Object *obj)
{
Scheme_Let_Void *lv;
lv = (Scheme_Let_Void *)scheme_malloc_tagged(sizeof(Scheme_Let_Void));
lv->iso.so.type = scheme_let_void_type;
if (!SCHEME_PAIRP(obj)) return NULL;
lv->count = SCHEME_INT_VAL(SCHEME_CAR(obj));
obj = SCHEME_CDR(obj);
if (!SCHEME_PAIRP(obj)) return NULL;
SCHEME_LET_AUTOBOX(lv) = SCHEME_TRUEP(SCHEME_CAR(obj));
lv->body = SCHEME_CDR(obj);
return (Scheme_Object *)lv;
}
void scheme_make_list_immutable(Scheme_Object *l)
{
for (; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) {
if (SCHEME_MUTABLEP(l))
SCHEME_SET_IMMUTABLE(l);
}
}
static Scheme_Object *read_set_bang(Scheme_Object *obj)
{
Scheme_Set_Bang *sb;
sb = MALLOC_ONE_TAGGED(Scheme_Set_Bang);
sb->so.type = scheme_set_bang_type;
if (!SCHEME_PAIRP(obj)) return NULL;
sb->set_undef = SCHEME_TRUEP(SCHEME_CAR(obj));
obj = SCHEME_CDR(obj);
if (!SCHEME_PAIRP(obj)) return NULL;
sb->var = SCHEME_CAR(obj);
sb->val = SCHEME_CDR(obj);
return (Scheme_Object *)sb;
}
static Scheme_Object *read_case_lambda(Scheme_Object *obj)
{
Scheme_Object *s, *a;
int count, i, all_closed = 1;
Scheme_Case_Lambda *cl;
if (!SCHEME_PAIRP(obj)) return NULL;
s = SCHEME_CDR(obj);
for (count = 0; SCHEME_PAIRP(s); s = SCHEME_CDR(s)) {
count++;
}
cl = (Scheme_Case_Lambda *)
scheme_malloc_tagged(sizeof(Scheme_Case_Lambda)
+ (count - 1) * sizeof(Scheme_Object *));
cl->so.type = scheme_case_lambda_sequence_type;
cl->count = count;
cl->name = SCHEME_CAR(obj);
if (SCHEME_NULLP(cl->name))
cl->name = NULL;
s = SCHEME_CDR(obj);
for (i = 0; i < count; i++, s = SCHEME_CDR(s)) {
a = SCHEME_CAR(s);
cl->array[i] = a;
if (!SCHEME_PROCP(a)) {
if (!SAME_TYPE(SCHEME_TYPE(a), scheme_unclosed_procedure_type))
return NULL;
all_closed = 0;
}
}
if (all_closed) {
/* Empty closure: produce procedure value directly.
(We assume that this was generated by a direct write of
a case-lambda data record in print.c, and that it's not
in a CASE_LAMBDA_EXPD syntax record.) */
return scheme_case_lambda_execute((Scheme_Object *)cl);
}
return (Scheme_Object *)cl;
}
static Scheme_Object *scheme_sfs_next_saved(SFS_Info *info)
{
Scheme_Object *v;
if (!info->pass)
scheme_signal_error("internal error: wrong pass to get saved info");
if (!SCHEME_PAIRP(info->saved))
scheme_signal_error("internal error: no saved info");
v = SCHEME_CAR(info->saved);
info->saved = SCHEME_CDR(info->saved);
return v;
}
Scheme_Object *read_boxenv(Scheme_Object *o)
{
Scheme_Object *data;
if (!SCHEME_PAIRP(o)) return NULL;
data = scheme_alloc_object();
data->type = scheme_boxenv_type;
SCHEME_PTR1_VAL(data) = SCHEME_CAR(o);
SCHEME_PTR2_VAL(data) = SCHEME_CDR(o);
return data;
}
static Scheme_Object *
immutablep (int argc, Scheme_Object *argv[])
{
Scheme_Object *v = argv[0];
return ((!SCHEME_INTP(v)
&& SCHEME_IMMUTABLEP(v)
&& (SCHEME_PAIRP(v)
|| SCHEME_VECTORP(v)
|| SCHEME_BYTE_STRINGP(v)
|| SCHEME_CHAR_STRINGP(v)
|| SCHEME_BOXP(v)))
? scheme_true
: scheme_false);
}
int
scheme_list_length (Scheme_Object *list)
{
int len;
len = 0;
while (!SCHEME_NULLP(list)) {
len++;
if (SCHEME_PAIRP(list))
list = SCHEME_CDR(list);
else
list = scheme_null;
}
return len;
}
static Scheme_Object *
reverse_prim (int argc, Scheme_Object *argv[])
{
Scheme_Object *lst, *last;
last = scheme_null;
lst = argv[0];
while (!SCHEME_NULLP (lst)) {
if (!SCHEME_PAIRP(lst))
scheme_wrong_type("reverse", "proper list", 0, argc, argv);
last = scheme_make_pair (SCHEME_CAR (lst), last);
lst = SCHEME_CDR (lst);
SCHEME_USE_FUEL(1);
}
return (last);
}
/**
* Convert a Scheme list or vector to a GVariant that represents an array.
*/
static GVariant *
scheme_object_to_array (Scheme_Object *lv, gchar *type)
{
Scheme_Object *sval; // One element of the list/array
GVariant *gval; // The converted element
GVariantBuilder *builder;
// Special case: The empty list gives the empty array.
if (SCHEME_NULLP (lv))
{
// Note: For individual objects, D-Bus type signatures are acceptable
// as GVariant type strings.
builder = g_variant_builder_new ((GVariantType *) type);
if (builder == NULL)
return NULL;
return g_variant_builder_end (builder);
} // if it's null
// A list, or so we think.
if (SCHEME_PAIRP (lv))
{
builder = g_variant_builder_new ((GVariantType *) type);
if (builder == NULL)
return NULL;
// Follow the cons cells through the list
while (SCHEME_PAIRP (lv))
{
sval = SCHEME_CAR (lv);
gval = scheme_object_to_parameter (sval, type+1);
if (gval == NULL)
{
g_variant_builder_unref (builder);
return NULL;
} // if (gval == NULL)
g_variant_builder_add_value (builder, gval);
lv = SCHEME_CDR (lv);
} // while
// We've reached the end. Was it really a list?
if (! SCHEME_NULLP (lv))
{
g_variant_builder_unref (builder);
return NULL;
} // If the list does not end in null, so it's not a list.
// We've hit the null at the end of the list.
return g_variant_builder_end (builder);
} // if it's a list
// A vector
else if (SCHEME_VECTORP (lv))
{
int len = SCHEME_VEC_SIZE (lv);
int i;
LOG ("scheme_object_to_array: Handling a vector of length %d", len);
builder = g_variant_builder_new (G_VARIANT_TYPE_ARRAY);
if (builder == NULL)
return NULL;
for (i = 0; i < len; i++)
{
sval = SCHEME_VEC_ELS(lv)[i];
gval = scheme_object_to_parameter (sval, type + 1);
if (gval == NULL)
{
g_variant_builder_unref (builder);
return NULL;
} // if we could not convert the object
g_variant_builder_add_value (builder, gval);
} // for each index
return g_variant_builder_end (builder);
} // if it's a vector
// Can only convert lists and vectors.
else
return NULL;
} // scheme_object_to_array
void TpMzScheme::evalDesign(Design::Ptr d){
DesignStore::Ptr ds = Game::getGame()->getDesignStore();
if (scheme_setjmp(scheme_error_buf)) {
Logger::getLogger()->warning("MzScheme Error");
} else {
Scheme_Object* temp;
std::ostringstream formater;
formater.str("");
formater << "(define-values (struct:designType make-designType designType? designType-ref designType-set!)(make-design-type "
<< ds->getMaxPropertyId() << "))";
temp = scheme_eval_string(formater.str().c_str(), env);
temp = scheme_eval_string("(define property-designType-set! (lambda (design id val) (designType-set! design (- id 1) val)))", env);
std::set<uint32_t> propids = ds->getPropertyIds();
for(std::set<uint32_t>::iterator propit = propids.begin();
propit != propids.end(); ++propit){
// for each property type
Property::Ptr p = ds->getProperty(*propit);
if(p){
formater.str("");
formater << "(define designType." << p->getName()
<< " (make-property-accessor designType-ref "
<< p->getPropertyId() << " \"" << p->getName()
<< "\" ))";
temp = scheme_eval_string(formater.str().c_str(), env);
}
}
propids.clear();
IdMap complist = d->getComponents();
temp = scheme_eval_string("(define design (make-designType))", env);
for(std::set<uint32_t>::iterator propit = propids.begin();
propit != propids.end(); ++propit){
formater.str("");
formater << "(property-designType-set! design "
<< *propit << " 0.0)";
temp = scheme_eval_string(formater.str().c_str(), env);
}
std::map<uint32_t, std::map<uint32_t, std::list<std::string> > > propranking;
for(IdMap::iterator compit = complist.begin();
compit != complist.end(); ++compit){
Component::Ptr c = ds->getComponent(compit->first);
std::map<uint32_t, std::string> pilist = c->getPropertyList();
for(std::map<uint32_t, std::string>::iterator piit = pilist.begin();
piit != pilist.end(); ++piit){
Property::Ptr p = ds->getProperty(piit->first);
for(uint32_t i = 0; i < compit->second; i++){
propranking[p->getRank()][p->getPropertyId()].push_back(piit->second);
}
}
}
std::map<uint32_t, PropertyValue> propertyvalues;
for(std::map<uint32_t, std::map<uint32_t, std::list<std::string> > >::iterator rpiit = propranking.begin();
rpiit != propranking.end(); ++rpiit){
std::map<uint32_t, std::list<std::string> > pilist = rpiit->second;
std::set<PropertyValue> localvalues;
for(std::map<uint32_t, std::list<std::string> >::iterator piit = pilist.begin();
piit != pilist.end(); ++piit){
PropertyValue propval(piit->first,0.0);
std::list<double> listvals;
std::list<std::string> lambdas = piit->second;
for(std::list<std::string>::iterator itlamb = lambdas.begin();
itlamb != lambdas.end(); ++itlamb){
temp = scheme_eval_string((std::string("(") + (*itlamb) + " design)").c_str(), env);
if(!SCHEME_NUMBERP(temp)){
Logger::getLogger()->warning("MzScheme: Return not a number");
}else{
listvals.push_back(scheme_real_to_double(temp));
}
}
Property::Ptr p = ds->getProperty(piit->first);
formater.str("");
formater << "(" << p->getTpclDisplayFunction() << " design '(";
for(std::list<double>::iterator itvals = listvals.begin();
itvals != listvals.end(); ++itvals){
formater << *itvals << " ";
}
formater << "))";
temp = scheme_eval_string(formater.str().c_str(), env);
#ifdef HAVE_MZSCHEME20X
if(!SCHEME_PAIRP(temp) || !SCHEME_NUMBERP(SCHEME_CAR(temp)) || !SCHEME_STRINGP(SCHEME_CDR(temp))){
#else
if(!SCHEME_PAIRP(temp) || !SCHEME_NUMBERP(SCHEME_CAR(temp)) || !SCHEME_CHAR_STRINGP(SCHEME_CDR(temp))){
#endif
Logger::getLogger()->warning("MzScheme: Return not a pair, or the wrong time in the pair");
}else{
propval.setValue(scheme_real_to_double(SCHEME_CAR(temp)));
#ifdef HAVE_MZSCHEME20X
propval.setDisplayString(std::string(SCHEME_STR_VAL(SCHEME_CDR(temp))));
#else
propval.setDisplayString(std::string((char*)SCHEME_CHAR_STR_VAL(SCHEME_CDR(temp))));
#endif
localvalues.insert(propval);
}
}
for(std::set<PropertyValue>::iterator pvit = localvalues.begin();
pvit != localvalues.end(); ++pvit){
PropertyValue pv = *pvit;
formater.str("");
formater << "(property-designType-set! design "
<< pv.getPropertyId() << " " << pv.getValue()
<< ")";
temp = scheme_eval_string(formater.str().c_str(), env);
propertyvalues[pv.getPropertyId()] = pv;
}
}
d->setPropertyValues(propertyvalues);
// now check if the design is valid
bool valid = true;
std::string feedback = "";
Logger::getLogger()->debug("About to process requirement functions");
for(IdMap::iterator compit = complist.begin();
compit != complist.end();
++compit){
uint32_t curval = compit->first;
//for each component in the design
temp = scheme_eval_string((std::string("(") + ds->getComponent(curval)->getTpclRequirementsFunction() + " design)").c_str(), env);
#ifdef HAVE_MZSCHEME20X
if(!SCHEME_PAIRP(temp) || !SCHEME_STRINGP(SCHEME_CDR(temp))){
#else
if(!SCHEME_PAIRP(temp) || !SCHEME_CHAR_STRINGP(SCHEME_CDR(temp))){
#endif
Logger::getLogger()->warning("MzScheme: (a) Return not a pair, or the wrong time in the pair");
}else{
valid &= SCHEME_TRUEP(SCHEME_CAR(temp));
#ifdef HAVE_MZSCHEME20X
std::string strtemp = SCHEME_STR_VAL(SCHEME_CDR(temp));
#else
std::string strtemp = (char*)SCHEME_CHAR_STR_VAL(SCHEME_CDR(temp));
#endif
if(strtemp.length() > 0)
feedback += strtemp + " ";
}
}
for(std::map<uint32_t, std::map<uint32_t, std::list<std::string> > >::iterator rpiit = propranking.begin();
rpiit != propranking.end(); ++rpiit){
std::map<uint32_t, std::list<std::string> > pilist = rpiit->second;
for(std::map<uint32_t, std::list<std::string> >::iterator piit = pilist.begin();
piit != pilist.end(); ++piit){
temp = scheme_eval_string((std::string("(") + ds->getProperty(piit->first)->getTpclRequirementsFunction() + " design)").c_str(), env);
#ifdef HAVE_MZSCHEME20X
if(!SCHEME_PAIRP(temp) || !SCHEME_STRINGP(SCHEME_CDR(temp))){
#else
if(!SCHEME_PAIRP(temp) || !SCHEME_CHAR_STRINGP(SCHEME_CDR(temp))){
#endif
Logger::getLogger()->warning("MzScheme: (a) Return not a pair, or the wrong time in the pair");
}else{
valid &= SCHEME_TRUEP(SCHEME_CAR(temp));
#ifdef HAVE_MZSCHEME20X
std::string strtemp = SCHEME_STR_VAL(SCHEME_CDR(temp));
#else
std::string strtemp = (char*)SCHEME_CHAR_STR_VAL(SCHEME_CDR(temp));
#endif
if(strtemp.length() > 0)
feedback += strtemp + " ";
}
}
}
propranking.clear();
d->setValid(valid, feedback);
Logger::getLogger()->debug("Eval'ed design");
if(!valid){
Logger::getLogger()->debug("Design %s is not valid, reason: %s", d->getName().c_str(), feedback.c_str());
}
}
}
TpMzScheme::TpMzScheme(){
//scheme_set_stack_base(NULL, 1); /* required for OS X, only. WILL NOT WORK HERE */
bool loaded = false;
env = scheme_basic_env();
if (scheme_setjmp(scheme_error_buf)) {
Logger::getLogger()->warning("MzScheme warning: could not load local file, trying installed file");
} else {
scheme_eval_string("(load \"../modules/tpcl/mzscheme/designstruct.scm\")",env);
loaded = true;
}
if(loaded == false){
if (scheme_setjmp(scheme_error_buf)) {
Logger::getLogger()->warning("MzScheme warning: could not load installed file");
} else {
scheme_eval_string("(load \"" DATADIR "/tpserver/tpscheme/mzscheme/designstruct.scm\")", env);
loaded = true;
}
}
if(loaded == false){
Logger::getLogger()->error("MzScheme Error: failed to load designstruct.scm file");
//throw exception?
}
}
static Scheme_Object *sfs_closure(Scheme_Object *expr, SFS_Info *info, int self_pos)
{
Scheme_Closure_Data *data = (Scheme_Closure_Data *)expr;
Scheme_Object *code;
int i, size, has_tl = 0;
size = data->closure_size;
if (size) {
if (info->stackpos + data->closure_map[size - 1] == info->tlpos) {
has_tl = 1;
--size;
}
}
if (!info->pass) {
for (i = size; i--; ) {
scheme_sfs_used(info, data->closure_map[i]);
}
} else {
/* Check whether we need to zero out any stack positions
after capturing them in a closure: */
Scheme_Object *clears = scheme_null;
if (info->ip < info->max_nontail) {
int pos, ip;
for (i = size; i--; ) {
pos = data->closure_map[i] + info->stackpos;
if (pos < info->depth) {
ip = info->max_used[pos];
if ((ip == info->ip)
&& (ip < info->max_calls[pos])) {
pos -= info->stackpos;
clears = scheme_make_pair(scheme_make_integer(pos),
clears);
}
}
}
}
return scheme_sfs_add_clears(expr, clears, 0);
}
if (!(SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_SFS)) {
SCHEME_CLOSURE_DATA_FLAGS(data) |= CLOS_SFS;
info = scheme_new_sfs_info(data->max_let_depth);
scheme_sfs_push(info, data->closure_size + data->num_params, 1);
if (has_tl)
info->tlpos = info->stackpos + data->closure_size - 1;
if (self_pos >= 0) {
for (i = size; i--; ) {
if (data->closure_map[i] == self_pos) {
info->selfpos = info->stackpos + i;
info->selfstart = info->stackpos;
info->selflen = data->closure_size;
break;
}
}
}
code = scheme_sfs(data->code, info, data->max_let_depth);
/* If any arguments go unused, and if there's a non-tail,
non-immediate call in the body, then we flush the
unused arguments at the start of the body. We assume that
the closure values are used (otherwise they wouldn't
be in the closure). */
if (info->max_nontail) {
int i, pos, cnt;
Scheme_Object *clears = scheme_null;
cnt = data->num_params;
for (i = 0; i < cnt; i++) {
pos = data->max_let_depth - (cnt - i);
if (!info->max_used[pos]) {
pos = i + data->closure_size;
clears = scheme_make_pair(scheme_make_integer(pos),
clears);
}
}
if (SCHEME_PAIRP(clears))
code = scheme_sfs_add_clears(code, clears, 1);
if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_REST)
SCHEME_CLOSURE_DATA_FLAGS(data) |= CLOS_NEED_REST_CLEAR;
}
data->code = code;
}
return expr;
}
static Scheme_Object *sfs_lambda(Scheme_Object *expr, SFS_Info *info, int self_pos)
{
Scheme_Lambda *data = (Scheme_Lambda *)expr;
Scheme_Object *code;
int i, size, has_tl = 0;
size = data->closure_size;
if (size) {
if (info->stackpos + data->closure_map[size - 1] == info->tlpos) {
has_tl = 1;
--size;
}
}
if (!info->pass) {
for (i = size; i--; ) {
scheme_sfs_used(info, data->closure_map[i]);
}
} else {
/* Check whether we need to zero out any stack positions
after capturing them in a closure: */
Scheme_Object *clears = scheme_null;
if (info->ip < info->max_nontail) {
int pos, ip;
for (i = size; i--; ) {
pos = data->closure_map[i] + info->stackpos;
if (pos < info->depth) {
ip = info->max_used[pos];
if ((ip == info->ip)
&& (ip < info->max_calls[pos])) {
pos -= info->stackpos;
clears = scheme_make_pair(scheme_make_integer(pos),
clears);
}
}
}
}
return scheme_sfs_add_clears(expr, clears, 0);
}
if (!(SCHEME_LAMBDA_FLAGS(data) & LAMBDA_SFS)) {
SCHEME_LAMBDA_FLAGS(data) |= LAMBDA_SFS;
info = scheme_new_sfs_info(data->max_let_depth);
scheme_sfs_push(info, data->closure_size + data->num_params, 1);
if (has_tl)
info->tlpos = info->stackpos + data->closure_size - 1;
if (self_pos >= 0) {
for (i = size; i--; ) {
if (data->closure_map[i] == self_pos) {
info->selfpos = info->stackpos + i;
info->selfstart = info->stackpos;
info->selflen = data->closure_size;
break;
}
}
}
/* Never clear typed arguments or typed closure elements: */
if (SCHEME_LAMBDA_FLAGS(data) & LAMBDA_HAS_TYPED_ARGS) {
int delta, size, ct, j, pos;
mzshort *map;
delta = data->closure_size;
size = data->closure_size + data->num_params;
map = data->closure_map;
for (j = 0; j < size; j++) {
ct = scheme_boxmap_get(map, j, delta);
if (ct > LAMBDA_TYPE_TYPE_OFFSET) {
if (j < data->num_params)
pos = info->stackpos + delta + j;
else
pos = info->stackpos + (j - data->num_params);
info->max_used[pos] = FAR_VALUE_FOR_MAX_USED;
}
}
}
code = scheme_sfs(data->body, info, data->max_let_depth);
/* If any arguments go unused, and if there's a non-tail,
non-immediate call in the body, then we flush the
unused arguments at the start of the body. We assume that
the closure values are used (otherwise they wouldn't
be in the closure). */
if (info->max_nontail) {
int i, pos, cnt;
Scheme_Object *clears = scheme_null;
cnt = data->num_params;
for (i = 0; i < cnt; i++) {
pos = data->max_let_depth - (cnt - i);
if (!info->max_used[pos]) {
pos = i + data->closure_size;
clears = scheme_make_pair(scheme_make_integer(pos),
clears);
}
}
if (SCHEME_PAIRP(clears))
code = scheme_sfs_add_clears(code, clears, 1);
if (SCHEME_LAMBDA_FLAGS(data) & LAMBDA_HAS_REST)
SCHEME_LAMBDA_FLAGS(data) |= LAMBDA_NEED_REST_CLEAR;
}
data->body = code;
}
return expr;
}
static Scheme_Object *
pair_p_prim (int argc, Scheme_Object *argv[])
{
return (SCHEME_PAIRP(argv[0]) ? scheme_true : scheme_false);
}
static Scheme_Object *
do_list_ref(char *name, int takecar, int argc, Scheme_Object *argv[])
{
long i, k;
Scheme_Object *lst, *index, *bnindex;
if (SCHEME_BIGNUMP(argv[1])) {
bnindex = argv[1];
k = 0;
} else if (!SCHEME_INTP(argv[1])) {
scheme_wrong_type(name, "non-negative exact integer", 1, argc, argv);
return NULL;
} else {
bnindex = NULL;
k = SCHEME_INT_VAL(argv[1]);
}
lst = argv[0];
index = argv[1];
if ((bnindex && !SCHEME_BIGPOS(bnindex))
|| (!bnindex && (k < 0))) {
scheme_wrong_type(name, "non-negative exact integer", 1, argc, argv);
return NULL;
}
do {
if (bnindex) {
if (SCHEME_INTP(bnindex)) {
k = SCHEME_INT_VAL(bnindex);
bnindex = 0;
} else {
k = LISTREF_BIGNUM_SLICE;
bnindex = scheme_bin_minus(bnindex, scheme_make_integer(LISTREF_BIGNUM_SLICE));
}
}
for (i = 0; i < k; i++) {
if (!SCHEME_PAIRP(lst)) {
char *lstr;
int llen;
lstr = scheme_make_provided_string(argv[0], 2, &llen);
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"%s: index %s too large for list%s: %t", name,
scheme_make_provided_string(index, 2, NULL),
SCHEME_NULLP(lst) ? "" : " (not a proper list)",
lstr, llen);
return NULL;
}
lst = SCHEME_CDR(lst);
if (!(i & OCCASIONAL_CHECK))
SCHEME_USE_FUEL(OCCASIONAL_CHECK);
}
} while(bnindex);
if (takecar) {
if (!SCHEME_PAIRP(lst)) {
char *lstr;
int llen;
lstr = scheme_make_provided_string(argv[0], 2, &llen);
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"%s: index %s too large for list%s: %t", name,
scheme_make_provided_string(index, 2, NULL),
SCHEME_NULLP(lst) ? "" : " (not a proper list)",
lstr, llen);
return NULL;
}
return SCHEME_CAR(lst);
} else
return lst;
}
