atom_p syntax_set(atom_p args, atom_p env) {
if ( !(args->array.len == 2 && args->array.ptr[0]->type == T_SYM) )
return error_atom("set!: need exactly 2 args, first has to be a symbol");
hash_set(env, args->array.ptr[0]->sym, eval(args->array.ptr[1], env));
return nil_atom;
}
static void
zmqdrv_error_code(zmq_drv_t *drv, int err)
{
ErlDrvTermData spec[] =
{ERL_DRV_ATOM, am_error,
ERL_DRV_ATOM, error_atom(err),
ERL_DRV_TUPLE, 2};
driver_send_term(drv->port, driver_caller(drv->port), spec, sizeof(spec)/sizeof(spec[0]));
}
atom_p syntax_if(atom_p args, atom_p env) {
if (args->array.len != 3)
return error_atom("if: needs exactly 3 args");
atom_p cond = eval(args->array.ptr[0], env);
if (cond->type == T_FALSE || cond->type == T_NIL)
return eval(args->array.ptr[2], env);
else
return eval(args->array.ptr[1], env);
}
atom_p syntax_lambda(atom_p args, atom_p env) {
if ( !(args->array.len == 2 && args->array.ptr[0]->type == T_ARRAY && args->array.ptr[1]->type == T_ARRAY) )
return error_atom("lambda: needs exactly 2 args, both have to be arrays");
atom_p atom = gc_alloc(sizeof(atom_t));
atom->type = T_LAMBDA;
atom->lambda.args = args->array.ptr[0];
atom->lambda.body = args->array.ptr[1];
atom->lambda.env = env;
return atom;
}
static void
zmqdrv_socket_error(zmq_drv_t *drv, ErlDrvTermData pid, uint32_t idx, int err) {
// Return {zmq, Socket::integer(), {error, Reason::atom()}}
ErlDrvTermData spec[] =
{ERL_DRV_ATOM, am_zmq,
ERL_DRV_UINT, idx,
ERL_DRV_ATOM, am_error,
ERL_DRV_ATOM, error_atom(err),
ERL_DRV_TUPLE, 2,
ERL_DRV_TUPLE, 3};
driver_send_term(drv->port, pid, spec, sizeof(spec)/sizeof(spec[0]));
}
//-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~
static void
reply_error(ErlDrvPort port, ErlDrvTermData pid, int err)
{
// Return {zmq, Socket::integer(), {error, Reason::atom()}}
ErlDrvTermData spec[] = {
ERL_DRV_ATOM, am_zmq_drv,
ERL_DRV_ATOM, am_error,
ERL_DRV_ATOM, error_atom(err),
ERL_DRV_TUPLE, 2,
ERL_DRV_TUPLE, 2
};
driver_send_term(port, pid, spec, sizeof(spec)/sizeof(spec[0]));
}
// send {Ref, {error,Reason}}
int dthread_port_send_error(dthread_t* thr, dthread_t* source,
ErlDrvTermData target,
ErlDrvTermData ref, int error)
{
dterm_t t;
dterm_mark_t m,e;
int r;
dterm_init(&t);
dterm_tuple_begin(&t, &m); {
dterm_int(&t, ref);
dterm_tuple_begin(&t, &e); {
dterm_atom(&t, am_error);
dterm_atom(&t, error_atom(error));
}
dterm_tuple_end(&t,&e);
}
dterm_tuple_end(&t,&m);
r = dthread_port_send_term(thr, source, target,
dterm_data(&t), dterm_used_size(&t));
dterm_finish(&t);
return r;
}
static void
zmqdrv_ready_input(ErlDrvData handle, ErlDrvEvent event)
{
zmq_drv_t *drv = (zmq_drv_t *)handle;
// Get 0MQ sockets managed by application thread's signaler
// identified by "event" fd.
zmq_fd_sockets_map_t::iterator it = drv->zmq_fd_sockets.find((long)event);
zmqdrv_fprintf("input ready on [idx=%ld]\r\n", (long)event);
assert(it != drv->zmq_fd_sockets.end());
zmq_sock_set_t::iterator si = it->second.begin();
assert(si != it->second.end());
for (; si != it->second.end(); ++si) {
zmq_socket_t s = (*si)->socket;
uint32_t idx = (*si)->idx;
ErlDrvTermData owner = (*si)->owner;
int rc = 0;
uint32_t events;
size_t events_size = sizeof(events);
zmq_getsockopt(s, ZMQ_EVENTS, &events, &events_size);
while (((*si)->active_mode || (*si)->in_caller) && (events & ZMQ_POLLIN)) {
msg_t msg;
rc = zmq_recv(s, &msg, ZMQ_NOBLOCK);
ErlDrvTermData pid = (*si)->active_mode ? owner : (*si)->in_caller;
if (rc == -1) {
if (zmq_errno() != EAGAIN) {
ErlDrvTermData spec[] =
{ERL_DRV_ATOM, am_zmq,
ERL_DRV_PORT, driver_mk_port(drv->port),
ERL_DRV_UINT, idx,
ERL_DRV_TUPLE, 2,
ERL_DRV_ATOM, am_error,
ERL_DRV_ATOM, error_atom(zmq_errno()),
ERL_DRV_TUPLE, 2,
ERL_DRV_TUPLE, 3};
driver_send_term(drv->port, owner, spec, sizeof(spec)/sizeof(spec[0]));
(*si)->in_caller = 0;
}
break;
}
if ((*si)->active_mode == 1) {
// Send message {zmq, Socket, binary()} to the owner pid
ErlDrvTermData spec[] =
{ERL_DRV_ATOM, am_zmq,
ERL_DRV_PORT, driver_mk_port(drv->port),
ERL_DRV_UINT, idx,
ERL_DRV_TUPLE, 2,
ERL_DRV_BUF2BINARY, (ErlDrvTermData)zmq_msg_data(&msg), zmq_msg_size(&msg),
ERL_DRV_TUPLE, 3};
driver_send_term(drv->port, owner, spec, sizeof(spec)/sizeof(spec[0]));
} else if ((*si)->active_mode == 2) {
// Send message {zmq, Socket, [binary()]} to the owner pid
// where binary() is each message part
std::vector<ErlDrvTermData> specv;
specv.reserve(100);
std::vector<msg_t*> parts;
specv.push_back(ERL_DRV_ATOM);
specv.push_back(am_zmq);
specv.push_back(ERL_DRV_PORT);
specv.push_back(driver_mk_port(drv->port));
specv.push_back(ERL_DRV_UINT);
specv.push_back(idx);
specv.push_back(ERL_DRV_TUPLE);
specv.push_back(2);
specv.push_back(ERL_DRV_BUF2BINARY);
specv.push_back((ErlDrvTermData)zmq_msg_data(&msg));
specv.push_back(zmq_msg_size(&msg));
int64_t more;
size_t more_size = sizeof(more);
int next_count = 0;
while (true) {
zmq_getsockopt(s, ZMQ_RCVMORE, &more, &more_size);
if (!more)
break;
next_count += 1;
msg_t *next_part = new msg_t;
parts.push_back(next_part);
rc = zmq_recv(s, next_part, ZMQ_NOBLOCK);
assert (!rc); // FIXME
specv.push_back(ERL_DRV_BUF2BINARY);
specv.push_back((ErlDrvTermData)zmq_msg_data(next_part));
specv.push_back(zmq_msg_size(next_part));
}
specv.push_back(ERL_DRV_NIL);
specv.push_back(ERL_DRV_LIST);
specv.push_back(next_count + 2);
specv.push_back(ERL_DRV_TUPLE);
specv.push_back(3);
driver_send_term(drv->port, owner, specv.data(), specv.size());
for (uint i = 0; i < parts.size(); i++) {
delete parts[i];
}
} else {
// Return result {ok, binary()} to the waiting caller's pid
ErlDrvTermData spec[] =
{ERL_DRV_ATOM, am_zok,
ERL_DRV_BUF2BINARY, (ErlDrvTermData)zmq_msg_data(&msg), zmq_msg_size(&msg),
ERL_DRV_TUPLE, 2};
driver_send_term(drv->port, pid, spec, sizeof(spec)/sizeof(spec[0]));
(*si)->in_caller = 0;
}
// FIXME: add error handling
zmqdrv_fprintf("received %ld byte message relayed to pid %ld\r\n", zmq_msg_size(&msg), pid);
zmq_getsockopt(s, ZMQ_EVENTS, &events, &events_size);
}
zmq_getsockopt(s, ZMQ_EVENTS, &events, &events_size);
if ((*si)->out_caller != 0 && (events & ZMQ_POLLOUT)) {
// There was a pending unwritten message on this socket.
// Try to write it. If the write succeeds/fails clear the ZMQ_POLLOUT
// flag and notify the waiting caller of completion of operation.
rc = zmq_send(s, &(*si)->out_msg, (*si)->out_flags | ZMQ_NOBLOCK);
zmqdrv_fprintf("resending message %p (size=%ld) on socket %p (ret=%d)\r\n",
zmq_msg_data(&(*si)->out_msg), zmq_msg_size(&(*si)->out_msg), s, rc);
if (rc == 0) {
zmq_msg_close(&(*si)->out_msg);
// Unblock the waiting caller's pid by returning result
zmqdrv_ok(drv, (*si)->out_caller);
(*si)->out_caller = 0;
} else if (zmq_errno() != EAGAIN) {
// Unblock the waiting caller's pid by returning result
zmq_msg_close(&(*si)->out_msg);
zmqdrv_socket_error(drv, (*si)->out_caller, idx, zmq_errno());
(*si)->out_caller = 0;
}
}
zmqdrv_fprintf("--> socket %p events=%d\r\n", s, events);
}
}
atom_p builtin_not(atom_p args, atom_p env) {
if (args->array.len != 1)
return error_atom("! needs one arg");
return (args->array.ptr[0]->type == T_FALSE || args->array.ptr[0]->type == T_NIL) ? true_atom : false_atom;
}
atom_p builtin_gt(atom_p args, atom_p env) {
if (args->array.len != 2 || args->array.ptr[0]->type != T_NUM || args->array.ptr[1]->type != T_NUM)
return error_atom("> needs 2 number args");
return (args->array.ptr[0]->num > args->array.ptr[1]->num) ? true_atom : false_atom;
}
atom_p syntax_quote(atom_p args, atom_p env) {
if (args->array.len == 1)
return args->array.ptr[0];
return error_atom("quote: only supports one arg");
}
/**
nil, true, false, num, str, obj, error → self
sym → env lookup
array → func call
eval func slot
func slot == error
return error
func slot == builtin
eval all args
return error if args contain error
call builtin with args
return result
func slot == syntax
return error if args contain error
call builtin with unevaled args
return result
env → error
**/
atom_p eval(atom_p atom, atom_p env) {
switch(atom->type) {
case T_NIL: case T_TRUE: case T_FALSE:
case T_NUM: case T_STR: case T_OBJ:
case T_ERROR:
return atom;
case T_SYM:
for(atom_p e = env; e != NULL; e = e->obj.parent) {
atom_p value = hash_get(e, atom->sym);
if (value)
return value;
}
return nil_atom;
case T_ARRAY:
{
if (atom->array.len == 0)
return error_atom("eval: array needs at least one elment to be evaled");
atom_p func = eval(atom->array.ptr[0], env);
if (func->type == T_ERROR)
return func;
if ( !(func->type == T_BUILTIN || func->type == T_SYNTAX || func->type == T_LAMBDA) )
return error_atom("eval: only builtin, syntax and lambda atoms are allowed in the function slot");
atom_p args = gc_alloc(sizeof(atom_t));
args->type = T_ARRAY;
if (func->type == T_BUILTIN) {
args->array.len = atom->array.len - 1;
args->array.ptr = gc_alloc(args->array.len * sizeof(atom_p));
for(size_t i = 1; i < atom->array.len; i++) {
atom_p evaled_arg = eval(atom->array.ptr[i], env);
if (evaled_arg->type == T_ERROR)
return evaled_arg;
args->array.ptr[i - 1] = evaled_arg;
}
return func->builtin(args, env);
} else if (func->type == T_SYNTAX) {
args->array.len = atom->array.len - 1;
args->array.ptr = atom->array.ptr + 1;
for(size_t i = 0; i < args->array.len; i++) {
if (args->array.ptr[i]->type == T_ERROR)
return args->array.ptr[i];
}
return func->syntax(args, env);
} else if (func->type == T_LAMBDA) {
if ( func->lambda.args->array.len != atom->array.len - 1 )
return error_atom("eval: a lambda needs to be called with exactly as many args as defined");
atom_p lambda_env = gc_alloc_zeroed(sizeof(atom_t));
lambda_env->type = T_ENV;
lambda_env->obj.parent = func->lambda.env;
for(size_t i = 1; i < atom->array.len; i++) {
atom_p arg_name = func->lambda.args->array.ptr[i - 1];
if (arg_name->type != T_SYM)
return error_atom("eval: in the definition of an lambda an argument has to be a symbol");
atom_p evaled_arg = eval(atom->array.ptr[i], env);
if (evaled_arg->type == T_ERROR)
return evaled_arg;
hash_set(lambda_env, arg_name->sym, evaled_arg);
}
return eval(func->lambda.body, lambda_env);
}
}
return error_atom("eval: unknown atom in function slot");
default:
return error_atom("eval: got unknown atom");
}
}
atom_p read(FILE* input) {
fscanf(input, " ");
if (feof(input))
return NULL;
char* str = NULL;
if ( fscanf(input, "\"%m[^\"]\"", &str) == 1 ) {
atom_p atom = gc_alloc(sizeof(atom_t));
atom->type = T_STR;
atom->str = gc_alloc(strlen(str) + 1);
strcpy(atom->str, str);
free(str);
return atom;
}
int c = getc(input);
if ( isdigit(c) ) {
double value = c - '0';
while ( (c = getc(input)), c >= '0' && c <= '9' ) {
value = value * 10;
value += c - '0';
}
if (c == '.') {
double fraction = 0.1;
while ( (c = getc(input)), c >= '0' && c <= '9' ) {
value += (c - '0') * fraction;
fraction /= 10;
}
}
ungetc(c, input);
atom_p atom = gc_alloc(sizeof(atom_t));
atom->type = T_NUM;
atom->num = value;
return atom;
} else if (c == '(') {
atom_p atom = gc_alloc(sizeof(atom_t));
atom->type = T_ARRAY;
atom->array.len = 0;
atom->array.ptr = NULL;
int c = 0;
while (true) {
fscanf(input, " ");
if ( (c = getc(input)) == ')' )
return atom;
ungetc(c, input);
atom_p item = read(input);
if (item == NULL)
return error_atom("unexpected EOF while reading array elements");
atom->array.ptr = gc_realloc(atom->array.ptr, atom->array.len * sizeof(atom->array.ptr[0]), (atom->array.len + 1) * sizeof(atom->array.ptr[0]));
atom->array.len += 1;
atom->array.ptr[atom->array.len - 1] = item;
}
} else if (c == '{') {
atom_p atom = gc_alloc_zeroed(sizeof(atom_t));
atom->type = T_OBJ;
char c = 0;
fscanf(input, " %c", &c);
if (c == '}')
return atom;
ungetc(c, input);
do {
char* key = NULL;
if ( fscanf(input, " %m[^:{}() \f\n\r\t\v]", &key) != 1 )
return error_atom("expected object property name after '{' or ','");
fscanf(input, " %c", &c);
if (c != ':')
return error_atom("expected ':' after object property name");
atom_p value = read(input);
hash_set(atom, key, value);
} while( fscanf(input, " %c", &c) == 1 && c == ',' );
if (c != '}')
return error_atom("expected '}' or ',' after object property value");
return atom;
} else {
ungetc(c, input);
}
if ( fscanf(input, " %m[^:{}() \f\n\r\t\v]", &str) == 1 ) {
atom_p atom = NULL;
if ( strcmp(str, "nil") == 0 ) {
atom = nil_atom;
free(str);
} else if ( strcmp(str, "true") == 0 ) {
atom = true_atom;
free(str);
} else if ( strcmp(str, "false") == 0 ) {
atom = false_atom;
free(str);
} else {
atom = gc_alloc_uncollected(sizeof(atom_t));
atom->type = T_SYM;
atom->sym = gc_alloc(strlen(str) + 1);
strcpy(atom->sym, str);
free(str);
}
return atom;
}
fscanf(input, "%*[^\n]");
return error_atom("syntax error, ignoring rest of line");
}
static void
zmqdrv_ready_input(ErlDrvData handle, ErlDrvEvent event)
{
zmq_drv_t *drv = (zmq_drv_t *)handle;
// Get 0MQ sockets managed by application thread's signaler
// identified by "event" fd.
zmq_fd_sockets_map_t::iterator it = drv->zmq_fd_sockets.find((long)event);
zmqdrv_fprintf("input ready on [idx=%ld]\r\n", (long)event);
assert(it != drv->zmq_fd_sockets.end());
zmq_sock_set_t::iterator si = it->second.begin();
assert(si != it->second.end());
for (; si != it->second.end(); ++si) {
zmq_socket_t s = (*si)->socket;
uint32_t idx = (*si)->idx;
ErlDrvTermData owner = (*si)->owner;
int rc = 0;
uint32_t events;
size_t events_size = sizeof(events);
zmq_getsockopt(s, ZMQ_EVENTS, &events, &events_size);
while (((*si)->active_mode || (*si)->in_caller) && (events & ZMQ_POLLIN)) {
msg_t msg;
rc = zmq_recv(s, &msg, ZMQ_NOBLOCK);
ErlDrvTermData pid = (*si)->active_mode ? owner : (*si)->in_caller;
if (rc == -1) {
if (zmq_errno() != EAGAIN) {
ErlDrvTermData spec[] =
{ERL_DRV_ATOM, am_zmq,
ERL_DRV_UINT, idx,
ERL_DRV_ATOM, error_atom(zmq_errno()),
ERL_DRV_TUPLE, 2,
ERL_DRV_TUPLE, 3};
driver_send_term(drv->port, owner, spec, sizeof(spec)/sizeof(spec[0]));
(*si)->in_caller = 0;
}
break;
}
if ((*si)->active_mode) {
// Send message {zmq, Socket, binary()} to the owner pid
ErlDrvTermData spec[] =
{ERL_DRV_ATOM, am_zmq,
ERL_DRV_UINT, idx,
ERL_DRV_BUF2BINARY, (ErlDrvTermData)zmq_msg_data(&msg), zmq_msg_size(&msg),
ERL_DRV_TUPLE, 3};
driver_send_term(drv->port, owner, spec, sizeof(spec)/sizeof(spec[0]));
} else {
// Return result {ok, binary()} to the waiting caller's pid
ErlDrvTermData spec[] =
{ERL_DRV_ATOM, am_zok,
ERL_DRV_BUF2BINARY, (ErlDrvTermData)zmq_msg_data(&msg), zmq_msg_size(&msg),
ERL_DRV_TUPLE, 2};
driver_send_term(drv->port, pid, spec, sizeof(spec)/sizeof(spec[0]));
(*si)->in_caller = 0;
}
// FIXME: add error handling
zmqdrv_fprintf("received %ld byte message relayed to pid %ld\r\n", zmq_msg_size(&msg), pid);
zmq_getsockopt(s, ZMQ_EVENTS, &events, &events_size);
}
zmq_getsockopt(s, ZMQ_EVENTS, &events, &events_size);
if ((*si)->out_caller != 0 && (events & ZMQ_POLLOUT)) {
// There was a pending unwritten message on this socket.
// Try to write it. If the write succeeds/fails clear the ZMQ_POLLOUT
// flag and notify the waiting caller of completion of operation.
rc = zmq_send(s, &(*si)->out_msg, (*si)->out_flags | ZMQ_NOBLOCK);
zmqdrv_fprintf("resending message %p (size=%ld) on socket %p (ret=%d)\r\n",
zmq_msg_data(&(*si)->out_msg), zmq_msg_size(&(*si)->out_msg), s, rc);
if (rc == 0) {
zmq_msg_close(&(*si)->out_msg);
// Unblock the waiting caller's pid by returning result
zmqdrv_ok(drv, (*si)->out_caller);
(*si)->out_caller = 0;
} else if (zmq_errno() != EAGAIN) {
// Unblock the waiting caller's pid by returning result
zmq_msg_close(&(*si)->out_msg);
zmqdrv_socket_error(drv, (*si)->out_caller, idx, zmq_errno());
(*si)->out_caller = 0;
}
}
zmqdrv_fprintf("--> socket %p events=%d\r\n", s, events);
}
}
