static LakeVal *_lambda(LakeCtx *ctx, Env *env, LakeList *expr)
{
/* (lambda (a b c) ...) */
if (LIST_N(expr) >= 3 && lake_is_type(TYPE_LIST, LIST_VAL(expr, 1))) {
list_shift(expr); /* drop the "lambda" symbol */
LakeList *params = LIST(list_shift(expr));
LakeList *body = expr;
return VAL(fn_make(params, NULL, body, env));
}
else if (LIST_N(expr) >= 3 && lake_is_type(TYPE_DLIST, LIST_VAL(expr, 1))) {
list_shift(expr); /* drop the "lambda" symbol */
LakeDottedList *def = DLIST(list_shift(expr));
LakeList *params = dlist_head(def);
LakeSym *varargs = SYM(dlist_tail(def));
LakeList *body = expr;
return VAL(fn_make(params, varargs, body, env));
}
else if (LIST_N(expr) >= 3 && lake_is_type(TYPE_SYM, LIST_VAL(expr, 1))) {
list_shift(expr); /* drop the "lambda" symbol */
LakeSym *varargs = SYM(list_shift(expr));
LakeList *body = expr;
return VAL(fn_make(list_make(), varargs, body, env));
}
else {
invalid_special_form(expr, "lambda requires at least 2 parameters");
return NULL;
}
}
static SCM alsa_cards(void) {
// compile list of available cards
int card;
char buf[32];
char *pt;
SCM list, alist;
snd_ctl_card_info_t *info;
snd_ctl_card_info_alloca(&info);
card = -1;
list = SCM_EOL;
while (1) {
if ((snd_card_next(&card) < 0) || (card < 0)) break;
sprintf(buf, "hw:%d", card);
alist = SCM_EOL;
alist = scm_assq_set_x(alist, SYM("dev"),
scm_from_locale_string(buf));
snd_card_get_name(card, &pt);
alist = scm_assq_set_x(alist, SYM("name"),
scm_take_locale_string(pt));
list = scm_cons(alist, list);
scm_remember_upto_here_1(alist);
}
scm_remember_upto_here_1(list);
return list;
}
elem XmlRpc_DecodeMember(elem obj, elem mem)
{
elem t, x;
elem cur;
elem var, val;
t=MISC_NULL;
cur=CDDR(mem);
while(ELEM_CONSP(cur))
{
if(CAAR(cur)==SYM("name"))
{
var=SYM(ELEM_TOSTRING(CADDR(CAR(cur))));
}
if(CAAR(cur)==SYM("value"))
{
val=XmlRpc_DecodeValue(CADDR(CAR(cur)));
}
cur=CDR(cur);
}
TyObj_SetSlot(obj, var, val);
return(t);
}
elem XmlRpc_EncodeArray(elem lst)
{
elem cur;
elem t, x;
x=MISC_EOL;
cur=lst;
while(ELEM_CONSP(cur))
{
t=XmlRpc_EncodeValue(CAR(cur));
t=CONS(t, MISC_EOL);
t=CONS(MISC_EOL, t);
t=CONS(SYM("value"), t);
x=CONS(t, x);
cur=CDR(cur);
}
x=TyFcn_NReverse(x);
x=CONS(MISC_EOL, x);
x=CONS(SYM("data"), x);
x=CONS(x, MISC_EOL);
x=CONS(MISC_EOL, x);
x=CONS(SYM("array"), x);
return(x);
}
Object* net_init() {
Socket_proto = Socket_createProto();
Object* net = Object_new(Object_proto);
Object_setSlot(net, SYM(socket), FUNC(net_socket, 1));
Object_setSlot(net, SYM(Socket), Socket_proto);
return net;
}
void mU0Object::Init() {
if (Inited)
return;
$mU0 = SYM(root, mU0);
$mU0Object = SYM($mU0, Object);
mU0::ParseFile(mU0::Path() + _W("mU0.ini"));
Inited = true;
}
elem Verify_SimpleStructReturnTest(elem num)
{
elem t;
int i;
t=TyObj_CloneNull();
TyObj_SetSlot(t, SYM("times10"), FLONUM(TOFLOAT(num)*10));
TyObj_SetSlot(t, SYM("times100"), FLONUM(TOFLOAT(num)*100));
TyObj_SetSlot(t, SYM("times1000"), FLONUM(TOFLOAT(num)*1000));
return(t);
}
// Documented in spec.
zvalue formalsMinArgs(zvalue formals) {
zint minArgs = 0;
zint sz = get_size(formals);
for (zint i = 0; i < sz; i++) {
zvalue one = cm_nth(formals, i);
zvalue repeat = cm_get(one, SYM(repeat));
if (!(cmpEqNullOk(repeat, SYM(CH_QMARK))
|| cmpEqNullOk(repeat, SYM(CH_STAR)))) {
minArgs++;
}
}
return intFromZint(minArgs);
}
// Documented in spec.
CMETH_IMPL_rest_2(If, andThenElse, functions, thenFunction, elseFunction) {
zvalue results[functions.size];
for (zint i = 0; i < functions.size; i++) {
results[i] =
methCall(functions.elems[i], SYM(call), (zarray) {i, results});
if (results[i] == NULL) {
return methCall(elseFunction, SYM(call), EMPTY_ZARRAY);
}
}
return
methCall(thenFunction, SYM(call), (zarray) {functions.size, results});
}
/* format an relative address (implicit page 0) */
static char *REL0(int pc)
{
static char buff[32];
int o = readarg(pc);
sprintf(buff, "%s%s", (o&0x80)?"*":"", SYM((rel[o]) & 0x1fff));
return buff;
}
loliObj* loliCons::eval(loliObj* env){
this->type = typeCONS;
// std::cout<<this->type->toString()<<std::endl;
if(this->head() == SYM("if")){
loliObj* cond = lcons(this->tail())->head();
if(this->tail()->nilp()){
loli_err("Need at least one expression for if");
return nil;
}
loliObj* wt = lcons(lcons(this->tail())->tail())->head();
loliObj* wf = lcons(lcons(lcons(this->tail())->tail())->tail())->head();
if(cond->eval(env)==boolt){
return wt->eval(top_env);
}else if(cond->eval(env)==boolf){
if(wf){
return wf->eval(top_env);
}else{
return nil;
}
}else{
loli_err("Condition error");
return nil;
}
}
return eval_list(this, env);
}
edge_ref *delaunay_edges(int nsites)
{
edge_ref *array, *stack;
int edges = 0, top = -1;
unsigned mark = next_mark;
assert(array =
(edge_ref *) malloc((3 * nsites - 5) * sizeof(edge_ref)));
assert(stack =
(edge_ref *) malloc((3 * nsites - 6) * sizeof(edge_ref)));
if (++next_mark == 0)
next_mark = 1;
stack[++top] = delaunay_build(nsites);
while (top != -1) {
edge_ref e = stack[top--];
while (MARK(e) != mark) {
MARK(e) = mark;
array[edges++] = e;
stack[++top] = ONEXT(e);
e = ONEXT(SYM(e));
}
}
array[edges] = 0;
free(stack);
return array;
}
elem Verify_CountTheEntities(elem str)
{
elem t;
char *s;
int ltc, gtc, ampc, qc, dqc;
ltc=0;
gtc=0;
ampc=0;
qc=0;
dqc=0;
s=ELEM_TOSTRING(str);
while(*s)
{
switch(*s++)
{
case '<':
ltc++;
break;
case '>':
gtc++;
break;
case '&':
ampc++;
break;
case '\'':
qc++;
break;
case '"':
dqc++;
break;
default:
break;
}
}
t=TyObj_CloneNull();
TyObj_SetSlot(t, SYM("ctLeftAngleBrackets"), FIXNUM(ltc));
TyObj_SetSlot(t, SYM("ctRightAngleBrackets"), FIXNUM(gtc));
TyObj_SetSlot(t, SYM("ctAmpersands"), FIXNUM(ampc));
TyObj_SetSlot(t, SYM("ctApostrophes"), FIXNUM(qc));
TyObj_SetSlot(t, SYM("ctQuotes"), FIXNUM(dqc));
return(t);
}
// Documented in spec.
METH_IMPL_1(Value, crossOrder, other) {
// Note: `other` not guaranteed to have the same class as `ths`.
if (!haveSameClass(ths, other)) {
die("`crossOrder` called with incompatible arguments.");
}
return cmpEq(ths, other) ? SYM(same) : NULL;
}
// Documented in spec.
zvalue formalsMaxArgs(zvalue formals) {
zint maxArgs = 0;
zint sz = get_size(formals);
for (zint i = 0; i < sz; i++) {
zvalue one = cm_nth(formals, i);
zvalue repeat = cm_get(one, SYM(repeat));
if (cmpEqNullOk(repeat, SYM(CH_STAR))
|| cmpEqNullOk(repeat, SYM(CH_PLUS))) {
maxArgs = -1;
break;
}
maxArgs++;
}
return intFromZint(maxArgs);
}
static void _cpu_wake_channel_and_read(EV_P_ struct ev_io *ev, int revents) {
STATE;
size_t sz, total, offset;
ssize_t i;
char *buf;
OBJECT ret, ba, enc;
struct thread_info *ti = (struct thread_info*)ev->data;
ti->state->pending_events--;
state = ti->state;
if(NIL_P(ti->buffer)) {
ret = I2N(ti->fd);
} else {
ba = string_get_data(ti->buffer);
enc = string_get_encoding(ti->buffer);
sz = (size_t)ti->count;
if(enc == SYM("buffer")) {
offset = N2I(string_get_bytes(ti->buffer));
} else {
offset = 0;
}
/* Clamp the read size so we don't overrun */
total = SIZE_OF_BODY(ba) - offset - 1;
if(total < sz) {
sz = total;
}
buf = bytearray_byte_address(state, ba);
buf += offset;
while(1) {
i = read(ti->fd, buf, sz);
if(i == 0) {
ret = Qnil;
} else if(i == -1) {
/* If we read and got nothing, go again. We must get something.
It might be better to re-schedule this in libev and try again,
but libev just said SOMETHING was there... */
if(errno == EINTR) continue;
ret = lookuptable_fetch(state, state->global->errno_mapping, I2N(errno));
} else {
buf[i] = 0;
string_set_bytes(ti->buffer, I2N(i + offset));
ret = I2N(i);
}
break;
}
}
cpu_channel_send(state, ti->c, ti->channel, ret);
_cpu_event_unregister_info(state, ti);
}
void destroy_edge(edge_ref e)
{
edge_ref f = SYM(e);
if (ONEXT(e) != e)
splice(e, OPREV(e));
if (ONEXT(f) != f)
splice(f, OPREV(f));
free((char *) (e & MASK));
}
elem Verify_EasyStructTest(elem obj)
{
elem t;
int i;
i=0;
t=TyObj_GetSlot(obj, SYM("moe"));
i+=TOINT(t);
t=TyObj_GetSlot(obj, SYM("larry"));
i+=TOINT(t);
t=TyObj_GetSlot(obj, SYM("curly"));
i+=TOINT(t);
return(FIXNUM(i));
}
static edge_ref connect(edge_ref a, edge_ref b)
{
edge_ref e = make_edge();
ODATA(e) = DEST(a);
DDATA(e) = ORG(b);
splice(e, LNEXT(a));
splice(SYM(e), b);
return e;
}
static LakeVal *eval_special_form(LakeCtx *ctx, Env *env, LakeList *expr)
{
LakeSym *name = SYM(LIST_VAL(expr, 0));
special_form_handler handler = get_special_form_handler(ctx, name);
if (handler) {
return handler(ctx, env, list_copy(expr));
}
ERR("unrecognized special form: %s", sym_repr(name));
return NULL;
}
void
wpcap_packet_load(void)
{
/* These are the symbols I need or want from packet.dll */
static const symbol_table_t symbols[] = {
SYM(PacketGetVersion, FALSE),
SYM(PacketOpenAdapter, FALSE),
SYM(PacketCloseAdapter, FALSE),
SYM(PacketRequest, FALSE),
{ NULL, NULL, FALSE }
};
GModule *wh; /* wpcap handle */
const symbol_table_t *sym;
wh = ws_module_open("packet.dll", 0);
if (!wh) {
return;
}
sym = symbols;
while (sym->name) {
if (!g_module_symbol(wh, sym->name, sym->ptr)) {
if (sym->optional) {
/*
* We don't care if it's missing; we just
* don't use it.
*/
*sym->ptr = NULL;
} else {
/*
* We require this symbol.
*/
return;
}
}
sym++;
}
has_wpacket = TRUE;
}
nrn_unit_chk() {
Item *q;
unit_chk("v", "millivolt");
unit_chk("t", "ms");
unit_chk("dt", "ms");
unit_chk("celsius", "degC");
unit_chk("diam", "micron");
unit_chk("area", "micron2");
ITERATE(q, current) {
if (point_process) {
unit_chk(SYM(q)->name, "nanoamp");
}else{
unit_chk(SYM(q)->name, "milliamp/cm2");
}
}
ITERATE(q, concen) {
unit_chk(SYM(q)->name, "milli/liter");
}
LakeVal *apply(LakeCtx *ctx, LakeVal *fnVal, LakeList *args)
{
LakeVal *result = NULL;
if (lake_is_type(TYPE_PRIM, fnVal)) {
LakePrimitive *prim = PRIM(fnVal);
int arity = prim->arity;
if (arity == ARITY_VARARGS || LIST_N(args) == arity) {
result = prim->fn(ctx, args);
}
else {
ERR("%s expects %d params but got %zu", prim->name, arity, LIST_N(args));
result = NULL;
}
}
else if (lake_is_type(TYPE_FN, fnVal)) {
LakeFn *fn = FN(fnVal);
/* Check # of params */
size_t nparams = LIST_N(fn->params);
if (!fn->varargs && LIST_N(args) != nparams) {
ERR("expected %zu params but got %zu", nparams, LIST_N(args));
return NULL;
}
else if (fn->varargs && LIST_N(args) < nparams) {
ERR("expected at least %zu params but got %zu", nparams, LIST_N(args));
return NULL;
}
Env *env = env_make(fn->closure);
/* bind each (param,arg) pair in env */
size_t i;
for (i = 0; i < nparams; ++i) {
env_define(env, SYM(LIST_VAL(fn->params, i)), LIST_VAL(args, i));
}
/* bind varargs */
if (fn->varargs) {
LakeList *remainingArgs = list_make_with_capacity(LIST_N(args) - nparams);
for (; i < LIST_N(args); ++i) {
list_append(remainingArgs, LIST_VAL(args, i));
}
env_define(env, fn->varargs, VAL(remainingArgs));
}
/* evaluate body */
result = eval_exprs1(ctx, env, fn->body);
}
else {
ERR("not a function: %s", lake_repr(fnVal));
}
return result;
}
static edge_ref make_edge(void)
{
edge_ref e;
assert(e = (edge_ref) malloc(sizeof(edge_struct)));
ONEXT(e) = e;
ROTRNEXT(e) = TOR(e);
SYMDNEXT(e) = SYM(e);
TORLNEXT(e) = ROT(e);
MARK(e) = 0;
return e;
}
elem XmlRpc_EncodeStruct(elem obj)
{
elem lst, cur;
elem t, t2, x;
x=MISC_EOL;
lst=TyObj_SlotNames(obj);
cur=lst;
while(ELEM_CONSP(cur))
{
t2=MISC_EOL;
t=TyObj_GetSlot(obj, CAR(cur));
t=XmlRpc_EncodeValue(t);
t=CONS(t, MISC_EOL);
t=CONS(MISC_EOL, t);
t=CONS(SYM("value"), t);
t2=CONS(t, t2);
t=STRING(ELEM_TOSYMBOL(CAR(cur)));
t=CONS(t, MISC_EOL);
t=CONS(MISC_EOL, t);
t=CONS(SYM("name"), t);
t2=CONS(t, t2);
t2=CONS(MISC_EOL, t2);
t2=CONS(SYM("member"), t2);
x=CONS(t2, x);
cur=CDR(cur);
}
x=CONS(MISC_EOL, x);
x=CONS(SYM("struct"), x);
return(x);
}
static LakeVal *_define(LakeCtx *ctx, Env *env, LakeList *expr)
{
/* TODO: make these more robust, check all expected params */
/* (define x 42) */
if (LIST_N(expr) == 3 && lake_is_type(TYPE_SYM, LIST_VAL(expr, 1))) {
list_shift(expr); /* drop the "define" symbol */
LakeSym *var = SYM(list_shift(expr));
LakeVal *form = list_shift(expr);
env_define(env, var, eval(ctx, env, form));
}
/* (define (inc x) (+ 1 x)) */
else if (LIST_N(expr) >= 3 && lake_is_type(TYPE_LIST, LIST_VAL(expr, 1))) {
list_shift(expr); /* drop the "define" symbol */
LakeList *params = LIST(list_shift(expr));
LakeSym *var = SYM(list_shift(params));
LakeList *body = expr;
env_define(env, var, VAL(fn_make(params, NULL, body, env)));
}
/* (define (print format . args) (...)) */
else if (LIST_N(expr) >= 3 && lake_is_type(TYPE_DLIST, LIST_VAL(expr, 1))) {
list_shift(expr); /* drop the "define" symbol */
LakeDottedList *def = DLIST(list_shift(expr));
LakeList *params = dlist_head(def);
LakeSym *varargs = SYM(dlist_tail(def));
LakeSym *var = SYM(list_shift(params));
LakeList *body = expr;
env_define(env, var, VAL(fn_make(params, varargs, body, env)));
}
else {
invalid_special_form(expr, "define requires at least 2 parameters");
}
return NULL;
}
elem XmlRpc_HandleCall(elem req)
{
elem cur, t;
elem method, params;
method=MISC_NULL;
params=MISC_EOL;
if(CAR(req)==SYM("methodCall"))
{
cur=CDDR(req);
while(ELEM_CONSP(cur))
{
if(CAAR(cur)==SYM("methodName"))
{
method=CADDR(CAR(cur));
}
if(CAAR(cur)==SYM("params"))
{
t=CDDR(CAR(cur));
params=XmlRpc_DecodeParams(t);
}
cur=CDR(cur);
}
}
kprint("method call: ");
TyFcn_DumpElem(method);
kprint(" with: ");
TyFcn_DumpElemBR(params);
method=SYM(ELEM_TOSTRING(method));
t=Verify_Func(method, params);
// t=MISC_NULL;
return(t);
}
elem XmlRpc_EncodeResponse(elem val)
{
elem t, x;
t=XmlRpc_EncodeValue(val);
x=CONS(t, MISC_EOL);
x=CONS(MISC_EOL, x);
x=CONS(SYM("value"), x);
x=CONS(x, MISC_EOL);
x=CONS(MISC_EOL, x);
x=CONS(SYM("param"), x);
x=CONS(x, MISC_EOL);
x=CONS(MISC_EOL, x);
x=CONS(SYM("params"), x);
x=CONS(x, MISC_EOL);
x=CONS(MISC_EOL, x);
x=CONS(SYM("methodResponse"), x);
return(x);
}
elem Verify_ArrayOfStructsTest(elem lst)
{
elem cur, t;
int i;
i=0;
cur=lst;
while(ELEM_CONSP(cur))
{
t=TyObj_GetSlot(CAR(cur), SYM("curly"));
i+=TOINT(t);
cur=CDR(cur);
}
return(FIXNUM(i));
}
Object *Builtin_set(ListObject *arg, ListObject *context)
{
if (arg->len == 2 && arg->arr[0]->type == SYMBOL_OBJECT)
{
SymbolObject *symbol = SYM(arg->arr[0]);
Object *value = arg->arr[1];
Context_set(context, symbol, value);
return value;
}
else
{
cause_error(INCORRECT_ARGUMENT_ERROR, "(set <symbol> <object>)", 23);
return NULL;
}
}
