static co_obj_t *
_csm_services_commit_i(co_obj_t *list, co_obj_t *current, void *context)
{
if (IS_LIST(current)) return NULL;
co_obj_t *service_list = (co_obj_t*)context;
assert(IS_LIST(service_list));
co_cbptr_t *handler = (co_cbptr_t*)current;
handler->cb(service_list, NULL, service_list);
return NULL;
}
void pretty_print(env_t *env, VALUE v, int i) {
if (VALUE_IS_ERROR(v)) {
printf("<error>\n");
} else if (IS_LIST(v)) {
printf("(\n");
int j;
for (j = 0; j < list_len(v); j++) {
indent(i + 1); pretty_print(env, list_get(v, j), i + 1);
}
indent(i); printf(")\n");
} else {
if (VALUE_IS_INT(v)) {
printf("%lld\n", INTVAL(v));
} else if (VALUE_IS_BOOL(v)) {
printf("#%c\n", BOOLVAL(v) ? 't' : 'f');
} else if (VALUE_IS_NIL(v)) {
printf("#nil\n");
} else if (VALUE_IS_IDENT(v)) {
printf("%s\n", intern_table_get_str(&env->intern, IDENT(v)));
} else if (VALUE_IS_ATOM(v)) {
printf(":%s\n", intern_table_get_str(&env->intern, ATOM(v)));
} else if (IS_STRING(v)) {
printf("\"%s\"\n", string_chars(v));
} else {
printf("<unknown %p>\n", v);
}
}
}
int olsrd_mdp_init(co_obj_t *self, co_obj_t **output, co_obj_t *params) {
keyring_file *mdp_keyring = NULL;
unsigned char *mdp_key = NULL;
int mdp_key_len = 0;
unsigned char packedSid[SID_SIZE] = {0};
CHECK(IS_LIST(params) && co_list_length(params) == 2,"Invalid params");
size_t sid_len = co_str_len(co_list_element(params,1));
char *sid_str = _LIST_ELEMENT(params,1);
CHECK(sid_len == 2*SID_SIZE + 1 && str_is_subscriber_id(sid_str) == 1,"Invalid SID");
stowSid(packedSid,0,sid_str);
CHECK(serval_init_keyring(packedSid,
SID_SIZE,
_LIST_ELEMENT(params,0),
co_str_len(co_list_element(params,0)),
&mdp_keyring,
&mdp_key,
&mdp_key_len), "Failed to initialize Serval keyring");
CMD_OUTPUT("key",co_bin8_create((char*)mdp_key,mdp_key_len,0));
return 1;
error:
return 0;
}
int
olsrd_mdp_init(co_obj_t *self, co_obj_t **output, co_obj_t *params)
{
svl_crypto_ctx *ctx = NULL;
CHECK(IS_LIST(params) && co_list_length(params) == 2, "Invalid params");
size_t sid_len = co_str_len(co_list_element(params, 1));
char *sid_str = _LIST_ELEMENT(params, 1);
CHECK(sid_len == (2 * SID_SIZE) + 1 && str_is_subscriber_id(sid_str) == 1, "Invalid SID");
ctx = svl_crypto_ctx_new();
stowSid(ctx->sid, 0, sid_str);
ctx->keyring_path = _LIST_ELEMENT(params, 0);
ctx->keyring_len = co_str_len(co_list_element(params, 0)) - 1;
CHECK_ERR(ctx->keyring_len < PATH_MAX,"Keyring path too long");
CHECK(serval_init_keyring(ctx), "Failed to initialize Serval keyring");
CMD_OUTPUT("key", co_bin8_create((char*)ctx->sas_private, crypto_sign_SECRETKEYBYTES, 0));
return 1;
error:
if (ctx)
svl_crypto_ctx_free(ctx);
return 0;
}
obj_t * apply(obj_t *args, obj_t *env) {
assert(IS_LIST(args));
if (IS_LIST(CAR(args)) && IS_FUNC(CAR(CAR(args)))) {
return (FUNC(CAR(CAR(args))))(CDR(args), env);
} else if (IS_LIST(CAR(args)) && IS_DEFUNC(CAR(CAR(args)))) {
obj_t * func_args;
obj_t * call_args;
obj_t * body;
obj_t * result;
body = clone_obj(BODY(CAR(CAR(args))));
func_args = ARGS(CAR(CAR(args)));
call_args = CDR(args);
/* ((<DEFUNC:[args=(X)][body=(TIMES X X)]>) 3) */
while (IS_LIST(func_args) && IS_LIST(call_args)) {
obj_t * func_arg = CAR(func_args);
obj_t * call_arg = CAR(call_args);
replace_obj(func_arg, call_arg, body);
func_args = CDR(func_args);
call_args = CDR(call_args);
}
if ((IS_LIST(func_args) && !IS_LIST(call_args)) ||
(!IS_LIST(func_args) && IS_LIST(call_args))) {
free_obj(body); /* clean up */
fprintf(stdout, "Unexpected number of arguments\n");
return alloc_fail();
}
result = eval(body, env);
free_obj(body);
return result;
} else {
return clone_obj(args);
}
}
//nilを空リストと解釈している。
int listp(int x){
if(IS_LIST(x) && (!(improperp(x))))
return(1);
else
if(IS_NIL(x))
return(1);
else
return(0);
}
static co_obj_t *
_csm_service_list_find_service(co_obj_t *list, co_obj_t *current, void *context)
{
if (IS_LIST(current)) return NULL;
assert(IS_SERVICE(current));
csm_service *srv_ptr = (csm_service*)context;
if (((co_service_t*)current)->service == srv_ptr)
return current;
return NULL;
}
int
co_request_append(co_obj_t *request, co_obj_t *object)
{
CHECK_MEM(request);
CHECK_MEM(object);
CHECK(IS_LIST(request), "Not a valid request.");
return co_list_append(request, object);
error:
return 0;
}
int
co_shutdown(void)
{
CHECK_MEM(_sockets);
CHECK(IS_LIST(_sockets), "API not properly initialized.");
co_list_parse(_sockets, _co_shutdown_sockets_i, NULL);
co_obj_free(_pool);
return 1;
error:
return 0;
}
void _bam_check_template_list(SEXP template_list)
{
if (!IS_LIST(template_list) || LENGTH(template_list) != N_TMPL_ELTS)
Rf_error("'template' must be list(%d)", N_TMPL_ELTS);
SEXP names = GET_ATTR(template_list, R_NamesSymbol);
if (!IS_CHARACTER(names) || LENGTH(names) != N_TMPL_ELTS)
Rf_error("'names(template)' must be character(%d)", N_TMPL_ELTS);
for (int i = 0; i < LENGTH(names); ++i)
if (strcmp(TMPL_ELT_NMS[i], CHAR(STRING_ELT(names, i))) != 0)
Rf_error("'template' names do not match scan_bam_template\n'");
}
int
co_call(co_obj_t *connection, co_obj_t **response, const char *method, const size_t mlen, co_obj_t *request)
{
CHECK(method != NULL && mlen > 0 && mlen < UINT8_MAX, "Invalid method name.");
CHECK(connection != NULL && IS_SOCK(connection), "Invalid connection.");
co_obj_t *params = NULL, *rlist = NULL, *rtree = NULL;
int retval = 0;
size_t reqlen = 0, resplen = 0;
char req[REQUEST_MAX];
char resp[RESPONSE_MAX];
if(request != NULL)
{
CHECK(IS_LIST(request), "Not a valid request.");
params = request;
}
else
{
params = co_list16_create();
}
co_obj_t *m = co_str8_create(method, mlen, 0);
reqlen = co_request_alloc(req, sizeof(req), m, params);
CHECK(((co_socket_t*)connection)->send((co_obj_t*)((co_socket_t*)connection)->fd, req, reqlen) != -1, "Send error!");
if((resplen = ((co_socket_t*)connection)->receive(connection, (co_obj_t*)((co_socket_t*)connection)->fd, resp, sizeof(resp))) > 0)
{
CHECK(co_list_import(&rlist, resp, resplen) > 0, "Failed to parse response.");
rtree = co_list_element(rlist, 3);
if(!IS_NIL(rtree))
{
retval = 1;
}
else
{
rtree = co_list_element(rlist, 2);
retval = 0;
}
if(rtree != NULL && IS_TREE(rtree))
{
*response = rtree;
hattach(*response, _pool);
}
else SENTINEL("Invalid response.");
}
else SENTINEL("Failed to receive data.");
co_obj_free(m);
if(params != request) co_obj_free(params);
return retval;
error:
co_obj_free(m);
if(params != request) co_obj_free(params);
return retval;
}
int
co_request_append_uint(co_obj_t *request, const unsigned int i)
{
CHECK_MEM(request);
CHECK(IS_LIST(request), "Not a valid request.");
CHECK(i < UINT64_MAX, "Integer out of bounds.");
if(i > UINT32_MAX) return co_list_append(request, co_uint64_create(i, 0));
if(i > UINT16_MAX) return co_list_append(request, co_uint32_create(i, 0));
if(i > UINT8_MAX) return co_list_append(request, co_uint16_create(i, 0));
return co_list_append(request, co_uint8_create(i, 0));
error:
return 0;
}
int
co_request_append_int(co_obj_t *request, const int i)
{
CHECK_MEM(request);
CHECK(IS_LIST(request), "Not a valid request.");
CHECK(i < INT64_MAX && i > INT64_MIN, "Integer out of bounds.");
if(i > INT32_MAX || i < INT32_MIN) return co_list_append(request, co_int64_create(i, 0));
if(i > INT16_MAX || i < INT16_MIN) return co_list_append(request, co_int32_create(i, 0));
if(i > INT8_MAX || i < INT8_MIN) return co_list_append(request, co_int16_create(i, 0));
return co_list_append(request, co_int8_create(i, 0));
error:
return 0;
}
int
co_request_append_bin(co_obj_t *request, const char *s, const size_t slen)
{
CHECK_MEM(request);
CHECK_MEM(s);
CHECK(IS_LIST(request), "Not a valid request.");
CHECK(slen < UINT32_MAX, "Binary is too large.");
if(slen > UINT16_MAX) return co_list_append(request, co_bin32_create(s, slen, 0));
if(slen > UINT8_MAX) return co_list_append(request, co_bin16_create(s, slen, 0));
return co_list_append(request, co_bin8_create(s, slen, 0));
error:
return 0;
}
static co_obj_t *
_csm_find_service_i(co_obj_t *list, co_obj_t *current, void *context)
{
if (IS_LIST(current)) return NULL;
assert(IS_SERVICE(current));
co_service_t *service = (co_service_t*)current;
char *uuid = (char*)context;
if (strcmp(uuid, service->service.uuid) == 0)
return current;
return NULL;
}
struct atom *builtin_atom(struct atom *expr, struct env *env)
{
struct list *list = expr->list;
struct atom *op = LIST_FIRST(list);
struct atom *a = LIST_NEXT(op, entries);
(void) env;
if (!a)
return &nil_atom;
if (IS_LIST(a))
return &false_atom;
else
return &true_atom;
}
static inline void
_co_tree_raw_r(char **output, const size_t *olen, size_t *written, _treenode_t *current)
{
if(current == NULL) return;
size_t klen = 0, vlen = 0;
char *kbuf = NULL, *vbuf = NULL;
if(current->value != NULL)
{
CHECK((klen = co_obj_raw(&kbuf, current->key)) > 0, "Failed to read key.");
memmove(*output, kbuf, klen);
*output += klen;
*written += klen;
if(IS_TREE(current->value))
{
vlen = co_tree_raw(*output, *olen - *written, current->value);
CHECK(vlen > 0, "Failed to dump tree value.");
}
else if(IS_LIST(current->value))
{
vlen = co_list_raw(*output, *olen, current->value);
CHECK(vlen > 0, "Failed to dump tree value.");
}
else
{
CHECK((vlen = co_obj_raw(&vbuf, current->value)) > 0, "Failed to read value.");
CHECK((klen + vlen) < ((*olen) - (*written)), "Data too large for buffer.");
DEBUG("Dumping value %s of size %d with key %s of size %d.", vbuf, (int)vlen, kbuf, (int)klen);
memmove(*output, vbuf, vlen);
}
*written += vlen;
*output += vlen;
}
_co_tree_raw_r(output, olen, written, current->low);
_co_tree_raw_r(output, olen, written, current->equal);
_co_tree_raw_r(output, olen, written, current->high);
return;
error:
return;
}
struct atom *builtin_lambda(struct atom *expr, struct env *env)
{
struct list *list = expr->list;
struct atom *op = LIST_FIRST(list);
struct atom *params = CDR(op);
struct atom *body = CDR(params);
if (!params || !body || CDR(body))
{
printf("error: lambda takes exactly 2 arguments\n");
return &nil_atom;
}
if (!IS_LIST(params) && !IS_NIL(params))
{
printf("error: first arg to lambda must be a list\n");
return &nil_atom;
}
return atom_new_closure(params, body, env);
}
/**
* slice string/list
* string.slice(a,b) [a,b), b is not included
* string.slice(0,-1) = string.slice(0,len(string))
* @since 2016-11-19
* <code>
* 'test'.slice(0,1) = 't'
* 'test'.slice(0,-1) = 'test'
* </code>
*/
Object obj_slice(Object self, Object first, Object second) {
int start = GET_NUM(first);
int end = GET_NUM(second);
Object ret = NONE_OBJECT;
if (IS_STR(self)) {
int length = GET_STR_LEN(self);
start = start >= 0 ? start : start + length + 1;
end = end >= 0 ? end : end + length + 1;
if (start < 0 || start > length) {
start = 0;
}
if (end < 0 || end > length) {
end = length; // do not overflow;
}
if (end <= start) {
return string_alloc("", 0);
}
return string_alloc(GET_STR(self) + start, end - start);
} else if (IS_LIST(self)) {
int length = LIST_LEN(self);
start = start > 0 ? start : start + length + 1;
end = end > 0 ? end : end + length + 1;
if (start < 0 || start > length) {
start = 0;
}
if (end < 0 || end > length) {
end = length;
}
int i = 0;
ret = list_new(end - start);
for (i = start; i < end ; i++) {
obj_append(ret, LIST_GET(self, i));
}
} else {
tm_raise("slice not implemented for type %s", tm_type(self.type));
}
return ret;
}
term_t
eval_term(struct lisp0_state*state,term_t term){
X = term;
CALL(L_eval);
return X;
L_eval:
if(IS_ERROR(X)){
RETURN(X);
}
if(IS_ATOM(X)){
RETURN(subst(ENV,X));
}
if(!IS_LIST(X)){
RETURN(ERR(E_BAD_EXPR));
}
PUSH(CDR(X));
X = CAR(X);
CALL(L_eval);
Y = POP();
switch(TAG(X)){
case TAG_ERROR: RETURN(X);
case TAG_PRIMITIVE:
switch(VALUE(X)){
case PRIM_QUOTE: goto L_quote;
case PRIM_ATOM: goto L_atom;
case PRIM_EQ: goto L_eq;
case PRIM_COND: goto L_cond;
case PRIM_CAR: goto L_car;
case PRIM_CDR: goto L_cdr;
case PRIM_CONS: goto L_cons;
case PRIM_LABEL: goto L_label;
case PRIM_LAMBDA: goto L_lambda;
case PRIM_MACRO: goto L_macro;
default: break;
};
break;
case TAG_POINTER:
if(!X) break;
switch(PTAG(X)){
case PTAG_LAMBDA: goto L_eval_lambda;
case PTAG_MACRO: goto L_eval_macro;
default: break;
};
default: break;
}
RETURN(ERR(E_NOT_CALLABLE));
L_quote:
PARSE_ARG1();
RETURN(X);
L_atom:
PARSE_AND_EVAL_ARG1();
RETURN(((!X)||IS_ATOM(X))?TRUE:FALSE);
L_eq:
PARSE_AND_EVAL_ARG2();
RETURN(eq(Y,X)?TRUE:FALSE);
L_cond:
PARSE_ARG();
PUSH(CDR(Y));
Y = CAR(Y);
PARSE_ARG2();
PUSH(Y);
CLEAR(Y);
CALL(L_eval);
Y = POP();
switch(X){
case TRUE:
X = Y;
CLEAR(Y);
goto L_eval;
case FALSE:
Y = POP();
goto L_cond;
default:
RETURN(ERR(E_COND_END));
};
L_car:
PARSE_AND_EVAL_ARG1();
if(!IS_LIST(X)){
RETURN(ERR(E_ARGUMENT));
}
RETURN(CAR(X));
L_cdr:
PARSE_AND_EVAL_ARG1();
if(!IS_LIST(X)){
RETURN(ERR(E_ARGUMENT));
}
RETURN(CDR(X));
L_cons:
PARSE_AND_EVAL_ARG2();
L_cons_1:
RETURN(cons(state,Y,X));
L_label:
PARSE_ARG2();
PUSH(X);
X = Y;
CLEAR(Y);
CALL(L_eval);
RETURN_ERROR(X);
Y = POP();
CALL(L_cons_1);
Y = X;
X = ENV;
CALL(L_cons_1);
ENV = X;
RETURN(CDR(CAR(ENV)));
L_lambda:
PARSE_ARG2();
RETURN(mklist(state,X,Y,PTAG_LAMBDA));
L_macro:
PARSE_ARG2();
RETURN(mklist(state,X,Y,PTAG_MACRO));
L_eval_lambda:
PUSH(X);
push_list_builder(state);
CALL(L_eval_list);
Y = pop_list_builder(state,NIL);
RETURN_ERROR(X);
X = POP();
PUSH(CDR(X));
X = CAR(X);
push_list_builder(state);
CALL(L_zip);
Y = POP();
PUSH(ENV);
ENV = pop_list_builder(state,ENV);
RETURN_ERROR(X);
X = Y;
CLEAR(Y);
CALL(L_eval);
RETURN_ERROR(ENV);
ENV = POP();
RETURN(X);
L_eval_list:
if(!Y){
RETURN(Y);
}
PARSE_ARG();
X = CAR(Y);
PUSH(CDR(Y));
CLEAR(Y);
CALL(L_eval);
RETURN_ERROR(X);
list_builder_add_term(state,X);
Y = POP();
goto L_eval_list;
L_eval_macro:
PUSH(CDR(X));
X = CAR(X);
push_list_builder(state);
CALL(L_zip);
Y = POP();
PUSH(ENV);
ENV = pop_list_builder(state,ENV);
RETURN_ERROR(X);
X = Y;
CLEAR(Y);
CALL(L_eval);
ENV = POP();
goto L_eval;
L_zip:
if((!X)||(!Y))
goto L_zip_finish;
RETURN_ERROR(X);
RETURN_ERROR(Y);
if(!IS_LIST(X)){
RETURN(ERR(E_IMPROPER_LIST));
}
if(!IS_LIST(Y)){
RETURN(ERR(E_IMPROPER_LIST));
}
list_builder_add_term(state,cons(state,CAR(X),CAR(Y)));
X = CDR(X);
Y = CDR(Y);
goto L_zip;
L_zip_finish:
if(X||Y){
RETURN(ERR(E_ARGUMENT));
}
RETURN(NIL);
}
Value eval_get_bindings(Value arguments, Value parameters) {
/* Returns bindings in opposite direction (first is tightest bound) */
w_assert(IS_LIST(arguments));
w_assert(IS_LIST(parameters));
/* Most of the error logging should be in defun, not here! */
Bool optional = false;
Bool rest = false;
Value bindings = VALUE_NIL;
while (parameters.type == CONS) {
Value parameter = NEXT(parameters);
if (parameter.val.symbol_val == symbols_ampersand_optional.val.symbol_val) {
optional = true;
break;
}
if (parameter.val.symbol_val == symbols_ampersand_rest.val.symbol_val) {
rest = true;
break;
}
ENSURE_NOT_EMPTY(arguments);
Value argument = NEXT(arguments);
bindings = CONS(CONS(parameter, argument), bindings);
}
if (optional) {
while (parameters.type == CONS) {
Value parameter = NEXT(parameters);
if (parameter.val.symbol_val == symbols_ampersand_rest.val.symbol_val) {
rest = true;
break;
}
Value argument;
if (arguments.type == CONS) {
argument = NEXT(arguments);
} else {
argument = VALUE_NIL;
}
bindings = CONS(CONS(parameter, argument), bindings);
}
}
if (rest) {
if (parameters.type == CONS) {
Value parameter = NEXT(parameters);
bindings = CONS(CONS(parameter, arguments), bindings);
arguments = VALUE_NIL;
/* It would make sense to only allow one rest parameter
But as Emacs allows more (or none) so do we.
But defun could definitely give a warning */
while (parameters.type == CONS) {
parameter = NEXT(parameters);
bindings = CONS(CONS(parameter, VALUE_NIL), bindings);
arguments = VALUE_NIL;
}
} else {
arguments = VALUE_NIL;
parameters = VALUE_NIL;
}
}
ENSURE_EMPTY(arguments);
ENSURE_EMPTY(parameters);
/* w_assert(parameters.type == NIL); */
/* w_assert(arguments.type == NIL); */
return bindings;
}
/**
** evaluate byte code.
** @param f: Frame
** @return evaluated value.
*/
Object tm_eval(TmFrame* f) {
Object* locals = f->locals;
Object* top = f->stack;
Object cur_fnc = f->fnc;
Object globals = get_globals(cur_fnc);
// TODO use code cache to replace unsigned char*
unsigned char* pc = f->pc;
const char* func_name_sz = get_func_name_sz(cur_fnc);
Object x, k, v;
Object ret = NONE_OBJECT;
int i;
#if INTERP_DB
printf("File \"%s\": enter function %s\n",get_func_file_sz(cur_fnc), get_func_name_sz(cur_fnc));
#endif
while (1) {
i = (pc[1] << 8) | pc[2];
#if INTERP_DB
printf("%30s%2d: %d frame = %d, top = %d\n","", pc[0], i, tm->cur, (int) (top - f->stack));
#endif
switch (pc[0]) {
case OP_NUMBER: {
double d = atof((char*)pc + 3);
pc += i;
v = tm_number(d);
/* obj_append(tm->constants,v);*/
dict_set(tm->constants, v, NONE_OBJECT);
break;
}
case OP_STRING: {
v = string_alloc((char*)pc + 3, i);
pc += i;
/* obj_append(tm->constants,v); */
dict_set(tm->constants, v, NONE_OBJECT);
break;
}
case OP_IMPORT: {
// TODO
// tm_import(globals)
Object import_func = tm_get_global(globals, "_import");
arg_start();
arg_push(globals);
Object modname, attr;
if (i == 1) {
modname = TM_POP();
arg_push(modname); // arg1
} else {
attr = TM_POP();
modname = TM_POP();
arg_push(modname);
arg_push(attr);
}
call_function(import_func);
break;
}
case OP_CONSTANT: {
TM_PUSH(GET_CONST(i));
break;
}
case OP_NONE: {
TM_PUSH(NONE_OBJECT);
break;
}
case OP_LOAD_LOCAL: {
TM_PUSH(locals[i]);
break;
}
case OP_STORE_LOCAL:
locals[i] = TM_POP();
break;
case OP_LOAD_GLOBAL: {
/* tm_printf("load global %o\n", GET_CONST(i)); */
int idx = dict_get_attr(GET_DICT(globals), i);
if (idx == -1) {
idx = dict_get_attr(GET_DICT(tm->builtins), i);
if (idx == -1) {
tm_raise("NameError: name %o is not defined", GET_CONST(i));
} else {
Object value = GET_DICT(tm->builtins)->nodes[idx].val;
// OPTIMIZE
// set the builtin to `globals()`
obj_set(globals, GET_CONST(i), value);
idx = dict_get_attr(GET_DICT(globals), i);
pc[0] = OP_FAST_LD_GLO;
code16(pc+1, idx);
// OPTIMIZE END
TM_PUSH(value);
}
} else {
TM_PUSH(GET_DICT(globals)->nodes[idx].val);
pc[0] = OP_FAST_LD_GLO;
code16(pc+1, idx);
}
break;
}
case OP_STORE_GLOBAL: {
x = TM_POP();
int idx = dict_set_attr(GET_DICT(globals), i, x);
pc[0] = OP_FAST_ST_GLO;
code16(pc+1, idx);
break;
}
case OP_FAST_LD_GLO: {
TM_PUSH(GET_DICT(globals)->nodes[i].val);
break;
}
case OP_FAST_ST_GLO: {
GET_DICT(globals)->nodes[i].val = TM_POP();
break;
}
case OP_LIST: {
TM_PUSH(list_new(2));
FRAME_CHECK_GC();
break;
}
case OP_APPEND:
v = TM_POP();
x = TM_TOP();
tm_assert(IS_LIST(x), "tm_eval: OP_APPEND require list");
list_append(GET_LIST(x), v);
break;
case OP_DICT_SET:
v = TM_POP();
k = TM_POP();
x = TM_TOP();
tm_assert(IS_DICT(x), "tm_eval: OP_DICT_SET require dict");
obj_set(x, k, v);
break;
case OP_DICT: {
TM_PUSH(dict_new());
FRAME_CHECK_GC();
break;
}
TM_OP(OP_ADD, obj_add)
TM_OP(OP_SUB, obj_sub)
TM_OP(OP_MUL, obj_mul)
TM_OP(OP_DIV, obj_div)
TM_OP(OP_MOD, obj_mod)
TM_OP(OP_GET, obj_get)
case OP_SLICE: {
Object second = TM_POP();
Object first = TM_POP();
*top = obj_slice(*top, first, second);
break;
}
case OP_EQEQ: { *(top-1) = tm_number(obj_equals(*(top-1), *top)); top--; break; }
case OP_NOTEQ: { *(top-1) = tm_number(!obj_equals(*(top-1), *top)); top--; break; }
case OP_LT: {
*(top-1) = tm_number(obj_cmp(*(top-1), *top)<0);
top--;
break;
}
case OP_LTEQ: {
*(top-1) = tm_number(obj_cmp(*(top-1), *top)<=0);
top--;
break;
}
case OP_GT: {
*(top-1) = tm_number(obj_cmp(*(top-1), *top)>0);
top--;
break;
}
case OP_GTEQ: {
*(top-1) = tm_number(obj_cmp(*(top-1), *top)>=0);
top--;
break;
}
case OP_IN: {
*(top-1) = tm_number(obj_in(*(top-1), *top));
top--;
break;
}
case OP_AND: {
*(top-1) = tm_number(is_true_obj(*(top-1)) && is_true_obj(*top));
top--;
break;
}
case OP_OR: {
*(top-1) = tm_number(is_true_obj(*(top-1)) || is_true_obj(*top));
top--;
break;
}
case OP_NOT:{
*top = tm_number(!is_true_obj(*top));
break;
}
case OP_SET:
k = TM_POP();
x = TM_POP();
v = TM_POP();
#if INTERP_DB
tm_printf("Self %o, Key %o, Val %o\n", x, k, v);
#endif
obj_set(x, k, v);
break;
case OP_POP: {
top--;
break;
}
case OP_NEG:
TM_TOP() = obj_neg(TM_TOP());
break;
case OP_CALL: {
f->top = top;
top -= i;
arg_set_arguments(top + 1, i);
Object func = TM_POP();
TM_PUSH(call_function(func));
// TM_PUSH(call_function(func));
tm->frame = f;
FRAME_CHECK_GC();
break;
}
case OP_APPLY: {
f->top = top;
Object args = TM_POP();
tm_assert_type(args, TYPE_LIST, "tm_eval: OP_APPLY");
arg_set_arguments(LIST_NODES(args), LIST_LEN(args));
Object func = TM_POP();
x = call_function(func);
TM_PUSH(x);
tm->frame = f;
FRAME_CHECK_GC();
break;
}
case OP_LOAD_PARAMS: {
int parg = pc[1];
int varg = pc[2];
if (tm->arg_cnt < parg || tm->arg_cnt > parg + varg) {
tm_raise("ArgError,parg=%d,varg=%d,given=%d",
parg, varg, tm->arg_cnt);
}
for(i = 0; i < tm->arg_cnt; i++){
locals[i] = tm->arguments[i];
}
break;
}
case OP_LOAD_PARG: {
int parg = i;
for (i = 0; i < parg; i++) {
locals[i] = arg_take_obj(func_name_sz);
}
break;
}
case OP_LOAD_NARG: {
int arg_index = i;
Object list = list_new(tm->arg_cnt);
while (arg_remains() > 0) {
obj_append(list, arg_take_obj(func_name_sz));
}
locals[arg_index] = list;
break;
}
case OP_ITER: {
*top = iter_new(*top);
break;
}
case OP_NEXT: {
Object *next = next_ptr(*top);
if (next != NULL) {
TM_PUSH(*next);
break;
} else {
pc += i * 3;
continue;
}
break;
}
case OP_DEF: {
Object mod = GET_FUNCTION(cur_fnc)->mod;
Object fnc = func_new(mod, NONE_OBJECT, NULL);
pc = func_resolve(GET_FUNCTION(fnc), pc);
GET_FUNCTION_NAME(fnc) = GET_CONST(i);
TM_PUSH(fnc);
continue;
}
case OP_RETURN: {
ret = TM_POP();
goto end;
}
case OP_ROT: {
int half = i / 2;
int j;
for (j = 0; j < half; j++) {
Object temp = *(top - j);
*(top-j) = *(top - i + j + 1);
*(top-i+j+1) = temp;
}
break;
}
case OP_UNPACK: {
x = TM_POP();
tm_assert_type(x, TYPE_LIST, "tm_eval:UNPACK");
int j;
for(j = LIST_LEN(x)-1; j >= 0; j--) {
TM_PUSH(LIST_GET(x, j));
}
break;
}
case OP_DEL: {
k = TM_POP();
x = TM_POP();
obj_del(x, k);
break;
}
case OP_POP_JUMP_ON_FALSE: {
if (!is_true_obj(TM_POP())) {
pc += i * 3;
continue;
}
break;
}
case OP_JUMP_ON_TRUE: {
if (is_true_obj(TM_TOP())) {
pc += i * 3;
continue;
}
break;
}
case OP_JUMP_ON_FALSE: {
if (!is_true_obj(TM_TOP())) {
pc += i * 3;
continue;
}
break;
}
case OP_UP_JUMP:
pc -= i * 3;
continue;
case OP_JUMP:
pc += i * 3;
continue;
case OP_EOP:
case OP_EOF: {
ret = NONE_OBJECT;
goto end;
}
case OP_LOAD_EX: { top = f->last_top; TM_PUSH(tm->ex); break; }
case OP_SETJUMP: { f->last_top = top; f->jmp = pc + i * 3; break; }
case OP_CLR_JUMP: { f->jmp = NULL; break;}
case OP_LINE: { f->lineno = i; break;}
case OP_DEBUG: {
#if 0
Object fdebug = tm_get_global(globals, "__debug__");
f->top = top;
tm_call(0, fdebug, 1, tm_number(tm->frame - tm->frames));
break;
#endif
}
case OP_FILE: {
// module name here.
break;
}
default:
tm_raise("BAD INSTRUCTION, %d\n globals() = \n%o", pc[0],
GET_FUNCTION_GLOBALS(f->fnc));
goto end;
}
pc += 3;
}
end:
/*
if (top != f->stack) {
tm_raise("tm_eval: operand stack overflow");
}*/
pop_frame();
return ret;
}
Object obj_append(Object a, Object item) {
if (IS_LIST(a)) {
list_append(GET_LIST(a), item);
}
return a;
}
static void out(register cell xval, stack wam)
{ register term xref;
static char ibuf[MAX1];
FDEREF(xval);
if(g.stop-g.sbuf>(bp_long)max.SBUF-MAX1)
{ warnmes("string buffer (-i option) exceeded or infinite term"); return; }
if(VAR(xval))
{
/* obsolete
ASSERT2((void*)g.shared[BBoardStk].base<(void*)htable &&
(void*)htable<(void*)wam[HeapStk].base, xval);
*/
VOUT(HeapStk,COUT('x'))
BOUT(COUT('b'))
TVOUT(htable,max.DICT*3*sizeof(cell),COUT('h'))
MVOUT(COUT('m'));
}
else
{
if(INTEGER(xval))
{IOUT(OUTPUT_INT(xval));}
else
{
if(!GETARITY(xval))
{SOUT(NAME(xval));}
/* operators can be handled here easily
else if(g.DIF==xval)
{
out(xref+1,wam),
SOUT(NAME(s));
out(xref+2,wam);
}
*/
else if IS_LIST(xval)
{
COUT('[');
out((cell)(++xref),wam);
++xref;
FDEREF(T2C(xref));
while(IS_LIST(xval))
{
COUT(',');
out((cell)(++xref),wam);
++xref;
FDEREF(T2C(xref));
}
if(g.NIL!=xval)
{
COUT('|');
out((cell)xref,wam);
}
COUT(']');
}
else if (BP_FLOAT(xval))
{
FLOAT_OUT(ints_to_double(
(half)(xref[1]),
(half)(xref[2]),
(half)(xref[3])));
}
else
{ register no i;
SOUT(NAME(xval));
COUT('(');
for (i=1; i<GETARITY(xval); i++)
{
out(xref[i],wam);
COUT(',');
}
out((cell)(xref+i),wam);
COUT(')');
}
}
}
int listp(int addr){
if(IS_LIST(addr) || IS_NIL(addr))
return(1);
else
return(0);
}
/**
* position must be a list
* If the list consists of two numbers (x y) the surface will be rendered at location x,y
* the same is true for (plain x y)
* (x y)
* (plain x y) x,y = numbers, rendered with top left corner at x,y with scale=1
* (full) fullscreen
* (centered)
* (scaled)
* (sized)
* (rotated)
* (windowed)
*/
Bool graphics_render_at_position(Renderable *renderable, Value position, Environment *environment) {
if (environment -> fast_run) {return false;}
profiler_start(profile_render);
Double width = renderable -> width;
Double height = renderable -> height;
Double screen_width = environment -> width;
Double screen_height = environment -> height;
cairo_save(environment -> cairo);
if (position.type == NIL) {
cairo_scale(environment -> cairo, screen_width/width, screen_height/height);
goto RENDER;
}
if (!IS_LIST(position)) {
log_error_in;
goto ERROR;
}
if (position.type != CONS) {
log_error_in;
goto ERROR;
}
Value length_val = list_length(position);
if (length_val.type != INTEGER) {
log_error_in;
goto ERROR;
}
Unt length = NUM_VAL(length_val);
Value first = NEXT(position);
if (first.type == SYMBOL) {
if (equal(first, symbols_plain)) {
/**** plain ****/
/* Render at coords, unscaled */
if (length == 3) {
Value x = NEXT(position);
Value y = NEXT(position);
if (IS_NUMERIC(x) && IS_NUMERIC(y)) {
cairo_translate(environment -> cairo, NUM_VAL(x), NUM_VAL(y));
goto RENDER;
} /* Return a specific error? */
}
} else if (equal(first, symbols_full)) {
/**** full ****/
/* Stretch image to fill entire screen */
if (length == 1) {
cairo_scale(environment -> cairo, screen_width/width, screen_height/height);
goto RENDER;
}
} else if (equal(first, symbols_centered)) {
/**** centered ****/
if (length == 3) {
Value x = NEXT(position);
Value y = NEXT(position);
if (x.type == INTEGER && y.type == INTEGER) {
/* Render offset from center */
Double dx = (screen_width - width) / 2 + NUM_VAL(x);
Double dy = (screen_height - height) / 2 + NUM_VAL(y);
cairo_translate(environment -> cairo, dx, dy);
goto RENDER;
}
if (x.type == FLOAT && y.type == FLOAT) {
/* As in sized */
Double dx = (screen_width - width) / 2 + ((screen_width - width)/2 * NUM_VAL(x));
Double dy = (screen_height - height) / 2 + ((screen_height - height)/2 * NUM_VAL(y));
cairo_translate(environment -> cairo, dx, dy);
goto RENDER;
}
} else if (length == 1) {
Double dx = (screen_width - width) / 2;
Double dy = (screen_height - height) / 2;
cairo_translate(environment -> cairo, dx, dy);
}
} else if (equal(first, symbols_scaled)) {
/**** scaled ****/
/* ('scaled x y scale) */
/* ('scaled x y scalex scaley) */
/* TODO: make it work with relative float positions */
if (length < 4 || length > 5) {
log_error_in;
goto ERROR;
}
Value x_val = NEXT(position);
Value y_val = NEXT(position);
Value scale_x = NEXT(position);
Value scale_y = scale_x;
if (length == 5) {
scale_y = NEXT(position);
}
Double new_width;
Double new_height;
if (scale_x.type == INTEGER) {
new_width = NUM_VAL(scale_x);
} else if (scale_x.type == FLOAT) {
new_width = width * NUM_VAL(scale_x);
} else {
log_error_in;
goto ERROR;
}
if (scale_y.type == INTEGER) {
new_height = NUM_VAL(scale_y);
} else if (scale_y.type == FLOAT) {
new_height = height * NUM_VAL(scale_y);
} else {
log_error_in;
goto ERROR;
}
Double x = 0;
Double y = 0;
if (x_val.type == INTEGER) {
x = NUM_VAL(x_val);
} else if (x_val.type == FLOAT) {
x = (screen_width - new_width) / 2 + ((screen_width - new_width)/2 * NUM_VAL(x_val));
} else {
log_error_in;
goto ERROR;
}
if (y_val.type == INTEGER) {
y = NUM_VAL(y_val);
} else if (y_val.type == FLOAT) {
y = (screen_height - new_height) / 2 + ((screen_height - new_height)/2 * NUM_VAL(y_val));
} else {
log_error_in;
goto ERROR;
}
cairo_translate(environment -> cairo, x, y);
cairo_scale(environment -> cairo, new_width/width, new_height/height);
goto RENDER;
} else if (equal(first, symbols_sized)) {
/**** sized ****/
/* ('sized x y sizex/boundx sizey/boundy) */
/* Render scaled but keep aspect ratio */
if (length < 4 || length > 5) {
log_error_in;
goto ERROR;
}
Value x_val = NEXT(position);
Value y_val = NEXT(position);
Value size_x = NEXT(position);
Value size_y = size_x;
if (length == 5) {
size_y = NEXT(position);
}
Double desired_width;
Double desired_height;
if (size_x.type == INTEGER) {
desired_width = NUM_VAL(size_x);
} else if (size_x.type == FLOAT) {
desired_width = screen_width * NUM_VAL(size_x);
} else {
log_error_in;
goto ERROR;
}
if (size_y.type == INTEGER) {
desired_height = NUM_VAL(size_y);
} else if (size_y.type == FLOAT) {
desired_height = screen_height * NUM_VAL(size_y);
} else {
log_error_in;
goto ERROR;
}
Double new_width;
Double new_height;
Double ratio_w = desired_width / width;
Double ratio_h = desired_height / height;
if (ratio_w <= ratio_h) {
new_height = desired_width * ((Double) height / (Double) width);
new_width = desired_width;
} else {
new_width = desired_height * ((Double) width / (Double) height);
new_height = desired_height;
}
Double x = 0;
Double y = 0;
if (x_val.type == INTEGER) {
x = NUM_VAL(x_val);
} else if (x_val.type == FLOAT) {
x = (screen_width - new_width) / 2 + ((screen_width - new_width)/2 * NUM_VAL(x_val));
} else {
log_error_in;
goto ERROR;
}
if (y_val.type == INTEGER) {
y = NUM_VAL(y_val);
} else if (y_val.type == FLOAT) {
y = (screen_height - new_height) / 2 + ((screen_height - new_height)/2 * NUM_VAL(y_val));
} else {
log_error_in;
goto ERROR;
}
cairo_translate(environment -> cairo, x, y);
cairo_scale(environment -> cairo, new_width/width, new_height/height);
goto RENDER;
} else if (equal(first, symbols_rotated)) {
/**** Rotated ****/
if (length < 4) {
log_error_in;
goto ERROR;
}
Value angle_v = NEXT(position);
if (!IS_NUMERIC(angle_v)) {
log_error_in;
goto ERROR;
}
Double angle = NUM_VAL(angle_v);
Value x = NEXT(position);
Value y = NEXT(position);
if (!IS_NUMERIC(x) || !IS_NUMERIC(y)) {
log_error_in;
goto ERROR;
}
Double dx = NUM_VAL(x);
Double dy = NUM_VAL(y);
Value scale_x;
Value scale_y;
if (length == 5) {
scale_x = NEXT(position);
scale_y = scale_x;
} else if (length == 6) {
scale_x = NEXT(position);
scale_y = NEXT(position);
} else {
log_error_in;
goto ERROR;
}
Double sx;
Double sy;
if (scale_x.type == INTEGER && scale_y.type == INTEGER) {
sx = NUM_VAL(scale_x)/width;
sy = NUM_VAL(scale_y)/height;
} else if (scale_x.type == FLOAT && scale_y.type == FLOAT) {
sx = NUM_VAL(scale_x);
sy = NUM_VAL(scale_y);
} else {
log_error_in;
goto ERROR;
}
if (sx == 0.0 || sy == 0.0) {
/* Scaled to 0, thus is not shown. Cairo freezes if given scales of 0 */
return true;
}
cairo_translate(environment -> cairo, dx, dy);
cairo_translate(environment -> cairo, sx*width/2, sx*height/2);
cairo_rotate(environment -> cairo, angle);
cairo_scale(environment -> cairo, sx, sy);
cairo_translate(environment -> cairo, -width/2, -height/2);
goto RENDER;
}
} else if (IS_NUMERIC(first) && length == 2) {/* (x y) */
Value second = NEXT(position);
if (IS_NUMERIC(second)) {
Double x = NUM_VAL(first);
Double y = NUM_VAL(second);
cairo_translate(environment -> cairo, x, y);
goto RENDER;
}
}
ERROR:
cairo_restore(environment -> cairo);
profiler_end(profile_render);
return false;
RENDER:
renderable -> render(renderable -> data, environment);
/* cairo_set_source_surface(environment -> cairo, surface, 0, 0); */
/* cairo_paint(environment -> cairo); */
cairo_restore(environment -> cairo);
profiler_end(profile_render);
return true;
}
int GAP_IsList(Obj obj)
{
return obj && IS_LIST(obj);
}
size_t
co_response_alloc(char *output, const size_t olen, const uint32_t id, const co_obj_t *error, co_obj_t *result)
{
CHECK(((output != NULL) && (error != NULL) && (result != NULL)), "Invalid response components.");
CHECK(olen > sizeof(_resp_header) + sizeof(uint32_t) + sizeof(co_str16_t) + sizeof(co_list16_t), "Output buffer too small.");
size_t written = 0;
char *cursor = NULL;
size_t s = 0;
/* Pack response header */
memmove(output + written, &_resp_header.list_type, sizeof(_resp_header.list_type));
written += sizeof(_resp_header.list_type);
memmove(output + written, &_resp_header.list_len, sizeof(_resp_header.list_len));
written += sizeof(_resp_header.list_len);
memmove(output + written, &_resp_header.type_type, sizeof(_resp_header.type_type));
written += sizeof(_resp_header.type_type);
memmove(output + written, &_resp_header.type_value, sizeof(_resp_header.type_value));
written += sizeof(_resp_header.type_value);
memmove(output + written, &_resp_header.id_type, sizeof(_resp_header.id_type));
written += sizeof(_resp_header.id_type);
/* Pack response ID */
memmove(output + written, &id, sizeof(uint32_t));
written += sizeof(uint32_t);
/* Pack error code */
//CHECK(IS_STR(error) || IS_NIL(error), "Not a valid error name.");
if(error != NULL)
{
if(IS_LIST(error))
written += co_list_raw(output + written, olen - written, error);
else if(IS_TREE(error))
{
written += co_tree_raw(output + written, olen - written, error);
}
else
{
s = co_obj_raw(&cursor, error);
memmove(output + written, cursor, s);
written += s;
}
}
/* Pack method result */
CHECK(written < olen, "Output buffer too small.");
if(result != NULL)
{
if(IS_LIST(result))
written += co_list_raw(output + written, olen - written, result);
else if(IS_TREE(result))
{
written += co_tree_raw(output + written, olen - written, result);
}
else
{
s = co_obj_raw(&cursor, result);
memmove(output + written, cursor, s);
written += s;
}
}
DEBUG("Response bytes written: %d", (int)written);
CHECK(written < olen, "Output buffer too small.");
return written;
error:
return -1;
}
size_t
co_request_alloc(char *output, const size_t olen, const co_obj_t *method, co_obj_t *param)
{
CHECK(((output != NULL) && (method != NULL)), "Invalid request components.");
CHECK(olen > sizeof(_req_header) + sizeof(uint32_t) + sizeof(co_str16_t) + sizeof(co_list16_t), "Output buffer too small.");
size_t written = 0;
char *cursor = NULL;
size_t s = 0;
/* Pack request header */
memmove(output + written, &_req_header.list_type, sizeof(_req_header.list_type));
written += sizeof(_req_header.list_type);
memmove(output + written, &_req_header.list_len, sizeof(_req_header.list_len));
written += sizeof(_req_header.list_len);
memmove(output + written, &_req_header.type_type, sizeof(_req_header.type_type));
written += sizeof(_req_header.type_type);
memmove(output + written, &_req_header.type_value, sizeof(_req_header.type_value));
written += sizeof(_req_header.type_value);
memmove(output + written, &_req_header.id_type, sizeof(_req_header.id_type));
written += sizeof(_req_header.id_type);
/* Pack request ID */
memmove(output + written, &_id, sizeof(uint32_t));
written += sizeof(uint32_t);
_id++;
/* Pack method call */
CHECK(IS_STR(method), "Not a valid method name.");
char *buffer = NULL;
size_t buffer_write = co_obj_raw(&buffer, method);
CHECK(buffer_write >= 0, "Failed to pack object.");
memmove(output + written, buffer, buffer_write);
written += buffer_write;
/* Pack parameters */
CHECK(written < olen, "Output buffer too small.");
if(param != NULL)
{
if(IS_LIST(param))
written += co_list_raw(output + written, olen - written, param);
else
{
s = co_obj_raw(&cursor, param);
written += s;
memmove(output + written, cursor, s);
}
}
CHECK(written >= 0, "Failed to pack object.");
DEBUG("Request bytes written: %d", (int)written);
CHECK(written < olen, "Output buffer too small.");
return written;
error:
return -1;
}
struct atom *eval(struct atom *expr, struct env *env)
{
// symbols and not-a-lists are evaluated or returned directly
if (IS_SYM(expr))
{
struct atom *atom = env_lookup(env, expr->str.str);
if (atom)
{
return atom;
}
else
{
printf("error: undefined variable: %s\n",
expr->str.str);
return &nil_atom;
}
}
if (!IS_LIST(expr))
return expr;
struct list *list = expr->list;
struct atom *op = LIST_FIRST(list);
// Check if the first elem is not a symbol or a closure. If it's
// not, then we'll evaluate it (it could be a lambda form).
if (!IS_SYM(op) && !IS_CLOSURE(op))
{
struct atom *evaluated_op = eval(op, env);
// Replace the evaluated one to the list!
LIST_REMOVE(op, entries);
LIST_INSERT_HEAD(list, evaluated_op, entries);
op = evaluated_op;
}
// If the first elem is a symbol, it should be a name for a builtin
// function or a closure bound to that name by the user. If the
// first argument is directly a closure, eval that with the args.
if (IS_SYM(op))
{
struct builtin_function_def *def = builtin_function_defs;
while (def->name && def->fn)
{
if (strcmp(op->str.str, def->name) == 0)
{
return def->fn(expr, env);
}
++def;
}
struct atom *closure = env_lookup(env, op->str.str);
if (closure)
{
return eval_closure(closure, CDR(op), env);
}
printf("error: unknown function %s\n", op->str.str);
}
else if (IS_CLOSURE(op))
{
return eval_closure(op, CDR(op), env);
}
printf("error: cannot evaluate\n");
return &nil_atom;
}
