void xdap_late_write_contig_data(List *l)
{
char *a;
bap_rl_file_rec rl_line;
long index;
index = io.max_gels-cur_contig_index;
if ( (a = assoc(l,contig_left_end)) == NULL)
crash("No left end for contig %d\n", cur_contig_index);
else
rl_line.clines.left_end = atoi(a);
if ( (a = assoc(l,contig_right_end)) == NULL)
crash("No right end for contig %d\n",cur_contig_index);
else
rl_line.clines.right_end = atoi(a);
if ( (a = assoc(l,contig_length)) == NULL)
crash("No length for contig %d\n",cur_contig_index);
else
rl_line.clines.length = atoi(a);
bap_write_rl(&io,index,&rl_line);
cur_contig_index++;
}
int test_list()
{
cell *c[3];
symbol *x = new_symbol("x");
symbol *y = new_symbol("y");
symbol *z = new_symbol("z");
integer *i = new_integer(10);
integer *j = new_integer(20);
list *l;
c[0] = cons(x, i);
c[1] = cons(x, i);
c[2] = cons(y, j);
l = cons(c[0], cons(c[1], cons(c[2], NULL)));
print_sexp(c[0]);
printf("\n");
print_sexp(c[1]);
printf("\n");
print_sexp(c[2]);
printf("\n");
print_sexp(l);
printf("\n");
assert(is_list(l));
assert(is_list(NULL));
assert(!is_list(c[0]));
assert(generic_equal(assoc(x, l), c[0]));
assert(generic_equal(assoc(y, l), c[2]));
assert(generic_equal(assoc(z, l), NULL));
return 1;
}
/* Returns the value associated with name, depends on if the logo_object is
* included in the hierarchy or not.
*/
NODE *varInObjectHierarchy(NODE *name, BOOLEAN includeLogo) {
NODE *result, *parentList;
result = assoc(name, getvars(current_object));
if (result != NIL) {
return getobject(result);
}
for (parentList = parent_list(current_object);
parentList != NIL;
parentList = cdr(parentList)) {
result = assoc(name, getvars(car(parentList)));
if (result != NIL) {
return getobject(result);
}
}
if (!includeLogo) {
return (NODE *)(-1);
}
result = intern(name);
if (flag__caseobj(result, IS_LOCAL_VALUE)) {
return (NODE *)(-1);
}
return valnode__caseobj(result);
}
expression::associativity ExpressionParser::associativity(TreeNode* op1, TreeNode* op2)
{
expression::associativity assoc1 = assoc(op1);
expression::associativity assoc2 = assoc(op2);
if (assoc1 == assoc2)
return assoc1;
else
return expression::non_associative;
}
static Word v2p(Word vAddr, Bool userMode, Bool writing, int accsWidth) {
Word pAddr;
Word page, offset;
int index;
if (debugUse) {
cPrintf("**** vAddr = 0x%08X", vAddr);
}
if ((vAddr & 0x80000000) != 0 && userMode) {
/* trying to access a privileged address from user mode */
mmuBadAccs = (writing ? MMU_ACCS_WRITE : MMU_ACCS_READ) | accsWidth;
mmuBadAddr = vAddr;
throwException(EXC_PRV_ADDRESS);
}
if ((vAddr & 0xC0000000) == 0xC0000000) {
/* unmapped address space */
/* simulate delay introduced by assoc when using mapped
addresses but not experienced with unmapped addresses */
assoc(0);
pAddr = vAddr & ~0xC0000000;
} else {
/* mapped address space */
page = vAddr & PAGE_MASK;
offset = vAddr & OFFSET_MASK;
index = assoc(page);
if (index == -1) {
/* TLB miss exception */
mmuBadAccs = (writing ? MMU_ACCS_WRITE : MMU_ACCS_READ) | accsWidth;
mmuBadAddr = vAddr;
tlbEntryHi = page;
throwException(EXC_TLB_MISS);
}
if (!tlb[index].valid) {
/* TLB invalid exception */
mmuBadAccs = (writing ? MMU_ACCS_WRITE : MMU_ACCS_READ) | accsWidth;
mmuBadAddr = vAddr;
tlbEntryHi = page;
throwException(EXC_TLB_INVALID);
}
if (!tlb[index].write && writing) {
/* TLB write exception */
mmuBadAccs = (writing ? MMU_ACCS_WRITE : MMU_ACCS_READ) | accsWidth;
mmuBadAddr = vAddr;
tlbEntryHi = page;
throwException(EXC_TLB_WRITE);
}
pAddr = tlb[index].frame | offset;
}
if (debugUse) {
cPrintf(", pAddr = 0x%08X ****\n", pAddr);
}
return pAddr;
}
/* Returns the procedure associated with name.
*/
NODE *procValue(NODE *name) {
NODE *result, *parentList;
result = assoc(name, getprocs(current_object));
if (result != NIL) return getobject(result);
for (parentList = parent_list(current_object);
parentList != NIL && result == NIL;
parentList = cdr(parentList)) {
result = assoc(name, getprocs(car(parentList)));
}
if (result != NIL) return getobject(result);
result = intern(name);
return procnode__caseobj(result);
}
/*! \brief Look up \a key in \a map.
*
* \param key An atom.
* \param map A dictionary in the form created by pair().
* \return The value associated with \a key if found, \a key
* otherwise.
*/
sexp assoc(sexp key, sexp map) {
/* TRoL missing the '() case */
if (c_bool(eq(map, ATOM_NIL()))) { return key; }
/* return car(cdr(car ? */
if (c_bool(eq(car(car(map)), key))) { return cdr(car(map)); }
return assoc(key, cdr(map));
}
//===========================================================================
void MessageManager_Register(HWND hwnd, const UINT* messages, bool add)
{
UINT msg;
while (0 != (msg = *messages++))
{
struct MsgMap *mm = (struct MsgMap *)assoc(msgs, (void*)msg);
if (mm) {
if (remove_assoc(&mm->winmap, hwnd))
--mm->count;
} else if (add) {
mm = c_new(struct MsgMap);
mm->msg = msg;
append_node (&msgs, mm);
// these are the messages that expect return values and
// are handled differently in 'MessageManager_Send()'
mm->send_mode = BB_DRAGTODESKTOP == msg || BB_GETBOOL == msg;
}
if (add) {
struct winmap *w = c_new(struct winmap);
w->hwnd = hwnd;
cons_node(&mm->winmap, w);
++mm->count;
dbg_msg("add", hwnd, msg);
} else if (mm) {
if (NULL == mm->winmap)
remove_item(&msgs, mm);
dbg_msg("del", hwnd, msg);
}
}
int assoc(int sym, int lis){
if(nullp(lis))
return(0);
else if(eqp(sym, caar(lis)))
return(car(lis));
else
return(assoc(sym,cdr(lis)));
}
B assoc (A a, list<std::pair<A, B>> l) {
if (empty (l))
throw not_found ();
std::pair<A, B> p=hd (l);
if (p.first == a)
return p.second;
return assoc (a, tl (l));
}
//deep-bindによる。シンボルが見つからなかったら登録。
//見つかったらそこに値をいれておく。
void bindsym(int sym, int val){
int addr;
addr= assoc(sym,ep);
if(addr == 0)
assocsym(sym,val);
else
SET_CDR(addr,val);
}
value_t operator () (E_variable const& xpr) const {
try{
return assoc (xpr.val, *env);
}
catch (not_found const&) {
throw std::runtime_error (
"\""+xpr.val+"\" isn't bound in the environment");
}
}
void mmuTbs(void) {
int index;
index = assoc(tlbEntryHi & PAGE_MASK);
if (index == -1) {
tlbIndex = 0x80000000;
} else {
tlbIndex = index;
}
}
closure *table_lookup(closure *symbol, symbol_table *table)
{
// TODO resize array here when load too great.
int hash = symbol_hash(symbol, table);
closure *chain = table->array[hash];
if (chain == NULL)
return nil();
return assoc(symbol, chain);
}
//環境は次のように連想リストになっている。
// env = ((sym1 . val1) (sym2 . val2) ...)
// assocでシンボルに対応する値を探す。
//見つからなかった場合には-1を返す。
int findsym(int sym){
int addr;
addr = assoc(sym,ep);
if(addr == 0)
return(-1);
else
return(cdr(addr));
}
/* Returns the object which contains the name, depends on if the
* logo_object is included in the hierarchy or not.
*/
NODE *varInThisObject(NODE *name, BOOLEAN includeLogo) {
NODE *object, *result, *parentList;
result = assoc(name, getvars(current_object));
if (result != NIL) return current_object;
for (parentList = parent_list(current_object);
parentList != NIL && result == NIL;
parentList = cdr(parentList)) {
result = assoc(name, getvars(car(parentList)));
object = car(parentList);
if (result != NIL) return object;
}
if (!includeLogo) return NIL;
result = intern(name);
if (flag__caseobj(result, IS_LOCAL_VALUE)) return NIL;
return logo_object;
}
void xdap_late_open_for_read(List *l)
/*
**
*/
{
char *name;
char *version;
name = assoc(l,db_name);
if (! name) crash("No database name specified\n");
version = assoc(l,db_version);
if (! version) crash("No version specified\n");
bap_open_for_read(&io,name,version);
cur_gel_index = 1;
cur_contig_index = 1;
}
/* representation of an object */
NODE *lrepresentation(NODE *args) {
NODE *license, *binding, *classbind;
char buffer[200];
char *old_stringptr = print_stringptr;
int old_stringlen = print_stringlen;
print_stringlen = 200;
print_stringptr = buffer;
license = assoc(theName(Name_licenseplate), getvars(current_object));
ndprintf(NULL, "${Object %p", getobject(license));
binding = assoc(theName(Name_name), getvars(current_object));
if (binding != NIL && getobject(binding) != UNBOUND) {
ndprintf(NULL, ": %p", getobject(binding));
}
classbind = assoc(theName(Name_class), getvars(current_object));
if (classbind != NIL) {
if (binding == NIL || getobject(binding) == UNBOUND) {
ndprintf(NULL, ":");
}else {
ndprintf(NULL, ",");
}
ndprintf(NULL, " the class %p", getobject(classbind));
} else {
classbind = varInObjectHierarchy(theName(Name_class), FALSE);
if (classbind != UNBOUND && classbind != (NODE *)(-1)) {
if (binding == NIL) {
ndprintf(NULL, ":");
} else {
ndprintf(NULL, ",");
}
ndprintf(NULL, " a %p", classbind);
}
}
ndprintf(NULL, "}");
print_stringptr* = '\0';
print_stringptr = old_stringptr;
print_stringlen = old_stringlen;
return make_strnode(buffer, NULL, strlen(buffer), STRING, strnzcpy);
}
std::shared_ptr<Object> syntax_quote(std::shared_ptr<Object> form) {
std::shared_ptr<Object> ret = nullptr;
if (Compiler::isSpecial(form)) {
ret = std::shared_ptr<List>( new List { Compiler::QUOTE, form } );
} else if (form->instanceof(typeid(Symbol))) {
std::shared_ptr<Symbol> sym = std::dynamic_pointer_cast<Symbol>(form);
if (sym->ns == "" && sym->name.back() == '#') {
auto gmap = std::dynamic_pointer_cast<Map>(GENSYM_ENV->deref());
if (gmap == nullptr) {
throw "Gensym literal not in syntax-quote";
}
auto gs = std::dynamic_pointer_cast<Symbol>(gmap->valAt(sym));
if (gs == nullptr) {
gs = Symbol::create("", sym->name.substr(0, sym->name.size() - 1) +
"__" + std::to_string(runtime::nextId()) + "__auto__");
GENSYM_ENV->set(gmap->assoc(sym, gs));
}
sym = gs;
} else if (sym->ns == "" && sym->name.back() == '.') {
auto csym = Symbol::create("", sym->name.substr(0, sym->name.size() - 1));
csym = Compiler::resolveSymbol(csym);
sym = Symbol::create("", csym->name + ".");
} else if (sym->ns == "" && sym->name.front() == '.') {
// simply quote method names
} else {
std::shared_ptr<Object> maybeClass = nullptr;
if (sym->ns != "") {
maybeClass = Compiler::currentNS()->getMapping(Symbol::create("", sym->ns));
}
if (maybeClass != nullptr) {
if (false) {
// TODO: we have nothing to represent Class objects yet
} else {
sym = Compiler::resolveSymbol(sym);
}
}
}
ret = std::shared_ptr<List>( new List { Compiler::QUOTE, sym } );
} else if (is_unquote(form)) {
return runtime::second(form);
} else if (is_unquote_splicing(form)) {
throw "splice not in list";
} else if (false) { // TODO: instanceof IPersistentCollection
} else if (form->instanceof(typeid(Keyword)) ||
form->instanceof(typeid(Number)) ||
form->instanceof(typeid(Character)) ||
form->instanceof(typeid(String))) {
ret = form;
} else {
ret = std::dynamic_pointer_cast<Object>(runtime::list(Compiler::QUOTE, form));
}
return ret;
}
static void dbg_msg(const char *action, HWND hwnd, UINT msg)
{
char buffer[100];
struct MsgMap *mm = (struct MsgMap *)assoc(msgs, (void*)msg);
if (0 == GetClassName(hwnd, buffer, sizeof buffer))
strcpy(buffer, "(invalid)");
dbg_printf("%s: %s %s (%d/%d)",
action,
buffer,
bb_str(msg, -1, -1),
listlen(msgs), mm ? mm->count : 0
);
}
/* Outputs TRUE if Symbol is the name of a procedure owned by the current
* object, FALSE otherwise.
* @params - Symbol
*/
NODE *lmyprocp(NODE *args) {
NODE *arg;
if (current_object == logo_object)
return lprocedurep(args); /* return lprocp or just call it? */
else {
arg = name_arg(args);
if (NOT_THROWING)
return torf(assoc(arg, getprocs(current_object)) != NIL);
}
return UNBOUND;
}
void table_insert(closure *symbol, closure *value, symbol_table *table)
{
int hash = symbol_hash(symbol, table);
closure *chain = table->array[hash];
if (chain == NULL)
chain = nil();
closure *prev = assoc(symbol, chain);
if (!nilp(prev)){
prev->in->cons->car = value;
} else {
table->array[hash] = cheap_cons(cheap_list(2, symbol, value), chain);
}
table->entries++;
}
uptr_t loop(uptr_t *env, uptr_t form) {
uptr_t *bindings_p = refer(CAR(form)),
*body_p = refer(CDR(form)),
*form_p = refer(form),
*local_env = refer(*env);
while (*bindings_p) {
assoc(local_env, CAR(*bindings_p), eval(local_env, CADR(*bindings_p)));
*bindings_p = CDDR(*bindings_p);
}
// print_env(local_env);
uptr_t rval = NIL,
*new_env = refer(NIL),
*new_vals = refer(NIL);
while (*body_p) {
rval = eval(local_env, CAR(*body_p));
*body_p = CDR(*body_p);
if (IS_CONS(rval) && IS_SYM(CAR(rval)) && SVAL(CAR(rval)) == S_RECUR) {
*new_env = *env;
*new_vals = CDR(rval);
*bindings_p = CAR(*form_p);
while (*new_vals && *bindings_p) {
assoc(new_env, CAR(*bindings_p), eval(local_env, CAR(*new_vals)));
*bindings_p = CDDR(*bindings_p);
*new_vals = CDR(*new_vals);
}
*body_p = CDR(*form_p);
*local_env = *new_env;
}
}
release(6); // bindings_p, body_p, form_p, local_env, new_env, new_vals
return rval;
}
int main(int argc, char *argv[]) {
#ifdef ARDUINO
ARDUINO_INIT_IO(9600);
#endif
/* populate env with special forms */
void *env = empty();
Special Car = { SPECIAL, "car", &car };
Special Cdr = { SPECIAL, "cdr", &cdr };
Special Quote = { SPECIAL, "quote", "e };
Special Eq = { SPECIAL, "eq", &eq };
Special Eval = { SPECIAL, "eval", &eval };
assoc(&env, sym("car"), (void*)&Car);
assoc(&env, sym("cdr"), (void*)&Cdr);
assoc(&env, sym("quote"), (void*)&Quote);
assoc(&env, sym("eq"), (void*)&Eq);
assoc(&env, sym("eval"), (void*)&Eval);
print_form(cons(sym("eq"), cons(integer(1), integer(2))));
printf("\n");
print_form(eval(&env, cons(sym("eq"), cons(integer(2), integer(3)))));
printf("\n");
printf("\n");
print_form(eval(&env, cons(sym("eq"), cons(integer(1), cons(integer(2), integer(3))))));
printf("\n");
while(1) {
printf("=> ");
print_form(read_form(stdin));
printf("\n");
}
return 0;
}
/* sublis - substitute using an association list */
LOCAL LVAL sublis(LVAL alist, LVAL expr, LVAL fcn, int tresult)
{
LVAL carval,cdrval,pair;
if ((pair = assoc(expr,alist,fcn,tresult)))
return (cdr(pair));
else if (consp(expr)) {
xlsave1(carval);
carval = sublis(alist,car(expr),fcn,tresult);
cdrval = sublis(alist,cdr(expr),fcn,tresult);
xlpop();
return (cons(carval,cdrval));
}
else
return (expr);
}
static void docommand(FILE *str,char *line)
{
char *cmd;
cmd = gettoken(&line);
if (!cmd) return;
switch (assoc(commands,cmd)) {
case CMD_AGENT:
doagentcmd(str,line);
break;
default:
fatal("Invalid command",cmd);
break;
}
}
/* Outputs TRUE if Symbol is the name of an object variable owned by the
* current object, FALSE otherwise.
* @params - Symbol
*/
NODE *lmynamep(NODE *args) {
NODE *arg;
arg = name_arg(args);
if (NOT_THROWING) {
arg = intern(arg);
if (current_object == logo_object) {
return torf(flag__caseobj(arg, HAS_GLOBAL_VALUE));
}
else
return torf(assoc(arg, getvars(current_object)) != NIL);
}
return UNBOUND;
}
lisp_object* eval(lisp_object* obj, lisp_object* env)
{
data_type type = get_type_tag(obj);
lisp_object *opecode, *ret;
switch(type){
case TYPE_BOOLEAN:
case TYPE_NUMBER:
case TYPE_CHAR:
case TYPE_SUBR:
case TYPE_FSUBR:
case TYPE_EXPR:
case TYPE_FEXPR:
case TYPE_STRING:
case TYPE_PORT:
case TYPE_NULL:
case TYPE_VECTOR:
return obj;
case TYPE_SYMBOL:
ret = assoc(obj, env);
if(null(ret)){
fprintf(stderr, "eval:undefined variable\n");
return create_empty_list();// たぶん、toplevelに戻ったほうがいい
}
return ret;
case TYPE_CONS:
opecode = eval(get_car(obj), env);
type = get_type_tag(opecode);
switch(type){
case TYPE_SUBR:
case TYPE_EXPR:
return apply(opecode, evls(get_cdr(obj), env));
case TYPE_FSUBR:
case TYPE_FEXPR:
return apply(opecode, get_cdr(obj));
default:
fprintf(stderr, "eval:not function\n");
return create_empty_list();
}
default:
fprintf(stderr, "eval:undefined type\n");
return create_empty_list();
}
}
// evaluate form x with lexical bindings a
LISPTR eval(LISPTR x)
{
if (consp(x)) {
// evaluate a form
LISPTR f = car(x);
LISPTR args = cdr(x);
x = apply(f, args);
} else if (stringp(x) || numberp(x)) {
return x;
} else if (symbolp(x)) {
LISPTR binding = assoc(x, lexvars);
if (binding != NIL) {
x = cdr(binding);
} else {
x = symbol_value(x);
}
}
return x;
}
/**
* TODO: Documentation
* <p>
*/
void testXdr()
{
AssociationDTO assoc(*_assocElement);
iostream::XdrOutputStream ostream("testfile");
assoc.encode(ostream);
ostream.close();
iostream::XdrInputStream istream("testfile");
AssociationDTO decodedAssoc(istream);
istream.close();
remove("testfile");
assertTrue(decodedAssoc.getFromEnd().getTypeName() == assoc.getFromEnd().getTypeName());
assertTrue(decodedAssoc.getFromEnd().getMultiplicity() == assoc.getFromEnd().getMultiplicity());
assertTrue(decodedAssoc.getToEnd().getTypeName() == assoc.getToEnd().getTypeName());
assertTrue(decodedAssoc.getToEnd().getMultiplicity() == assoc.getToEnd().getMultiplicity());
}