static int s_hash_item(lv_t *item) {
assert(item);
if(item->type == l_str)
return murmurhash2(L_STR(item), strlen(L_STR(item)), 0);
if(item->type == l_sym)
return murmurhash2(L_SYM(item), strlen(L_SYM(item)), 0);
assert(0);
}
/**
* c helper for equalp
*/
int c_equalp(lv_t *a1, lv_t *a2) {
int result = 0;
if(a1->type != a2->type)
return 0;
switch(a1->type) {
case l_int:
result = (mpz_cmp(L_INT(a1), L_INT(a2)) == 0);
break;
case l_float:
result = (mpfr_cmp(L_FLOAT(a1), L_FLOAT(a2)) == 0);
break;
case l_bool:
if((L_BOOL(a1) == 0 && L_BOOL(a2) == 0) ||
(L_BOOL(a1) != 0 && L_BOOL(a1) != 0))
result = 1;
break;
case l_sym:
if(strcmp(L_SYM(a1), L_SYM(a2)) == 0)
result = 1;
break;
case l_str:
if(strcmp(L_STR(a1), L_STR(a2)) == 0)
result = 1;
break;
case l_hash:
result = (L_HASH(a1) == L_HASH(a2));
break;
case l_null:
result = 1;
break;
case l_fn:
result = (L_FN(a1) == L_FN(a1));
break;
case l_pair:
/* this is perhaps not right */
if(!(c_equalp(L_CAR(a1), L_CAR(a2))))
return 0;
if(L_CDR(a1) && L_CDR(a2))
return c_equalp(L_CDR(a1), L_CDR(a2));
if(!L_CDR(a1) && !L_CDR(a2))
return 1;
result = 0;
break;
}
return result;
}
lv_t *p_load(lexec_t *exec, lv_t *v) {
assert(v && exec);
rt_assert(c_list_length(v) == 1, le_arity, "load arity");
rt_assert(L_CAR(v)->type == l_str, le_type, "filename must be string");
return c_sequential_eval(exec, c_parse_file(exec, L_STR(L_CAR(v))));
}
/**
* dup an object
*/
lv_t *lisp_dup_item(lv_t *v) {
lv_t *r;
lv_t *vptr = v;
lv_t *rptr;
assert(v);
switch(v->type) {
case l_int:
r = lisp_create_int(0);
mpz_set(L_INT(r), L_INT(v));
return r;
case l_rational:
r = lisp_create_rational(1, 1);
mpq_set(L_RAT(r), L_RAT(v));
return r;
case l_float:
r = lisp_create_float(0.0);
mpfr_set(L_FLOAT(r), L_FLOAT(v), MPFR_ROUND_TYPE);
return r;
case l_bool:
return v;
case l_sym:
return lisp_create_symbol(L_SYM(v));
case l_str:
return lisp_create_string(L_STR(v));
case l_null:
return v;
case l_port:
/* can't really copy this -- it's a socket or a file
handle, or something else. */
return v;
case l_char:
return lisp_create_char(L_CHAR(v));
case l_fn:
/* can't really copy this either, but it's essentially
immutable */
return v;
case l_err:
return lisp_create_err(L_ERR(v));
case l_hash:
/* FIXME: should really be a copy */
return v;
case l_pair:
r = lisp_create_pair(NULL, NULL);
rptr = r;
while(vptr && L_CAR(vptr)) {
L_CAR(rptr) = lisp_dup_item(L_CAR(vptr));
vptr = L_CDR(vptr);
if(vptr) {
L_CDR(rptr) = lisp_create_pair(NULL, NULL);
rptr = L_CDR(rptr);
}
}
return r;
}
assert(0);
}
void repl(int level) {
char prompt[30];
char *cmd;
int quit = 0;
int line = 1;
lv_t *parsed_value;
lv_t *env_sym;
lv_t *result;
lv_t *arg;
lv_t *str;
char sym_buf[20];
lexec_t *exec;
exec = lisp_context_new(5); /* get r5rs environment */
while(!quit) {
snprintf(prompt, sizeof(prompt), "%d:%d> ", level, line);
// r!
cmd = readline(prompt);
if(!cmd) {
printf("\n");
quit = 1;
break;
}
if(!*cmd)
continue;
parsed_value = lisp_parse_string(cmd);
if(!parsed_value) {
fprintf(stderr, "synax error\n");
continue;
}
// e!
result = lisp_execute(exec, parsed_value);
// p!
if(result && !is_nil(result)) {
sprintf(sym_buf, "$%d", line);
env_sym = lisp_create_symbol(sym_buf);
c_hash_insert(L_CAR(exec->env), env_sym, result);
dprintf(1, "%s = ", sym_buf);
str = lisp_str_from_value(result);
printf("%s\n", L_STR(str));
}
// and l. ;)
add_history(cmd);
free(cmd);
line++;
}
}
void compile_attr_name(COMPILATION_CONTEXT *ctx, ast_node *node, char **buf, size_t *idx, size_t *allocated, int need_result) {
if(!need_result) {
return;
}
if(node->type != IDENTIFIER_NODE) {
compile_main_section(ctx, node, buf, idx, allocated, NEED_RESULT);
return;
}
OPCODE(*buf, OP_PUSH_L_STR);
L_STR(*buf, node->name);
}
lv_t *lisp_create_type(void *value, lisp_type_t type) {
lv_t *result;
result = safe_malloc(sizeof(lv_t));
result->type = type;
result->row = 0;
result->col = 0;
result->file = NULL;
switch(type) {
case l_char:
L_CHAR(result) = *((char*)value);
break;
case l_int:
mpz_init(L_INT(result));
mpz_set_si(L_INT(result), *(int64_t *)value);
break;
case l_rational:
mpq_init(L_RAT(result));
break;
case l_float:
mpfr_init(L_FLOAT(result));
mpfr_set_d(L_FLOAT(result), *(double*)value, MPFR_ROUND_TYPE);
break;
case l_bool:
L_BOOL(result) = *((int*)value);
break;
case l_sym:
L_SYM(result) = safe_strdup((char*)value);
break;
case l_str:
L_STR(result) = safe_strdup((char*)value);
break;
case l_err:
L_ERR(result) = *((lisp_errsubtype_t *)value);
break;
case l_fn:
L_FN(result) = (lisp_method_t)value;
break;
case l_port:
L_PORT(result) = (port_info_t *)value;
break;
default:
assert(0);
fprintf(stderr, "Bad type");
exit(EXIT_FAILURE);
}
return result;
}
/**
* (write obj)
* (write obj port)
*
* write a representation of obj to the given port
* (or current-output-port if unspecified)
*
* returns nil
*/
lv_t *p_write(lexec_t *exec, lv_t *v) {
lv_t *str;
assert(v && exec);
rt_assert(c_list_length(v) == 1, le_arity, "display arity");
str = lisp_str_from_value(exec, L_CAR(v), 0);
fprintf(stdout, "%s", L_STR(str));
fflush(stdout);
return lisp_create_null();
}
/**
* print a value to a fd, in a debug form
*/
void lisp_dump_value(int fd, lv_t *v, int level) {
switch(v->type) {
case l_null:
dprintf(fd, "()");
break;
case l_int:
dprintf(fd, "%" PRIu64, L_INT(v));
break;
case l_float:
dprintf(fd, "%0.16g", L_FLOAT(v));
break;
case l_bool:
dprintf(fd, "%s", L_BOOL(v) ? "#t": "#f");
break;
case l_sym:
dprintf(fd, "%s", L_SYM(v));
break;
case l_str:
dprintf(fd, "\"%s\"", L_STR(v));
break;
case l_char:
dprintf(fd, "#\%02x", L_CHAR(v));
break;
case l_pair:
dprintf(fd, "(");
lv_t *vp = v;
while(vp && L_CAR(vp)) {
lisp_dump_value(fd, L_CAR(vp), level + 1);
if(L_CDR(vp) && (L_CDR(vp)->type != l_pair)) {
dprintf(fd, " . ");
lisp_dump_value(fd, L_CDR(vp), level + 1);
vp = NULL;
} else {
vp = L_CDR(vp);
dprintf(fd, "%s", vp ? " " : "");
}
}
dprintf(fd, ")");
break;
case l_fn:
if(L_FN(v) == NULL)
dprintf(fd, "<lambda@%p>", v);
else
dprintf(fd, "<built-in@%p>", v);
break;
default:
// missing a type check.
assert(0);
}
}
/**
* given a string format specifier, create a new
* string with the correct format
*/
lv_t *p_format(lexec_t *exec, lv_t *v) {
lv_t *current_arg = NULL;
char *format, *current;
char *return_buffer, *return_ptr;
int len;
assert(v && exec);
/* make sure the format string is a string */
rt_assert(L_CAR(v)->type == l_str, le_type, "bad format specifier");
format = L_STR(L_CAR(v));
current = format;
current_arg = L_CDR(v);
/* first, find out how long the destination string
* must be, using the lisp_snprintf stuff */
len = 0;
while(*current) {
if(*current != '~') {
len++;
} else {
current++;
switch(*current) {
case 'A':
case 'S':
rt_assert(current_arg && L_CAR(current_arg),
le_arity, "insufficient args");
len += lisp_snprintf(exec, NULL, 0, L_CAR(current_arg), 1);
current_arg = L_CDR(current_arg);
break;
case '~':
case '%':
len++;
break;
default:
rt_assert(0, le_syntax, "bad format specifier");
}
}
current++;
}
fprintf(stderr, "propsed len: %d\n", len);
current = format;
current_arg = L_CDR(v);
return_buffer = safe_malloc(len + 1);
return_ptr = return_buffer;
memset(return_buffer, 0, sizeof(return_buffer));
int item_len = 0;
while(*current) {
if(*current != '~') {
*return_ptr = *current;
return_ptr++;
} else {
current++;
if(*current == 'A' ||
*current == 'S') {
item_len = lisp_snprintf(exec, return_ptr,
len - (return_ptr - return_buffer) + 1,
L_CAR(current_arg), 1);
current_arg = L_CDR(current_arg);
return_ptr += item_len;
} else if (*current == '~') {
*return_ptr = '~';
return_ptr++;
} else if (*current == '%') {
*return_ptr = '\n';
return_ptr++;
} else {
rt_assert(0, le_syntax, "bad format specifier");
}
}
current++;
}
/* FIXME: need a non-strduping create_string */
return lisp_create_string(return_buffer);
}
/**
* print the object specified by v in the provided buffer.
* follows standard snprintf rules, in that it returns the
* number of bytes required to print if an insufficient buffer
* length is provided.
*
* if display is true, then the results are printed as human
* readable (p_display), otherwise it is printed as machine
* readable (p_write)
*/
int lisp_snprintf(lexec_t *exec, char *buf, int len, lv_t *v, int display) {
int pair_len = 0;
switch(v->type) {
case l_null:
return snprintf(buf, len, "()");
case l_int:
/* return snprintf(buf, len, "%" PRIu64, L_INT(v)); */
return gmp_snprintf(buf, len, "%Zd", L_INT(v));
case l_rational:
return gmp_snprintf(buf, len, "%Qd", L_RAT(v));
case l_float:
/* return snprintf(buf, len, "%0.16g", L_FLOAT(v)); */
return mpfr_snprintf(buf, len, "%Rg", L_FLOAT(v));
case l_bool:
return snprintf(buf, len, "%s", L_BOOL(v) ? "#t": "#f");
case l_sym:
return snprintf(buf, len, "%s", L_SYM(v));
case l_str:
if(display)
return snprintf(buf, len, "%s", L_STR(v));
else
return snprintf(buf, len, "\"%s\"", L_STR(v));
case l_pair:
if(len >= 1)
sprintf(buf, "(");
pair_len += 1;
lv_t *vp = v;
while(vp && L_CAR(vp)) {
pair_len += lisp_snprintf(exec, buf + pair_len,
(len - pair_len) > 0 ? len - pair_len : 0,
L_CAR(vp), display);
if(L_CDR(vp) && (L_CDR(vp)->type != l_pair)) {
pair_len += snprintf(buf + pair_len,
(len - pair_len) > 0 ? len - pair_len : 0,
" . ");
pair_len += lisp_snprintf(exec, buf + pair_len,
(len - pair_len) > 0 ? len - pair_len : 0,
L_CDR(vp), display);
vp = NULL;
} else {
vp = L_CDR(vp);
if(vp) {
if (len - pair_len > 0)
snprintf(buf + pair_len, len - pair_len, " ");
pair_len++;
}
}
}
if (len - pair_len > 0) {
sprintf(buf + pair_len, ")");
}
pair_len++;
return pair_len;
break;
case l_fn:
rt_assert(!display, le_type, "cannot display function types");
if(L_FN(v) == NULL)
return snprintf(buf, len, "<lambda@%p>", v);
else
return snprintf(buf, len, "<built-in@%p>", v);
break;
case l_char:
if(display)
return snprintf(buf, len, "%c", L_CHAR(v));
else
return snprintf(buf, len, "#\\x%02x", L_CHAR(v));
break;
case l_port:
rt_assert(!display, le_type, "cannot display port types");
return snprintf(buf, len, "<port@%p>", v);
break;
case l_err:
rt_assert(!display, le_type, "cannot display error types");
return snprintf(buf, len, "<error@%p:%d>", v, L_ERR(v));
break;
default:
// missing a type check.
assert(0);
}
}
void compile_main_section(COMPILATION_CONTEXT *ctx, ast_node *node, char **buf, size_t *idx, size_t *allocated, int need_result) {
ast_node *ptr;
int argc, have_arr_splat, have_hash_splat, params_flags;
int doing_named_args = 0;
LOCAL_VAR_INDEX n_locals, n_params_required, n_params_optional;
UPVAR_INDEX n_uplevels;
size_t loop_beg_idx, cond_jump, continue_target_idx, func_jump, end_of_func_idx, if_jump, while_jump;
int old_break_addrs_ptr, old_continue_addrs_ptr, i, saved_stack_depth;
ensure_room(buf, *idx, allocated, 1024); // XXX - magic number
// printf("compile_main_section() node=%p type=%s last_child=%p need_result=%d\n", node, NGS_AST_NODE_TYPES_NAMES[node->type], node->last_child, need_result);
if(node->location.first_line) {
source_tracking_entry *ste = NULL;
// printf("LOC: ip=%lu\n %d:%d %d:%d\n", *idx, node->location.first_line, node->location.first_column, node->location.last_line, node->location.last_column);
if(ctx->source_tracking_entries_count) {
if(ctx->source_tracking_entries[ctx->source_tracking_entries_count-1].ip == *idx) {
// Override because deeper ast nodes have more precise location
ste = &ctx->source_tracking_entries[ctx->source_tracking_entries_count-1];
} else {
ste = NULL;
}
}
if(!ste) {
if (ctx->source_tracking_entries_count == ctx->source_tracking_entries_allocated) {
ctx->source_tracking_entries_allocated *= 2;
ctx->source_tracking_entries = NGS_REALLOC(ctx->source_tracking_entries, ctx->source_tracking_entries_allocated * sizeof(source_tracking_entry));
}
ste = &ctx->source_tracking_entries[ctx->source_tracking_entries_count++];
}
ste->source_file_name_idx = 0; // XXX: currently only one source file per compile() is supported
ste->ip = *idx;
ste->source_location[0] = node->location.first_line;
ste->source_location[1] = node->location.first_column;
ste->source_location[2] = node->location.last_line;
ste->source_location[3] = node->location.last_column;
}
switch(node->type) {
case CALL_NODE:
DEBUG_COMPILER("COMPILER: %s %zu\n", "CALL NODE", *idx);
OPCODE(*buf, OP_PUSH_NULL); // Placeholder for return value
saved_stack_depth = STACK_DEPTH;
STACK_DEPTH++;
// print_ast(node, 0);
assert(node->first_child->next_sibling->type == ARGS_NODE);
for(ptr=node->first_child->next_sibling->first_child, have_arr_splat=0, have_hash_splat=0; ptr; ptr=ptr->next_sibling) {
assert(ptr->type == ARG_NODE);
if(ptr->first_child->type == ARR_SPLAT_NODE) {
have_arr_splat = 1;
}
if(ptr->first_child->type == HASH_SPLAT_NODE) {
have_hash_splat = 1;
}
}
if(have_arr_splat) {
OPCODE(*buf, OP_PUSH_INT); DATA_INT(*buf, 0);
OPCODE(*buf, OP_MAKE_ARR);
STACK_DEPTH++;
}
doing_named_args = 0;
argc = 0;
if(node->first_child->type == ATTR_NODE) {
compile_main_section(ctx, node->first_child->first_child, buf, idx, allocated, NEED_RESULT);
if(have_arr_splat) {
OPCODE(*buf, OP_ARR_APPEND);
}
argc++;
}
for(ptr=node->first_child->next_sibling->first_child; ptr; ptr=ptr->next_sibling) {
assert(ptr->type == ARG_NODE);
if(ptr->first_child->next_sibling) {
// Got named argument
if(!doing_named_args) {
// Setup named arguments
doing_named_args = 1;
// TODO: maybe special opcode for creating an empty hash?
OPCODE(*buf, OP_PUSH_INT); DATA_INT(*buf, 0);
OPCODE(*buf, OP_MAKE_HASH);
STACK_DEPTH++;
argc++;
}
// argument name
compile_main_section(ctx, ptr->first_child->next_sibling, buf, idx, allocated, NEED_RESULT);
// argument value
compile_main_section(ctx, ptr->first_child, buf, idx, allocated, NEED_RESULT);
OPCODE(*buf, OP_HASH_SET);
continue;
}
if(ptr->first_child->type == ARR_SPLAT_NODE) {
assert(!doing_named_args);
compile_main_section(ctx, ptr->first_child->first_child, buf, idx, allocated, NEED_RESULT);
OPCODE(*buf, OP_TO_ARR);
OPCODE(*buf, OP_ARR_CONCAT);
continue;
}
if(ptr->first_child->type == HASH_SPLAT_NODE) {
if(!doing_named_args) {
// Setup named arguments
doing_named_args = 1;
// TODO: maybe special opcode for creating an empty hash?
OPCODE(*buf, OP_PUSH_INT); DATA_INT(*buf, 0);
OPCODE(*buf, OP_MAKE_HASH);
argc++;
}
compile_main_section(ctx, ptr->first_child->first_child, buf, idx, allocated, NEED_RESULT);
OPCODE(*buf, OP_HASH_UPDATE);
continue;
}
assert(!doing_named_args);
compile_main_section(ctx, ptr->first_child, buf, idx, allocated, NEED_RESULT);
STACK_DEPTH++;
argc++;
if(have_arr_splat) {
OPCODE(*buf, ptr->first_child->type == ARR_SPLAT_NODE ? OP_ARR_CONCAT : OP_ARR_APPEND);
}
}
if(doing_named_args) {
// Marker at the end
OPCODE(*buf, OP_PUSH_KWARGS_MARKER);
argc++;
if(have_arr_splat) {
OPCODE(*buf, OP_ARR_APPEND);
}
}
if(!have_arr_splat) {
assert(argc <= MAX_ARGS); // TODO: Exception
OPCODE(*buf, OP_PUSH_INT); DATA(*buf, argc);
STACK_DEPTH++;
}
if(node->first_child->type == ATTR_NODE) {
// printf("---\n");
// print_ast(node->first_child->first_child->next_sibling, 0);
compile_main_section(ctx, node->first_child->first_child->next_sibling, buf, idx, allocated, NEED_RESULT);
} else {
compile_main_section(ctx, node->first_child, buf, idx, allocated, NEED_RESULT);
}
OPCODE(*buf, have_arr_splat ? OP_CALL_ARR : OP_CALL);
POP_IF_DONT_NEED_RESULT(*buf);
STACK_DEPTH = saved_stack_depth;
break;
case INDEX_NODE:
case ATTR_NODE:
DEBUG_COMPILER("COMPILER: %s %zu\n", "INDEX NODE", *idx);
OPCODE(*buf, OP_PUSH_NULL); // Placeholder for return value
saved_stack_depth = STACK_DEPTH;
STACK_DEPTH++;
compile_main_section(ctx, node->first_child, buf, idx, allocated, NEED_RESULT);
STACK_DEPTH++;
if(node->type == ATTR_NODE) {
compile_attr_name(ctx, node->first_child->next_sibling, buf, idx, allocated, NEED_RESULT);
} else {
compile_main_section(ctx, node->first_child->next_sibling, buf, idx, allocated, NEED_RESULT);
}
STACK_DEPTH++;
OPCODE(*buf, OP_PUSH_INT); DATA_INT(*buf, 2);
STACK_DEPTH++;
compile_identifier(ctx, buf, idx, node->type == INDEX_NODE ? "[]" : ".", OP_FETCH_LOCAL, OP_FETCH_UPVAR, OP_FETCH_GLOBAL);
OPCODE(*buf, OP_CALL);
POP_IF_DONT_NEED_RESULT(*buf);
STACK_DEPTH = saved_stack_depth;
break;
case INT_NODE:
/*printf("Compiling tNUMBER @ %d\n", *idx);*/
if(need_result) {
OPCODE(*buf, OP_PUSH_INT); DATA(*buf, node->number);
}
break;
case REAL_NODE:
if(need_result) {
OPCODE(*buf, OP_PUSH_REAL); DATA(*buf, *(NGS_REAL *)node->data);
}
break;
case IDENTIFIER_NODE:
compile_identifier(ctx, buf, idx, node->name, OP_FETCH_LOCAL, OP_FETCH_UPVAR, OP_FETCH_GLOBAL);
POP_IF_DONT_NEED_RESULT(*buf);
break;
case ASSIGNMENT_NODE:
ptr = node->first_child;
switch(ptr->type) {
case IDENTIFIER_NODE:
DEBUG_COMPILER("COMPILER: %s %zu\n", "identifier <- expression", *idx);
compile_main_section(ctx, ptr->next_sibling, buf, idx, allocated, NEED_RESULT);
DUP_IF_NEED_RESULT(*buf);
compile_identifier(ctx, buf, idx, ptr->name, OP_STORE_LOCAL, OP_STORE_UPVAR, OP_STORE_GLOBAL);
break;
case INDEX_NODE:
OPCODE(*buf, OP_PUSH_NULL); // Placeholder for return value
compile_main_section(ctx, ptr->first_child, buf, idx, allocated, NEED_RESULT);
compile_main_section(ctx, ptr->first_child->next_sibling, buf, idx, allocated, NEED_RESULT);
compile_main_section(ctx, node->first_child->next_sibling, buf, idx, allocated, NEED_RESULT);
OPCODE(*buf, OP_PUSH_INT); DATA_INT(*buf, 3);
compile_identifier(ctx, buf, idx, "[]=", OP_FETCH_LOCAL, OP_FETCH_UPVAR, OP_FETCH_GLOBAL);
OPCODE(*buf, OP_CALL);
POP_IF_DONT_NEED_RESULT(*buf);
break;
case ATTR_NODE:
OPCODE(*buf, OP_PUSH_NULL); // Placeholder for return value
compile_main_section(ctx, ptr->first_child, buf, idx, allocated, NEED_RESULT);
compile_attr_name(ctx, ptr->first_child->next_sibling, buf, idx, allocated, NEED_RESULT);
compile_main_section(ctx, node->first_child->next_sibling, buf, idx, allocated, NEED_RESULT);
OPCODE(*buf, OP_PUSH_INT); DATA_INT(*buf, 3);
compile_identifier(ctx, buf, idx, ".=", OP_FETCH_LOCAL, OP_FETCH_UPVAR, OP_FETCH_GLOBAL);
OPCODE(*buf, OP_CALL);
POP_IF_DONT_NEED_RESULT(*buf);
break;
default:
assert(0=="compile_main_section(): assignment to unknown node type");
}
break;
case EXPRESSIONS_NODE:
if(!node->first_child && need_result) {
OPCODE(*buf, OP_PUSH_NULL);
break;
}
for(ptr=node->first_child; ptr; ptr=ptr->next_sibling) {
// printf("EXPRESSIONS_NODE ptr=%p type=%s need_result=%d will_do_result=%d\n", ptr, NGS_AST_NODE_TYPES_NAMES[ptr->type], need_result, (ptr == node->last_child) && need_result);
compile_main_section(ctx, ptr, buf, idx, allocated, (!ptr->next_sibling) && need_result);
}
break;
case FOR_NODE:
// setup
compile_main_section(ctx, node->first_child, buf, idx, allocated, DONT_NEED_RESULT);
// condition
loop_beg_idx = *idx;
compile_main_section(ctx, node->first_child->next_sibling, buf, idx, allocated, NEED_RESULT);
OPCODE(*buf, OP_JMP_FALSE);
cond_jump = *idx;
DATA_JUMP_OFFSET_PLACEHOLDER(*buf);
// body
SETUP_ADDRESS_FILLING();
compile_main_section(ctx, node->first_child->next_sibling->next_sibling->next_sibling, buf, idx, allocated, DONT_NEED_RESULT);
// increment
continue_target_idx = *idx;
compile_main_section(ctx, node->first_child->next_sibling->next_sibling, buf, idx, allocated, DONT_NEED_RESULT);
// jump to condition
OPCODE(*buf, OP_JMP);
assert(*idx - cond_jump < 0x7FFF);
*(JUMP_OFFSET *)&(*buf)[cond_jump] = *idx - cond_jump;
assert((*idx - loop_beg_idx) < 0x7FFF);
DATA_JUMP_OFFSET(*buf, -(*idx - loop_beg_idx + sizeof(JUMP_OFFSET)));
HANDLE_ADDRESS_FILLING();
if(need_result) OPCODE(*buf, OP_PUSH_NULL);
break;
case EMPTY_NODE:
break;
case ARR_LIT_NODE:
DEBUG_COMPILER("COMPILER: %s %zu\n", "ARRAY NODE", *idx);
for(ptr=node->first_child, have_arr_splat=0; ptr; ptr=ptr->next_sibling) {
if(ptr->type == ARR_SPLAT_NODE) {
have_arr_splat = 1;
break;
}
}
if(have_arr_splat) {
OPCODE(*buf, OP_PUSH_INT); DATA_INT(*buf, 0);
OPCODE(*buf, OP_MAKE_ARR);
}
for(argc=0, ptr=node->first_child; ptr; argc++, ptr=ptr->next_sibling) {
if(ptr->type == ARR_SPLAT_NODE) {
compile_main_section(ctx, ptr->first_child, buf, idx, allocated, NEED_RESULT);
OPCODE(*buf, OP_TO_ARR);
} else {
compile_main_section(ctx, ptr, buf, idx, allocated, NEED_RESULT);
}
if(have_arr_splat) {
OPCODE(*buf, ptr->type == ARR_SPLAT_NODE ? OP_ARR_CONCAT : OP_ARR_APPEND);
}
}
if(!have_arr_splat) {
OPCODE(*buf, OP_PUSH_INT); DATA(*buf, argc);
OPCODE(*buf, OP_MAKE_ARR);
}
POP_IF_DONT_NEED_RESULT(*buf);
break;
case FUNC_NODE:
// FUNC_NODE children: arguments, body
DEBUG_COMPILER("COMPILER: %s %zu\n", "FUNC NODE", *idx);
OPCODE(*buf, OP_JMP);
func_jump = *idx;
DATA_JUMP_OFFSET_PLACEHOLDER(*buf);
ctx->locals_ptr++;
assert(ctx->locals_ptr < COMPILE_MAX_FUNC_DEPTH);
LOCALS = NULL;
IDENTIFIERS_SCOPES = NULL;
N_LOCALS = 0;
N_UPLEVELS = 0;
STACK_DEPTH = 0;
params_flags = 0;
// Arguments
for(ptr=node->first_child->first_child; ptr; ptr=ptr->next_sibling) {
// ptr children: identifier, type, (default value | splat indicator)
register_local_var(ctx, ptr->first_child->name);
}
// Body
register_local_vars(ctx, node->first_child->next_sibling);
compile_main_section(ctx, node->first_child->next_sibling, buf, idx, allocated, NEED_RESULT);
n_locals = N_LOCALS;
n_uplevels = N_UPLEVELS;
ctx->locals_ptr--;
OPCODE(*buf, OP_RET);
end_of_func_idx = *idx;
// Arguments' types and default values
for(ptr=node->first_child->first_child, n_params_required=0, n_params_optional=0; ptr; ptr=ptr->next_sibling) {
// ptr children: identifier, type, (default value | splat indicator)
OPCODE(*buf, OP_PUSH_L_STR);
L_STR(*buf, ptr->first_child->name);
// printf("PT 0 %s\n", ptr->first_child->name);
compile_main_section(ctx, ptr->first_child->next_sibling, buf, idx, allocated, NEED_RESULT);
if(ptr->first_child->next_sibling->next_sibling) {
// Either array/hash splat or default value
if(ptr->first_child->next_sibling->next_sibling->type == ARR_SPLAT_NODE) {
if(ptr->next_sibling && (ptr->next_sibling->first_child->next_sibling->next_sibling->type != HASH_SPLAT_NODE)) {
assert(0 == "splat function parameter must be the last one or followed by keyword splat only");
}
params_flags |= PARAMS_FLAG_ARR_SPLAT;
continue;
}
if(ptr->first_child->next_sibling->next_sibling->type == HASH_SPLAT_NODE) {
if(ptr->next_sibling) {
assert(0 == "keyword splat function parameter must be the last one");
}
params_flags |= PARAMS_FLAG_HASH_SPLAT;
continue;
}
// Splat's handled, we have default value
compile_main_section(ctx, ptr->first_child->next_sibling->next_sibling, buf, idx, allocated, NEED_RESULT);
n_params_optional++;
continue;
}
// Optional parameters can not be followed by required parameters
assert(n_params_optional == 0);
n_params_required++;
}
*(JUMP_OFFSET *)&(*buf)[func_jump] = (end_of_func_idx - func_jump - sizeof(JUMP_OFFSET));
OPCODE(*buf, OP_MAKE_CLOSURE);
DATA_JUMP_OFFSET(*buf, -(*idx - func_jump + 3*sizeof(LOCAL_VAR_INDEX) + sizeof(UPVAR_INDEX) + sizeof(int)));
DATA_N_LOCAL_VARS(*buf, n_params_required);
DATA_N_LOCAL_VARS(*buf, n_params_optional);
DATA_N_LOCAL_VARS(*buf, n_locals);
DATA_N_UPVAR_INDEX(*buf, n_uplevels);
DATA_INT(*buf, params_flags);
// Doc
compile_main_section(ctx, node->first_child->next_sibling->next_sibling, buf, idx, allocated, NEED_RESULT);
OPCODE(*buf, OP_SET_CLOSURE_DOC);
// Name
if(node->first_child->next_sibling->next_sibling->next_sibling) {
// Function has a name
compile_identifier(ctx, buf, idx, node->first_child->next_sibling->next_sibling->next_sibling->name, OP_DEF_LOCAL_FUNC, OP_DEF_UPVAR_FUNC, OP_DEF_GLOBAL_FUNC);
OPCODE(*buf, OP_SET_CLOSURE_NAME);
L_STR(*buf, node->first_child->next_sibling->next_sibling->next_sibling->name);
}
POP_IF_DONT_NEED_RESULT(*buf);
break;
case STR_COMPS_NODE:
for(argc=0, ptr=node->first_child; ptr; argc++, ptr=ptr->next_sibling) {
compile_main_section(ctx, ptr, buf, idx, allocated, NEED_RESULT);
if(ptr->type != STR_COMP_IMM_NODE) {
OPCODE(*buf, OP_TO_STR);
}
}
switch(argc) {
case 0:
OPCODE(*buf, OP_PUSH_EMPTY_STR);
break;
case 1:
break;
default:
OPCODE(*buf, OP_PUSH_INT);
DATA_INT(*buf, argc);
OPCODE(*buf, OP_MAKE_STR);
}
POP_IF_DONT_NEED_RESULT(*buf);
break;
case STR_COMP_IMM_NODE:
OPCODE(*buf, OP_PUSH_L_STR);
L_STR(*buf, node->name);
break;
case NULL_NODE: if(need_result) { OPCODE(*buf, OP_PUSH_NULL); } break;
case TRUE_NODE: if(need_result) { OPCODE(*buf, OP_PUSH_TRUE); } break;
case FALSE_NODE: if(need_result) { OPCODE(*buf, OP_PUSH_FALSE); } break;
case DEFINED_NODE:
compile_identifier(ctx, buf, idx, node->first_child->name, OP_LOCAL_DEF_P, OP_UPVAR_DEF_P, OP_GLOBAL_DEF_P);
POP_IF_DONT_NEED_RESULT(*buf);
break;
case IF_NODE:
compile_main_section(ctx, node->first_child, buf, idx, allocated, NEED_RESULT);
OPCODE(*buf, OP_TO_BOOL);
OPCODE(*buf, OP_JMP_FALSE);
if_jump = *idx;
DATA_JUMP_OFFSET_PLACEHOLDER(*buf);
compile_main_section(ctx, node->first_child->next_sibling, buf, idx, allocated, need_result);
OPCODE(*buf, OP_JMP);
DATA_JUMP_OFFSET_PLACEHOLDER(*buf);
*(JUMP_OFFSET *)&(*buf)[if_jump] = *idx - if_jump - sizeof(JUMP_OFFSET); // Jump is OP_JMP_FALSE JUMP_OFFSET shorter
if_jump = *idx - sizeof(JUMP_OFFSET);
compile_main_section(ctx, node->first_child->next_sibling->next_sibling, buf, idx, allocated, need_result);
*(JUMP_OFFSET *)&(*buf)[if_jump] = *idx - if_jump - sizeof(JUMP_OFFSET);
break;
case WHILE_NODE:
loop_beg_idx = *idx;
compile_main_section(ctx, node->first_child, buf, idx, allocated, NEED_RESULT);
OPCODE(*buf, OP_TO_BOOL);
OPCODE(*buf, OP_JMP_FALSE);
while_jump = *idx;
DATA_JUMP_OFFSET_PLACEHOLDER(*buf);
SETUP_ADDRESS_FILLING();
continue_target_idx = *idx; // For HANDLE_ADDRESS_FILLING
compile_main_section(ctx, node->first_child->next_sibling, buf, idx, allocated, DONT_NEED_RESULT);
OPCODE(*buf, OP_JMP);
DATA_JUMP_OFFSET(*buf, -(*idx - loop_beg_idx + sizeof(JUMP_OFFSET)));
*(JUMP_OFFSET *)&(*buf)[while_jump] = *idx - while_jump - sizeof(JUMP_OFFSET);
HANDLE_ADDRESS_FILLING();
if(need_result) { OPCODE(*buf, OP_PUSH_NULL); }
break;
case LOCAL_NODE:
case UPVAR_NODE:
case GLOBAL_NODE:
for(ptr=node->first_child; ptr; ptr=ptr->next_sibling) {
if(ptr->type != IDENTIFIER_NODE) {
compile_main_section(ctx, ptr, buf, idx, allocated, DONT_NEED_RESULT);
}
}
if(need_result) { OPCODE(*buf, OP_PUSH_NULL); }
break;
case HASH_LIT_NODE:
DEBUG_COMPILER("COMPILER: %s %zu\n", "HASH NODE", *idx);
for(ptr=node->first_child, have_hash_splat=0; ptr; ptr=ptr->next_sibling) {
if(ptr->type == HASH_SPLAT_NODE) {
have_hash_splat = 1;
break;
}
}
if(have_hash_splat) {
OPCODE(*buf, OP_PUSH_INT); DATA_INT(*buf, 0);
OPCODE(*buf, OP_MAKE_HASH);
for(argc=0, ptr=node->first_child; ptr; argc++, ptr=ptr->next_sibling) {
if(ptr->type == HASH_SPLAT_NODE) {
compile_main_section(ctx, ptr->first_child, buf, idx, allocated, NEED_RESULT);
OPCODE(*buf, OP_TO_HASH);
OPCODE(*buf, OP_HASH_UPDATE);
} else {
compile_main_section(ctx, ptr->first_child, buf, idx, allocated, NEED_RESULT);
compile_main_section(ctx, ptr->first_child->next_sibling, buf, idx, allocated, NEED_RESULT);
OPCODE(*buf, OP_HASH_SET);
}
}
} else {
for(argc=0, ptr=node->first_child; ptr; argc++, ptr=ptr->next_sibling) {
compile_main_section(ctx, ptr->first_child, buf, idx, allocated, NEED_RESULT);
compile_main_section(ctx, ptr->first_child->next_sibling, buf, idx, allocated, NEED_RESULT);
}
OPCODE(*buf, OP_PUSH_INT); DATA_INT(*buf, argc);
OPCODE(*buf, OP_MAKE_HASH);
}
POP_IF_DONT_NEED_RESULT(*buf);
break;
case RETURN_NODE:
for(i=0; i<STACK_DEPTH; i++) {
OPCODE(*buf, OP_POP);
}
if(node->first_child) {
compile_main_section(ctx, node->first_child, buf, idx, allocated, NEED_RESULT);
} else {
OPCODE(*buf, OP_PUSH_NULL);
}
OPCODE(*buf, OP_RET);
break;
case AND_NODE:
case OR_NODE:
// TODO: optimize more for DONT_NEED_RESULT case
compile_main_section(ctx, node->first_child, buf, idx, allocated, NEED_RESULT);
OPCODE(*buf, OP_DUP);
OPCODE(*buf, OP_TO_BOOL);
if_jump = *idx;
OPCODE(*buf, node->type == AND_NODE ? OP_JMP_FALSE : OP_JMP_TRUE);
DATA_JUMP_OFFSET_PLACEHOLDER(*buf);
OPCODE(*buf, OP_POP);
compile_main_section(ctx, node->first_child->next_sibling, buf, idx, allocated, NEED_RESULT);
*(JUMP_OFFSET *)&(*buf)[if_jump+1] = *idx - if_jump - 1 - sizeof(JUMP_OFFSET); // Jump is OP_JMP_FALSE JUMP_OFFSET shorter
if_jump = *idx - 1 - sizeof(JUMP_OFFSET);
POP_IF_DONT_NEED_RESULT(*buf);
break;
case GUARD_NODE:
compile_main_section(ctx, node->first_child, buf, idx, allocated, NEED_RESULT);
OPCODE(*buf, OP_TO_BOOL);
OPCODE(*buf, OP_GUARD);
break;
case TRY_CATCH_NODE:
if_jump = *idx;
OPCODE(*buf, OP_TRY_START);
DATA_JUMP_OFFSET_PLACEHOLDER(*buf); // Set handler code location
compile_main_section(ctx, node->first_child, buf, idx, allocated, need_result);
end_of_func_idx = *idx;
OPCODE(*buf, OP_TRY_END);
DATA_JUMP_OFFSET_PLACEHOLDER(*buf); // Jump over handler code
*(JUMP_OFFSET *)&(*buf)[if_jump+1] = *idx - if_jump - 1 - sizeof(JUMP_OFFSET); // Jump is OP_TRY_START JUMP_OFFSET shorter
if(node->first_child->next_sibling) {
// Room for return value
OPCODE(*buf, OP_PUSH_NULL);
OPCODE(*buf, OP_XCHG);
OPCODE(*buf, OP_PUSH_INT); DATA_INT(*buf, 1); // One argument for the call of handler function(s)
OPCODE(*buf, OP_PUSH_INT); DATA_INT(*buf, 0); // Make array with zero elements
OPCODE(*buf, OP_MAKE_ARR);
for(ptr=node->first_child->next_sibling; ptr; ptr=ptr->next_sibling) {
compile_main_section(ctx, ptr, buf, idx, allocated, NEED_RESULT);
OPCODE(*buf, OP_ARR_APPEND);
}
OPCODE(*buf, OP_ARR_REVERSE);
OPCODE(*buf, OP_CALL_EXC);
POP_IF_DONT_NEED_RESULT(*buf);
} else {
// No handlers, return null
OPCODE(*buf, OP_POP); // Ignore the exception value
if(need_result) {
OPCODE(*buf, OP_PUSH_NULL);
}
}
*(JUMP_OFFSET *)&(*buf)[end_of_func_idx+1] = *idx - end_of_func_idx - 1 - sizeof(JUMP_OFFSET); // Jump is OP_TRY_START JUMP_OFFSET shorter
break;
case THROW_NODE:
compile_main_section(ctx, node->first_child, buf, idx, allocated, NEED_RESULT);
OPCODE(*buf, OP_THROW);
break;
case COMMAND_NODE:
OPCODE(*buf, OP_PUSH_NULL); // Placeholder for return value
// argv
OPCODE(*buf, OP_PUSH_INT); DATA_INT(*buf, 0); // Make array with zero elements
OPCODE(*buf, OP_MAKE_ARR);
for(ptr=node->first_child->next_sibling->first_child; ptr; ptr=ptr->next_sibling) {
if(ptr->type == ARR_SPLAT_NODE) {
compile_main_section(ctx, ptr->first_child, buf, idx, allocated, NEED_RESULT);
OPCODE(*buf, OP_TO_ARR);
OPCODE(*buf, OP_ARR_CONCAT);
continue;
}
compile_main_section(ctx, ptr, buf, idx, allocated, NEED_RESULT);
OPCODE(*buf, OP_ARR_APPEND);
}
// redirects
OPCODE(*buf, OP_PUSH_INT); DATA_INT(*buf, 0); // Make array with zero elements
OPCODE(*buf, OP_MAKE_ARR);
for(ptr=node->first_child->next_sibling->next_sibling->first_child; ptr; ptr=ptr->next_sibling) {
compile_main_section(ctx, ptr, buf, idx, allocated, NEED_RESULT);
OPCODE(*buf, OP_ARR_APPEND);
}
OPCODE(*buf, node->number ? OP_PUSH_TRUE : OP_PUSH_FALSE);
OPCODE(*buf, OP_MAKE_CMD);
OPCODE(*buf, OP_PUSH_INT); DATA_INT(*buf, 1);
compile_identifier(ctx, buf, idx, node->first_child->name, OP_FETCH_LOCAL, OP_FETCH_UPVAR, OP_FETCH_GLOBAL);
OPCODE(*buf, OP_CALL);
POP_IF_DONT_NEED_RESULT(*buf);
break;
case BREAK_NODE:
assert(ctx->fill_in_break_addrs_ptr < COMPILE_MAX_FILL_IN_LEN);
OPCODE(*buf, OP_JMP);
ctx->fill_in_break_addrs[ctx->fill_in_break_addrs_ptr++] = *idx;
DATA_JUMP_OFFSET_PLACEHOLDER(*buf);
break;
case CONTINUE_NODE:
assert(ctx->fill_in_continue_addrs_ptr < COMPILE_MAX_FILL_IN_LEN);
OPCODE(*buf, OP_JMP);
ctx->fill_in_continue_addrs[ctx->fill_in_continue_addrs_ptr++] = *idx;
DATA_JUMP_OFFSET_PLACEHOLDER(*buf);
break;
case REDIR_NODE:
compile_main_section(ctx, node->first_child, buf, idx, allocated, NEED_RESULT);
compile_main_section(ctx, node->first_child->next_sibling, buf, idx, allocated, NEED_RESULT);
OPCODE(*buf, OP_MAKE_REDIR);
break;
case SWITCH_NODE:
// XXX: Fix and test STACK_DEPTH
// XXX: Check for/while { ... case { ... break } ... } situation because break addresses are used in switch too.
// TODO: assert jump ranges
IF_NOT_SWITCH_COND {
compile_main_section(ctx, node->first_child, buf, idx, allocated, NEED_RESULT);
STACK_DEPTH++;
}
SETUP_ADDRESS_FILLING();
continue_target_idx = 0; // Should not appear there!
// TODO: make sure that leaving the section pops the switch value from the stack
cond_jump = 0;
for(ptr=node->first_child->next_sibling; ptr; ptr=ptr->next_sibling) {
if(cond_jump) {
// Jump to next comparison
*(JUMP_OFFSET *)&(*buf)[cond_jump] = *idx - (cond_jump + sizeof(JUMP_OFFSET));
cond_jump = 0;
}
IF_NOT_SWITCH_COND {
OPCODE(*buf, OP_DUP);
OPCODE(*buf, OP_PUSH_NULL); // Result placeholder
OPCODE(*buf, OP_XCHG);
}
// The value to compare to
compile_main_section(ctx, ptr->first_child, buf, idx, allocated, NEED_RESULT);
switch((switch_node_subtype)node->number) {
case SWITCH_NODE_SWITCH:
case SWITCH_NODE_ESWITCH:
OPCODE(*buf, OP_PUSH_INT); DATA_INT(*buf, 2);
compile_identifier(ctx, buf, idx, "==", OP_FETCH_LOCAL, OP_FETCH_UPVAR, OP_FETCH_GLOBAL);
OPCODE(*buf, OP_CALL);
break;
case SWITCH_NODE_MATCH:
case SWITCH_NODE_EMATCH:
OPCODE(*buf, OP_PUSH_INT); DATA_INT(*buf, 2);
compile_identifier(ctx, buf, idx, "match", OP_FETCH_LOCAL, OP_FETCH_UPVAR, OP_FETCH_GLOBAL);
OPCODE(*buf, OP_CALL);
case SWITCH_NODE_COND:
case SWITCH_NODE_ECOND:
OPCODE(*buf, OP_TO_BOOL);
break;
default:
fprintf(stderr, "ERROR: SWITCH_NODE subtype %i %i\n", node->number, SWITCH_NODE_COND);
assert(0 == "Unsupported SWITCH_NODE subtype");
}
OPCODE(*buf, OP_JMP_FALSE);
cond_jump = *idx;
DATA_JUMP_OFFSET_PLACEHOLDER(*buf);
// Code block to execute when values match
compile_main_section(ctx, ptr->first_child->next_sibling, buf, idx, allocated, NEED_RESULT);
IF_NOT_SWITCH_COND {
// Get rid of original value, preserving the match result
OPCODE(*buf, OP_XCHG);
OPCODE(*buf, OP_POP);
}
// Break
assert(ctx->fill_in_break_addrs_ptr < COMPILE_MAX_FILL_IN_LEN);
OPCODE(*buf, OP_JMP);
ctx->fill_in_break_addrs[ctx->fill_in_break_addrs_ptr++] = *idx;
DATA_JUMP_OFFSET_PLACEHOLDER(*buf);
}
if(cond_jump) {
// Jump to next comparison
*(JUMP_OFFSET *)&(*buf)[cond_jump] = *idx - (cond_jump + sizeof(JUMP_OFFSET));
}
// TOOD: optimize - OP_PUSH_NULL is not needed if result is not needed
if(node->number & 1) {
OPCODE(*buf, OP_PUSH_INT); DATA_INT(*buf, 0);
compile_identifier(ctx, buf, idx, "SwitchFail", OP_FETCH_LOCAL, OP_FETCH_UPVAR, OP_FETCH_GLOBAL);
// TODO: attribute with offending value
OPCODE(*buf, OP_CALL);
OPCODE(*buf, OP_THROW);
} else {
IF_NOT_SWITCH_COND {
OPCODE(*buf, OP_POP); // Get rid of original value
}
OPCODE(*buf, OP_PUSH_NULL);
}
HANDLE_ADDRESS_FILLING();
POP_IF_DONT_NEED_RESULT(*buf);
IF_NOT_SWITCH_COND {
STACK_DEPTH--;
}
break;
default:
fprintf(stderr, "Node type %i\n", node->type);
assert(0=="compile_main_section(): unknown node type");
}
}