/* Copyright J"orn Rennecke 1993 - 1997 */
#include <stdarg.h>
#include <stdio.h>
#include "common.h"
#include "alloc.h"
#include "lex.h"
#include "exec.h"
#include "interpret.h"
#include "object.h"
#include "lang.h"
#include "instrs.h"
#include "switch.h"
/* maximum recursion depth for compile_value */
#define MAX_LAMBDA_LEVELS 0x10000;
#define SYMTAB_START_SIZE 16
#define CODE_BUFFER_START_SIZE 1024
#define VALUE_START_MAX 0x20
#define ZERO_ACCEPTED 0x01 /* a return value of zero need not be coded */
#define VOID_ACCEPTED 0x02 /* any return value can be left out */
#define VOID_GIVEN 0x04
#define NEGATE_ACCEPTED 0x08
#define NEGATE_GIVEN 0x10
#define REF_REJECTED 0x20
#define PROTECT_LVALUE 0x2
#define VOID_WANTED (ZERO_ACCEPTED | VOID_ACCEPTED | NEGATE_ACCEPTED)
#define UNIMPLEMENTED \
lambda_error("Unimplemented - contact amylaar@meolyon.hanse.de\n");
#define ADD_STACK_USE(n) { \
if ((current.stack_use += (n)) > EVALUATOR_STACK_SIZE) \
lambda_error("closure would provoke stack overflow\n"); \
}
#define SUB_STACK_USE(n) (current.stack_use -= (n))
struct efun_closure bogus_closure;
static void insert_value_push(union svalue);
int leaf_inherit_find_function(struct program *prog, svalue name) {
/* The function is either newly defined or undefined. */
svalue *nfp, fn;
int i,o;
/* All truly new defined functions must be adjacent and numerically
ordered in order to get a correct index (can combine this with
alphasorted by alphasorting the new definitions at compile time). */
if (sizeof prog->new_function[0] != sizeof *nfp << 1)
fatal("Hack went awry\n");
o = prog->function.search.offset;
if (o) {
nfp = &prog->new_function[0].name;
i = prog->function.search.base;
do {
fn = nfp[i];
if (fn.p > name.p) {
i -= o;
if ((int)i < 0)
i = 0;
} else if (fn.p < name.p) {
i += o;
} else {
return i >> 1;
}
o >>= 1;
} while (o);
}
return -1;
}
/* possible register allocation:
r0: prog
r1: j, ix, fn
r2: i
r3: o
r4: prog2, scratch for subtract
r5: iix, inheritp
r6: name
r7: flag
*/
int find_function(struct program *prog, svalue name) {
unsigned i, j, o;
struct program_flags flag;
i = PR_FUNCTION_NAME_SIZE(prog->function.name);
if (!i)
return -1;
j = 1;
do j <<= 1; while (j <= i);
i *= sizeof *prog->function.name;
j *= sizeof *prog->function.name / 2;
o = j >> 1;
i = (i - sizeof *prog->function.name) -
(j - sizeof *prog->function.name);
flag = prog->flag;
do {
int ix, iix;
svalue fn;
struct program *prog2;
ix = *(uint16*)((void*)prog->function.name + i);
#ifdef RISC
prog2 = prog;
iix = flag.many_inherits ?
prog2->virtual.function_16[ix] : prog2->virtual.function_8[ix];
#else
iix = prog->flag.many_inherits ?
prog->virtual.function_16[ix] : prog->virtual.function_8[ix];
prog2 = prog;
#endif
while (iix) {
struct inherit *inheritp;
inheritp = &prog2->inherit[iix];
ix -= inheritp->virtual_offset;
prog2 = (struct program *)(inheritp->program & ~3);
iix = prog2->virtual.function_8[ix];
}
fn = prog->new_function[ix].name;
if (fn.p > name.p) {
i -= o;
if ((int)i < 0)
i = 0;
} else if (fn.p < name.p) {
i += o;
} else {
return *(uint16*)((void*)prog->function.name + i);
}
} while ((o >>= 1) >= sizeof *prog->function.name / 2);
return -1;
}
struct s_case_state case_state;
static int switch_initialized;
static struct case_list_entry *save_case_free_block, *save_case_next_free,
*save_case_list0, *save_case_list1;
static struct work_area {
struct symbol **symbols;
mp_int symbol_max, symbol_mask, symbols_left;
unsigned char *code, *codep;
mp_int code_max, code_left;
union svalue *values, *valuep;
mp_int value_max, values_left;
mp_int num_arg, num_locals, stack_use;
mp_int levels_left;
struct work_area *last;
union svalue lambda_origin; /* object */
} current = { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, { 0 } };
struct case_list_entry *case_blocks;
void closure_literal(union svalue *dest, int ix, struct frame *fp) {
struct lfun_closure *l;
int32 flags;
struct program *prog;
l = &SV_CLOSURE(ALLOC(T_CLOSURE, 1, sizeof *l)).lfun;
/* FIXME: ENOMEM */
prog = SV_OBJECT(fp->object).program;
if (ix >= CLOSURE_IDENTIFIER_OFFS) {
ix +=
-CLOSURE_IDENTIFIER_OFFS +
(fp->variable - SV_OBJECT(fp->object).variable);
l->closure_type = CLOSURE_IDENTIFIER;
} else {
#if 0 /* Fixme */
ix +=
fp->virtual.function -
SV_OBJECT(fp->object).program->virtual.function;
flags = prog->virtual.function[ix];
if (flags & TYPE__CROSS_DEFINED) {
ix += (flags & INHERIT_MASK) - (INHERIT_MASK + 1 >> 1);
}
l->closure_type = CLOSURE_LFUN;
#endif
}
l->ob = fp->object;
l->index = ix;
REF_INC(fp->object);
prog = SV_OBJECT(fp->object).program;
*dest = TO_SVALUE(l);
}
struct symbol {
union svalue name;
struct symbol *next;
struct symbol *next_local;
int index;
};
static void lambda_error(char *error_str, ...) FORMATDEBUG(printf, 1, 2);
int realloc_values() {
mp_int new_max;
union svalue *new_values;
new_max = current.value_max << 1;
new_values = re_x_alloc(current.values, new_max * sizeof new_values[0]);
if (!new_values) {
lambda_error("Out of memory\n");
current.values_left++;
--current.valuep;
FREE_SVALUE(*current.valuep);
return 0;
}
current.values_left += current.value_max;
current.valuep =
(union svalue *)((char*)current.valuep +
((char *)new_values - (char *)current.values));
current.values = new_values;
current.value_max = new_max;
return 1;
}
void realloc_code() {
mp_int new_max;
unsigned char *new_code;
new_max = current.code_max << 1;
new_code = re_x_alloc(current.code, new_max);
if (!new_code) {
lambda_error("Out of memory\n");
current.codep = current.code;
return;
}
current.code_left += current.code_max;
current.code_max = new_max;
current.codep += new_code - current.code;
current.code = new_code;
}
static void free_symbols();
static void lambda_error(char *error_str, ...)
{
va_list va;
#if 0
for (;;) {
free_symbols();
if (current.code)
x_free(current.code);
if (current.values) {
mp_int num_values = current.value_max - current.values_left;
struct svalue *svp;
for (svp = current.valuep; --num_values >= 0; )
free_svalue(svp++);
x_free((char *)current.values);
}
if (!current.last) break;
current = *current.last;
}
#endif
if (!inter_errno) {
char buf[256];
eval_switch = off;
inter_errno = IE_LAMBDA_ERROR;
va_start(va, error_str);
vsprintf(buf, error_str, va);
va_end(va);
error_arg[0] = make_string(buf, strlen(buf));
}
}
void lambda_cerror(s)
char *s;
{
lambda_error("%s\n", s);
}
int lambda_cerrorl(s1, s2, line1, line2)
char *s1, *s2;
int line1, line2;
{
lambda_error(s1, "\n");
return 0;
}
char *lambda_get_space(size)
p_int size;
{
while (current.code_left < size)
realloc_code();
current.code_left -= size;
current.codep += size;
return current.codep - size;
}
void lambda_move_switch_instructions(len, blocklen)
int len;
p_int blocklen;
{
while (current.code_left < len)
realloc_code();
current.code_left -= len;
current.codep += len;
move_memory(
current.codep - blocklen,
current.codep - blocklen - len,
blocklen
);
}
static void free_symbols()
{
p_int i;
struct symbol **symp, *sym, *next;
i = current.symbol_max;
symp = current.symbols;
do {
for (sym = *symp++; sym; sym = next) {
next = sym->next;
free_gen((char *)sym);
}
} while (i -= sizeof sym);
free_gen(current.symbols);
if (switch_initialized) {
if (inctop) {
case_state.free_block = save_case_free_block;
case_state.next_free = save_case_next_free;
case_state.list0 = save_case_list0;
case_state.list1 = save_case_list1;
} else {
while (case_blocks) {
struct case_list_entry *tmp;
tmp = case_blocks;
case_blocks = tmp->next;
free_gen(tmp);
}
}
}
}
struct symbol *make_symbol(name)
union svalue name;
{
p_int h;
struct symbol *sym, **symp;
h = name.i;
h ^= h >> 16;
h ^= h >> 8;
h ^= h >> 4;
h &= current.symbol_mask;
symp = (struct symbol **)((char *)current.symbols + h);
for (sym = *symp; sym; sym = sym->next) {
if (sym->name.p == name.p)
return sym;
}
sym = alloc_gen(sizeof *sym);
if (!sym) {
lambda_error("Out of memory\n");
return 0;
}
sym->name = name;
sym->index = -1;
sym->next = *symp;
*symp = sym;
if ( !(current.symbols_left -= sizeof sym) ) {
struct symbol **newtab, *sym2;
p_int i;
sym2 = sym;
current.symbols_left = current.symbol_max;
if (current.symbol_max > 0x7fff) {
free_gen(sym);
lambda_error("Too many symbols\n");
return 0;
}
current.symbol_max <<= 1;
symp = newtab = alloc_gen(current.symbol_max);
if (!symp) {
current.symbol_max >>= 1;
free_gen(sym);
lambda_error("Out of memory\n");
return 0;
}
current.symbol_mask = i = current.symbol_max - sizeof sym;
do {
*symp++ = 0;
} while ((i -= sizeof sym) >= 0);
i = current.symbols_left - sizeof sym;
do {
struct symbol *next;
for (sym = *(struct symbol **)((char *)current.symbols+i);
sym; sym = next)
{
next = sym->next;
h = sym->name.i;
h ^= h >> 16;
h ^= h >> 8;
h ^= h >> 4;
h &= current.symbol_mask;
symp = (struct symbol **)((char *)newtab + h);
sym->next = *symp;
*symp = sym;
}
} while ((i -= sizeof sym) >= 0);
free_gen(current.symbols);
current.symbols = newtab;
return sym2;
}
return sym;
}
/* compile_lvalue does not only supply an lvalue, but also 1 byte space to
* store the assignment code
*/
void compile_lvalue(union svalue, int);
int compile_value(union svalue value, int opt_flags) {
if (!--current.levels_left) {
lambda_error("Too deep recursion inside lambda()\n");
} else if (!SV_IS_NUMBER(value)) switch(SV_TYPE(value)) {
case T_ARRAY:
{
struct array *block;
union svalue *argp, first;
ph_int type;
block = &SV_ARRAY(value);
argp = block->member;
first = *argp;
if (block == &nil_array || SV_TYPE(first) != T_CLOSURE) {
lambda_error("Missing function\n");
break;
}
if ( (type = SV_CLOSURE(first).g.closure_type) <
(ph_int)CLOSURE_SIMUL_EFUN)
{
if (type < (ph_int)CLOSURE_EFUN) {
/* operator */
mp_int block_size;
block_size = VEC_SIZE(block);
switch(type - CLOSURE_OPERATOR) {
default:
lambda_error("Unimplemented operator %s for lambda()\n",
instrs[type - CLOSURE_OPERATOR].name);
case ULV_MAP_INDEX + ULV_CLOSURE_OFFSET:
type = ULV_INDEX + ULV_CLOSURE_OFFSET;
case ULV_INDEX + ULV_CLOSURE_OFFSET:
if (block_size == 3) {
compile_value(argp[2], REF_REJECTED);
compile_value(argp[3], REF_REJECTED);
compile_lvalue(argp[1], 0);
*current.codep++ = ULV_MAP_INDEX;
} else {
case ULV_RINDEX + ULV_CLOSURE_OFFSET:
if (block_size == 2) {
union svalue ix = argp[2];
if ( !(ix.i & 0x1fffe) ) {
compile_lvalue(argp[1], 0);
if (current.code_left < 2)
realloc_code();
current.code_left -= 2;
current.codep[0] =
type - ULV_CLOSURE_OFFSET +
ULV_SINDEX - ULV_INDEX;
STORE16(current.codep + 1, ix.i >> 1);
current.codep += 3;
} else {
compile_value(ix, REF_REJECTED);
compile_lvalue(argp[1], 0);
*current.codep++ = type - ULV_CLOSURE_OFFSET;
}
} else {
lambda_error("Bad number of arguments to #'[\n");
}
}
break;
case ULV_NN_RANGE + ULV_CLOSURE_OFFSET:
case ULV_NR_RANGE + ULV_CLOSURE_OFFSET:
case ULV_RN_RANGE + ULV_CLOSURE_OFFSET:
case ULV_RR_RANGE + ULV_CLOSURE_OFFSET:
type -= ULV_CLOSURE_OFFSET;
if (block_size == 2) {
type |= ULV_NR_RANGE - ULV_NN_RANGE;
compile_value(argp[2], REF_REJECTED);
compile_value(
(union svalue)(p_int)(1 << 1),
REF_REJECTED);
} else if (block_size == 3) {
compile_value(argp[2], REF_REJECTED);
compile_value(argp[3], REF_REJECTED);
} else {
lambda_error("Bad number of arguments to #'[..]\n");
}
compile_lvalue(argp[1], 0);
*current.codep++ = type;
break;
case F_LOR:
case F_LAND:
{
mp_int *branchp;
mp_int i, start, end;
int code = type - CLOSURE_OPERATOR;
int void_given;
if (opt_flags & VOID_ACCEPTED) {
code =
code == F_LAND ?
F_BRANCH_ON_ZERO :
F_BRANCH_ON_NON_ZERO ;
opt_flags |= VOID_GIVEN;
}
i = block_size - 1;
branchp = alloca(i * sizeof *branchp);
while (--i > 0) {
compile_value(++argp, REF_REJECTED);
if (current.code_left < 2)
realloc_code();
*branchp++ = current.code_max - current.code_left;
current.code_left -= 2;
*current.codep = code;
current.codep += 2;
}
void_given = compile_value(
i ?
(union svalue)(code == F_LAND ? (p_int)2 : (p_int)0) :
*++argp,
opt_flags & (VOID_ACCEPTED|REF_REJECTED)
);
if (opt_flags & VOID_ACCEPTED && !(void_given & VOID_GIVEN))
{
if (current.code_left < 1)
realloc_code();
current.code_left--;
*current.codep++ = F_POP;
}
i = block_size - 1;
end = current.code_max - current.code_left;
while (--i > 0) {
mp_int offset;
start = *--branchp;
offset = end - start - 2;
if (offset <= 0xff) {
current.code[start+1] = offset;
continue;
} else {
mp_int growth;
int growth_factor;
mp_int j;
char *p, *q;
if (opt_flags & VOID_ACCEPTED) {
growth = i;
growth_factor = 1;
code +=
F_LBRANCH_ON_ZERO - F_BRANCH_ON_ZERO;
} else {
growth = i * 3;
growth_factor = 3;
code += F_LBRANCH_ON_ZERO - F_LAND;
}
if (current.code_left < growth)
realloc_code();
current.code_left -= growth;
current.codep += growth;
p = current.code + end;
q = p + growth;
/* - 1 is precompensation for leading branch code */
end += growth_factor - 1;
if ( !(opt_flags & VOID_ACCEPTED) )
/* offset precompensation for leading F_DUP */
end--;
branchp++;
do {
char tmp_short[2];
start = *--branchp;
offset = end - start;
end += growth_factor;
if (offset > 0x7fff)
UNIMPLEMENTED
*(short *)tmp_short = offset;
j = p - (char *)¤t.code[start+2];
do {
*--q = *--p;
} while (--j);
if (opt_flags & VOID_ACCEPTED) {
*--q = tmp_short[1];
*--q = tmp_short[0];
*--q = code;
} else {
*--q = F_POP;
*--q = tmp_short[1];
*--q = tmp_short[0];
*--q = code;
*--q = F_PICK0;
}
p -= 2;
} while (--i > 0);
break;
}
}
break;
}
case F_BRANCH_ON_ZERO:
case F_BRANCH_ON_NON_ZERO:
{
mp_int *branchp;
mp_int i, start, end, void_dest, non_void_dest;
int code = type - CLOSURE_OPERATOR;
int opt_used, all_void;
mp_int last_branch;
if ( !(block_size & 1) &&
opt_flags & (VOID_ACCEPTED|ZERO_ACCEPTED) &&
( opt_flags & VOID_ACCEPTED ?
SV_TYPE(argp[block_size-1]) != T_ARRAY
/* no side effect */ :
!argp[block_size-1].i
) )
{
/* ignore default, it is equivalent to 0. */
block_size--;
}
i = block_size;
branchp = alloca(i * sizeof *branchp);
all_void = VOID_GIVEN;
while ( (i -= 2) > 0) {
mp_int offset;
opt_used = compile_value(++argp, NEGATE_ACCEPTED);
if (current.code_left < 2)
realloc_code();
last_branch = current.code_max - current.code_left;
current.code_left -= 2;
*current.codep = opt_used & NEGATE_GIVEN ?
(code == F_BRANCH_ON_NON_ZERO ?
F_BRANCH_ON_ZERO :
F_BRANCH_ON_NON_ZERO) :
code;
current.codep += 2;
++argp;
opt_used =
compile_value(
argp,
i == 1 && !all_void ?
opt_flags & REF_REJECTED :
opt_flags &
(VOID_ACCEPTED|ZERO_ACCEPTED|REF_REJECTED)
);
all_void &= opt_used;
if (current.code_left < 4)
realloc_code();
offset =
current.code_max - current.code_left - last_branch;
/* Allow the offset to be incremented
* by one afterwards.
*/
if (offset > 0xfe) {
char *p, tmp_short[2];
mp_int j;
p = current.codep++;
j = offset - 2;
if (offset > 0x7ffd)
UNIMPLEMENTED
do {
p--;
p[1] = *p;
} while (--j);
current.code_left--;
*((short *)tmp_short) = offset + 2;
current.code[last_branch] +=
F_LBRANCH_ON_ZERO - F_BRANCH_ON_ZERO;
current.code[last_branch+1] = tmp_short[0];
current.code[last_branch+2] = tmp_short[1];
} else {
current.code[last_branch+1] = offset;
}
*branchp++ = current.code_max - current.code_left;
*branchp++ = last_branch;
current.code_left -= 2;
*current.codep++ = F_BRANCH;
*current.codep++ = opt_used;
}
if ( i /* no default */ &&
( opt_flags & VOID_ACCEPTED ||
(all_void && opt_flags & ZERO_ACCEPTED)
) )
{
mp_int offset;
opt_flags |= VOID_GIVEN;
if (all_void) {
if (block_size < 2) {
break;
}
offset = -2;
void_dest =
current.code_max - current.code_left - 2;
} else {
/* Terminating void after non-void is avoided */
current.codep[-2] = F_POP;
offset = -1;
non_void_dest =
current.code_max - current.code_left - 2;
void_dest = non_void_dest + 1;
}
start = *--branchp;
code = current.code[start];
if (code == F_LBRANCH_ON_ZERO ||
code == F_LBRANCH_ON_NON_ZERO)
{
char tmp_short[2];
tmp_short[0] = current.code[start+1];
tmp_short[1] = current.code[start+2];
(*(short *)tmp_short) += offset;
current.code[start+1] = tmp_short[0];
current.code[start+2] = tmp_short[1];
} else {
current.code[start+1] += offset;
}
current.codep += offset;
current.code_left -= offset;
branchp--;
i = block_size - 2;
} else {
/* the following assignment is only valid if
* no V default
* if ( !all_void && i &&
* ( (opt_flags & (VOID_ACCEPTED|ZERO_ACCEPTED)) ==
* ZERO_ACCEPTED) )
* is met, and it is only needed when there is at
* least one void expression, too.
* However, it's easier to do the assignment
* all the time, and it does no harm here.
*/
void_dest = current.code_max - current.code_left;
opt_used = compile_value(
i ? (p_int)0 : ++argp,
opt_flags &
( all_void ?
(VOID_ACCEPTED|ZERO_ACCEPTED|REF_REJECTED) :
REF_REJECTED
)
);
non_void_dest =
current.code_max - current.code_left;
if (opt_used & VOID_GIVEN) {
void_dest = non_void_dest;
opt_flags |= VOID_GIVEN;
} else if (opt_flags & VOID_ACCEPTED) {
opt_flags |= VOID_GIVEN;
if (current.code_left < 1)
realloc_code();
current.code_left--;
*current.codep++ = F_POP;
opt_used = VOID_GIVEN;
void_dest = non_void_dest + 1;
} else if (all_void && block_size > 2) {
if (current.code_left < 3)
realloc_code();
if (block_size > 4 ||
branchp[-2] - branchp[-1] > 0xfd)
{
void_dest = non_void_dest + 2;
current.code_left -= 3;
*current.codep++ = F_BRANCH;
*current.codep++ = 1;
*current.codep++ = F_CONST0;
} else {
current.code_left--;
start = branchp[-2];
move_memory(
¤t.code[start+1],
¤t.code[start],
non_void_dest - start
);
current.codep++;
current.code[start] = F_CONST0;
/* void_dest = start; */
current.code[start+2] = 0; /* not void */
branchp[-2] = start+1;
current.code[branchp[-1]+1]++;
non_void_dest++;
/* all_void isn't used any more, else we'd
* need to zero it now.
*/
}
} else if (!i && !all_void &&
opt_flags & ZERO_ACCEPTED)
{
mp_int *branchp2, j;
branchp2 = branchp;
for (j = block_size; (j -= 2) > 0; ) {
start = *(branchp2 -= 2);
if (current.code[start+1] & VOID_GIVEN) {
void_dest = non_void_dest + 2;
non_void_dest += 3;
if (current.code_left < 3)
realloc_code();
current.code_left -= 3;
*current.codep++ = F_BRANCH;
*current.codep++ = 1;
*current.codep++ = F_CONST0;
break;
}
}
}
i = block_size;
}
end = current.code_max - current.code_left;
while ( (i -= 2) > 0) {
mp_int offset;
start = *(branchp -= 2);
offset = current.code[start+1] & VOID_GIVEN ?
void_dest - start - 2:
non_void_dest - start - 2;
if (offset <= 0xff) {
current.code[start+1] = offset;
continue;
} else {
mp_int growth;
mp_int j;
unsigned char *p, *q;
growth = i+1 >> 1;
if (current.code_left < growth)
realloc_code();
current.code_left -= growth;
current.codep += growth;
p = current.code + end;
q = p + growth;
branchp +=2;
do {
char tmp_short[2];
start = *--branchp;
code = current.code[start];
if (code == F_LBRANCH_ON_ZERO ||
code == F_LBRANCH_ON_NON_ZERO)
{
tmp_short[0] = current.code[start+1];
tmp_short[1] = current.code[start+2];
(*(short *)tmp_short)++;
current.code[start+1] = tmp_short[0];
current.code[start+2] = tmp_short[1];
} else {
current.code[start+1]++;
}
start = *--branchp;
offset = current.code[start+1] & VOID_GIVEN ?
void_dest - start - 1:
non_void_dest - start - 1;
end++;
void_dest++;
non_void_dest++;
if (offset > 0x7fff)
UNIMPLEMENTED
*(short *)tmp_short = offset;
j = (p - (current.code + start)) - 2;
do {
*--q = *--p;
} while (--j);
*--q = tmp_short[1];
*--q = tmp_short[0];
*--q = *(p-=2) +
(F_LBRANCH_ON_ZERO - F_BRANCH_ON_ZERO);
} while ( (i -= 2) > 0);
break;
}
}
break;
}
case F_POP:
{
mp_int i;
int void_given;
for (i = block_size - 1; --i > 0; ) {
void_given = compile_value(++argp, VOID_WANTED);
if ( !(void_given & VOID_GIVEN) ) {
if (current.code_left < 1)
realloc_code();
current.code_left--;
*current.codep++ = F_POP;
}
}
opt_flags = compile_value(i ? (p_int)0 : ++argp, opt_flags);
break;
}
case ULV_ASSIGN + ULV_CLOSURE_OFFSET:
{
mp_int i;
/* There must be at least one assignment in order to get
* a return value.
*/
if ( !(i = block_size - 1) || (i & 1) )
lambda_error("Missing value in assignment\n");
argp++;
for (; (i -= 2) >= 0; argp+=2) {
compile_value(argp[1], REF_REJECTED);
compile_lvalue(argp[0], 0);
/* we could build faster code using
* ULV_ASSIGN / ULV_VOID_ASSIGN by determining when
* the lvalue does not point to a function argument.
*/
if (!i) {
if (opt_flags & VOID_ACCEPTED) {
opt_flags = VOID_GIVEN;
*current.codep++ = ULV_VOID_HAIRY_ASSIGN;
} else {
*current.codep++ = ULV_HAIRY_ASSIGN;
}
} else {
*current.codep++ = ULV_VOID_HAIRY_ASSIGN;
}
}
break;
}
case ULV_ADD + ULV_CLOSURE_OFFSET:
if (block_size != 3)
goto generic_assign_error;
if (argp[2].i == 2) {
if (opt_flags & VOID_ACCEPTED) {
opt_flags = VOID_GIVEN;
type = ULV_INC;
} else {
type = ULV_PRE_INC;
}
goto generic_modify;
}
goto generic_assign;
case ULV_SUB + ULV_CLOSURE_OFFSET:
if (block_size != 3)
goto generic_assign_error;
if (argp[2].i == 2) {
if (opt_flags & VOID_ACCEPTED) {
opt_flags = VOID_GIVEN;
type = ULV_DEC;
} else {
type = ULV_PRE_DEC;
}
goto generic_modify;
}
goto generic_assign;
case ULV_MUL + ULV_CLOSURE_OFFSET:
case ULV_AND + ULV_CLOSURE_OFFSET:
case ULV_OR + ULV_CLOSURE_OFFSET:
case ULV_XOR + ULV_CLOSURE_OFFSET:
case ULV_LSH + ULV_CLOSURE_OFFSET:
case ULV_RSH + ULV_CLOSURE_OFFSET:
case ULV_DIV + ULV_CLOSURE_OFFSET:
case ULV_MOD + ULV_CLOSURE_OFFSET:
if (block_size != 3) {
generic_assign_error:
lambda_error(
"Bad number of arguments to #'%s\n",
instrs[type - CLOSURE_OPERATOR].name
);
}
generic_assign:
type -= ULV_CLOSURE_OFFSET;
if (opt_flags & VOID_ACCEPTED) {
opt_flags = VOID_GIVEN;
type += ULV_VOID_ADD - ULV_ADD;
}
compile_value(argp[2], REF_REJECTED);
generic_modify:
compile_lvalue(argp[1], 0);
*current.codep++ = type;
break;
case ULV_POST_INC + ULV_CLOSURE_OFFSET:
case ULV_POST_DEC + ULV_CLOSURE_OFFSET:
if (block_size != 2)
goto generic_assign_error;
if (opt_flags & VOID_ACCEPTED) {
opt_flags = VOID_GIVEN;
type -= ULV_POST_INC - ULV_INC;
}
goto generic_modify;
case F_BBRANCH_ON_NON_ZERO: /* #'do */
{
mp_int i;
int void_given;
mp_int offset;
i = block_size - 3;
if (i < 0)
lambda_error("Missing argument(s) to #'do\n");
offset = current.code_left - current.code_max;
if (i) do {
void_given = compile_value(++argp, VOID_WANTED);
if ( !(void_given & VOID_GIVEN) ) {
if (current.code_left < 1)
realloc_code();
current.code_left--;
*current.codep++ = F_POP;
}
} while(--i);
void_given =
compile_value(++argp, NEGATE_ACCEPTED);
offset += current.code_max - current.code_left + 1;
if (current.code_left < 3)
realloc_code();
if (offset > 0xff) {
char tmp_short[2];
if (offset > 0x8000)
UNIMPLEMENTED
current.code_left -= 3;
*((short *)tmp_short) = -offset;
*current.codep++ = void_given & NEGATE_GIVEN ?
F_LBRANCH_ON_ZERO :
F_LBRANCH_ON_NON_ZERO;
*current.codep++ = tmp_short[0];
*current.codep++ = tmp_short[1];
} else {
current.code_left -= 2;
*current.codep++ = void_given & NEGATE_GIVEN ?
F_BBRANCH_ON_ZERO :
F_BBRANCH_ON_NON_ZERO;
*current.codep++ = offset;
}
opt_flags = compile_value(++argp, opt_flags);
break;
}
case F_BBRANCH_ON_ZERO: /* #'while */
{
mp_int i;
int void_given;
mp_int start_branch;
mp_int offset;
if (current.code_left < 2)
realloc_code();
current.code_left -= 2;
start_branch = current.code_max - current.code_left;
*current.codep = F_BRANCH;
current.codep += 2;
i = block_size - 3;
if (i < 0)
lambda_error("Missing argument(s) to #'while\n");
offset = current.code_left - current.code_max;
argp += 2;
if (i) do {
void_given = compile_value(++argp, VOID_WANTED);
if ( !(void_given & VOID_GIVEN) ) {
if (current.code_left < 2)
realloc_code();
current.code_left--;
*current.codep++ = F_POP;
}
} while(--i);
offset =
current.code_max - current.code_left - start_branch;
if (offset > 0xff) {
char *p, tmp_short[2];
if (offset > 0x7ffd)
UNIMPLEMENTED
if (current.code_left < 1)
realloc_code();
current.code_left--;
p = current.codep++;
i = offset;
do {
p--;
p[1] = *p;
} while (--i);
*((short *)tmp_short) = offset + 2;
current.code[start_branch-2] = F_LBRANCH;
current.code[start_branch-1] = tmp_short[0];
current.code[start_branch-0] = tmp_short[1];
start_branch++;
} else {
current.code[start_branch-1] = offset;
}
argp = block->member;
void_given =
compile_value(++argp, NEGATE_ACCEPTED);
if (current.code_left < 3)
realloc_code();
offset =
current.code_max - current.code_left - start_branch + 1;
if (offset > 0xff) {
char tmp_short[2];
if (offset > 0x8000)
UNIMPLEMENTED
current.code_left -= 3;
*((short *)tmp_short) = -offset;
*current.codep++ = void_given & NEGATE_GIVEN ?
F_LBRANCH_ON_ZERO :
F_LBRANCH_ON_NON_ZERO;
*current.codep++ = tmp_short[0];
*current.codep++ = tmp_short[1];
} else {
current.code_left -= 2;
*current.codep++ = void_given & NEGATE_GIVEN ?
F_BBRANCH_ON_ZERO :
F_BBRANCH_ON_NON_ZERO;
*current.codep++ = offset;
}
opt_flags = compile_value(++argp, opt_flags);
break;
}
case F_CATCH:
{
mp_int start, offset;
int void_given;
if (block_size != 2)
lambda_error("Wrong number of arguments to #'catch\n");
if (current.code_left < 2)
realloc_code();
current.code_left -= 2;
*current.codep++ = F_CATCH;
*current.codep++ = 0;
start = current.code_max - current.code_left;
void_given = compile_value(++argp, 0);
if (current.code_left < 1)
realloc_code();
current.code_left--;
*current.codep++ = F_END_CATCH;
offset = current.code_max - current.code_left - start;
if (offset > 0xff) {
UNIMPLEMENTED
}
current.code[start-1] = offset;
break;
}
case F_NOT:
{
if (block_size != 2)
lambda_error("Wrong number of arguments to #'!\n");
opt_flags |=
compile_value(++argp, opt_flags & ~ZERO_ACCEPTED);
if (opt_flags & (NEGATE_ACCEPTED|VOID_GIVEN) ) {
opt_flags ^= NEGATE_GIVEN;
} else {
if (current.code_left < 1)
realloc_code();
current.code_left--;
*current.codep++ = F_NOT;
}
break;
}
case F_AND:
{
int i;
if ( (i = block_size - 2) > 0) {
compile_value(++argp, 0);
do {
compile_value(++argp, 0);
if (current.code_left < 1)
realloc_code();
current.code_left--;
*current.codep++ = F_AND;
} while (--i);
} else if (!i) {
if (opt_flags & REF_REJECTED)
lambda_error("Reference value in bad position\n");
compile_lvalue(
*++argp, PROTECT_LVALUE);
current.code_left++;
} else {
lambda_error("Missing argument(s) to #'&\n");
}
break;
}
case F_SSCANF:
{
int lvalues;
if ( (lvalues = block_size - 3) < 0)
lambda_error("Missing argument(s) to #'sscanf\n");
if (lvalues > 0xff - 2)
lambda_error("Too many arguments to #'sscanf\n");
compile_value(++argp, 0);
compile_value(++argp, 0);
while (--lvalues >= 0) {
compile_lvalue(*++argp, PROTECT_LVALUE);
current.code_left++;
}
if (current.code_left < 2)
realloc_code();
current.code_left -= 2;
*current.codep++ = F_SSCANF;
*current.codep++ = block_size - 1;
break;
}
case F_AGGREGATE:
{
int i;
char size[2];
i = block_size - 1;
*(short *)size = i;
while (--i >= 0) {
compile_value(++argp, REF_REJECTED);
}
if (current.code_left < 3)
realloc_code();
current.code_left -= 3;
*current.codep++ = F_AGGREGATE;
*current.codep++ = size[0];
*current.codep++ = size[1];
break;
}
case F_M_CAGGREGATE:
{
int i, j, num_keys, num_values;
num_values = 1;
i = block_size;
num_keys = i - 1;
for (i = block_size; --i;) {
union svalue *element;
if (SV_TYPE(*++argp) != T_ARRAY)
lambda_error("Bad argument to #'([\n");
element = SV_ARRAY(*argp).member;
j = VEC_SIZE(&SV_ARRAY(*argp));
if (j != num_values) {
if (i != num_keys)
lambda_error(
"#'([ : Inconsistent value count.\n");
num_values = j;
}
while (--j >= 0) {
compile_value(*element++, REF_REJECTED);
}
}
if (current.code_left < 5)
realloc_code();
num_values--; /* one item of each subarray is the key */
if ( (num_keys | num_values) & ~0xff) {
char size[2];
current.code_left -= 5;
*current.codep++ = F_M_AGGREGATE;
*(short *)size = num_keys;
*current.codep++ = size[0];
*current.codep++ = size[1];
*(short *)size = num_values;
*current.codep++ = size[0];
*current.codep++ = size[1];
} else {
current.code_left -= 3;
*current.codep++ = F_M_CAGGREGATE;
*current.codep++ = num_keys;
*current.codep++ = num_values;
}
break;
}
case F_RETURN:
{
if (block_size != 2) {
if (block_size > 1)
lambda_error("Too many arguments to #'return\n");
opt_flags = VOID_GIVEN;
} else {
opt_flags =
compile_value(++argp, ZERO_ACCEPTED|REF_REJECTED);
}
if (current.code_left < 1)
realloc_code();
current.code_left--;
*current.codep++ =
opt_flags & VOID_GIVEN ? F_RETURN0 : F_RETURN;
break;
}
case F_SWITCH:
{
mp_int num_blocks, i, switch_pc, default_addr = 0;
int some_numeric = 0, no_string = 1;
struct case_list_entry *zero = 0;
struct case_list_entry *save_free_block, *save_next_free,
*save_list0, *save_list1;
int success;
if (!switch_initialized) {
switch_initialized = 1;
if (inctop) {
save_case_free_block = case_state.free_block;
save_case_next_free = case_state.next_free;
save_case_list0 = case_state.list0;
save_case_list1 = case_state.list1;
} else {
case_blocks = 0;
case_state.free_block = (struct case_list_entry *)(
((PTRTYPE)(&case_blocks))-
((PTRTYPE)(&((struct case_list_entry*)0)->next)-
(PTRTYPE) 0)
);
case_state.next_free = case_state.free_block + 1;
}
}
num_blocks = (block_size) / 3;
if (block_size != 2 + num_blocks*3)
lambda_error("Bad number of arguments to #'switch\n");
compile_value(++argp, REF_REJECTED);
if (current.code_left < 3)
realloc_code();
current.code_left -= 3;
*current.codep = F_SWITCH;
current.codep += 3;
switch_pc = current.code_max - current.code_left - 2;
ADD_STACK_USE(1)
save_free_block = case_state.free_block;
save_next_free = case_state.next_free;
save_list0 = case_state.list0;
save_list1 = case_state.list1;
case_state.list0 = case_state.list1 = 0;
for (i = num_blocks; --i >= 0;) {
union svalue *labels;
mp_int j;
struct case_list_entry *l;
int opt_used;
++argp;
if (!SV_IS_NUMBER(*argp) && SV_TYPE(*argp) == T_ARRAY)
{
labels = SV_ARRAY(*argp).member;
j = VEC_SIZE(&SV_ARRAY(*argp));
} else {
labels = argp;
j = 1;
}
for (; j--; labels++) {
l = new_case_entry();
l->addr =
current.code_max - current.code_left - switch_pc;
l->line = 1;
if (j && !SV_IS_NUMBER(labels[1]) &&
SV_TYPE(labels[1]) == T_CLOSURE &&
SV_CLOSURE(labels[1]).g.closure_type ==
F_RANGE + CLOSURE_EFUN )
{
if (j < 2) {
lambda_error(
"case label range lacks end\n"
);
}
if (!SV_IS_NUMBER(labels[0]) ||
!SV_IS_NUMBER(labels[2]) )
{
lambda_error(
"case label range must be numeric\n"
);
}
if (!no_string)
lambda_error(
"mixed case label lists not supported\n"
);
some_numeric = 1;
l->key = *labels;
j -= 2;
labels += 2;
if (labels[-2].i == labels->i)
continue;
if (labels[-2].i > labels->i)
goto reuse_list_entry;
l->addr = 1;
l = new_case_entry();
l->addr =
current.code_max - current.code_left -
switch_pc;
l->line = 0;
l->key = *labels;
} else if (SV_IS_NUMBER(*labels)) {
if ((l->key = *labels).i) {
if (!no_string)
lambda_error(
"mixed case label lists not supported\n"
);
some_numeric = 1;
} else {
zero = l;
}
} else if (SV_IS_STRING(*labels)) {
if (some_numeric)
lambda_error(
"mixed case label lists not supported\n"
);
if (!--current.values_left)
realloc_values();
no_string = 0;
*labels = make_string_global(*labels);
l->key = *current.valuep++ =
!++SV_REF(*labels) ?
ref_inc(*labels) : *labels;
} else if (SV_TYPE(*labels) == T_CLOSURE &&
SV_CLOSURE(*labels).g.closure_type ==
F_CSHARED0 + CLOSURE_OPERATOR)
{
if (default_addr)
lambda_error("duplicate default\n");
default_addr = l->addr;
reuse_list_entry:
case_state.list0 = case_state.list1;
case_state.list1 = l->next;
case_state.next_free++;
continue;
} else {
lambda_error("bad type of case label\n");
}
}
argp++;
opt_used = compile_value(
argp,
SV_CLOSURE(argp[1]).g.closure_type ==
F_POP + CLOSURE_OPERATOR ?
REF_REJECTED | VOID_ACCEPTED :
REF_REJECTED
);
if (SV_IS_NUMBER(*++argp) ||
SV_TYPE(*argp) != T_CLOSURE ||
( SV_CLOSURE(*argp).g.closure_type !=
F_BREAK + CLOSURE_OPERATOR &&
(!i || SV_CLOSURE(*argp).g.closure_type !=
F_POP + CLOSURE_OPERATOR)) )
{
lambda_error("Bad delimiter in #'switch\n");
}
if ( !(opt_used & VOID_GIVEN) ) {
if (current.code_left < 1)
realloc_code();
current.code_left--;
*current.codep++ =
SV_CLOSURE(*argp).efun.closure_type;
}
}
if (!default_addr) {
default_addr =
current.code_max - current.code_left - switch_pc;
if (current.code_left < 2)
realloc_code();
current.code_left -= 2;
*current.codep++ = F_CONST0;
*current.codep++ = F_BREAK;
}
success = store_case_labels(
current.code_max - current.code_left - switch_pc,
default_addr,
some_numeric|no_string, zero,
lambda_get_space, lambda_move_switch_instructions,
lambda_cerror, lambda_cerrorl
);
case_state.free_block = save_free_block;
case_state.next_free = save_next_free;
case_state.list0 = save_list0;
case_state.list1 = save_list1;
SUB_STACK_USE(1);
break;
}
}
} else {
/* efun */
mp_int i;
char *p;
int f;
int num_arg, min, max, def;
num_arg = VEC_SIZE(block) - 1;
for (i = num_arg; --i >= 0; ) {
compile_value(++argp, 0);
}
argp = block->member;
if (current.code_left < 5)
realloc_code();
f = type - CLOSURE_EFUN;
min = instrs[f].min_arg;
max = instrs[f].max_arg;
p = current.codep;
if (num_arg < min) {
extern int proxy_efun(int, int);
int g;
if (num_arg == min-1 && (def = instrs[f].Default)) {
*p++ = def;
current.code_left--;
max--;
min--;
} else if ((g = proxy_efun(f, num_arg)) < 0 || (f = g, 0))
lambda_error("Too few arguments to %s\n", instrs[f].name);
} else if (num_arg > max && max != -1) {
lambda_error("Too many arguments to %s\n", instrs[f].name);
}
if (f > 0xff) {
*p++ = f >> F_ESCAPE_BITS;
current.code_left--;
}
*p++ = f;
current.code_left--;
if (min != max) {
*p++ = num_arg;
if (num_arg > 0xff)
lambda_error("Too many arguments to efun closure\n");
current.code_left--;
}
if ( instrs[f].ret_type == TYPE_VOID ) {
if (opt_flags & (ZERO_ACCEPTED|VOID_ACCEPTED)) {
opt_flags = VOID_GIVEN;
} else {
*p++ = F_CONST0;
current.code_left--;
}
}
current.codep = p;
break;
}
} else switch (type) {
default:
{
/* simul_efun */
uint16 simul_efun;
int num_arg;
int i;
struct simul_efun_table_s *funp;
simul_efun = type - CLOSURE_SIMUL_EFUN;
num_arg = VEC_SIZE(block) - 1;
for (i = num_arg; --i >= 0; ) {
compile_value(++argp, 0);
}
if (current.code_left < 4)
realloc_code();
funp = &simul_efun_table[simul_efun];
if (num_arg > (uint16)funp->num_arg) {
union svalue name;
uint8 *start;
mp_int len;
memcpy(&name, funp->fun.start - 1 - sizeof name, sizeof name);
start = sv_string(name, &len);
lambda_error(
"Too many arguments to simul_efun %.*s\n", (int)len, start
);
}
if (funp->num_arg > 0) {
i = funp->num_arg - num_arg;
if (i > 1 && current.code_left < i + 2)
realloc_code();
current.code_left -= i;
while ( --i >= 0 ) {
*current.codep++ = F_CONST0;
}
}
if (simul_efun > 0xff) {
*current.codep++ = F_XSIMUL_EFUN;
STORE16(current.codep, simul_efun);
current.codep += 2;
current.code_left--;
} else {
*current.codep++ = F_SIMUL_EFUN;
*current.codep++ = simul_efun;
}
if (funp->num_arg < 0) {
*current.codep++ = num_arg;
current.code_left -= 3;
} else
current.code_left -= 2;
break;
}
case CLOSURE_UNBOUND_LAMBDA:
case CLOSURE_BOUND_LAMBDA:
case CLOSURE_LAMBDA:
lambda_error("Unimplemented closure type for lambda()\n");
case CLOSURE_ALIEN_LFUN:
{
mp_int i;
mp_int block_size;
block_size = VEC_SIZE(block);
insert_value_push(*argp);
for (i = block_size; --i; ) {
compile_value(*++argp, 0);
}
if (current.code_left < 2)
realloc_code();
current.code_left -= 2;
*current.codep++ = F_FUNCALL;
*current.codep++ = block_size;
break;
}
case CLOSURE_LFUN:
{
mp_int i;
struct lfun_closure *l;
mp_int block_size;
block_size = VEC_SIZE(block);
l = &SV_CLOSURE(*argp).lfun;
if (l->ob.p != current.lambda_origin.p) {
insert_value_push(*argp);
for (i = block_size; --i; ) {
compile_value(*++argp, 0);
}
if (current.code_left < 2)
realloc_code();
current.code_left -= 2;
*current.codep++ = F_FUNCALL;
*current.codep++ = block_size;
} else {
for (i = block_size; --i; ) {
compile_value(*++argp, 0);
}
if (current.code_left < 4)
realloc_code();
current.code_left -= 4;
*current.codep++ = F_CALL_FUNCTION_BY_INDEX;
STORE16(current.codep, l->index);
current.codep += 2;
*current.codep++ = block_size - 1;
if (block_size > 0x100)
lambda_error("Too many arguments to lfun closure\n");
}
break;
}
case CLOSURE_IDENTIFIER:
{
struct lfun_closure *l;
l = &SV_CLOSURE(*argp).lfun;
if (VEC_SIZE(block) != 1)
lambda_error("Argument to variable\n");
if (l->ob.p != current.lambda_origin.p) {
insert_value_push(*argp);
if (current.code_left < 2)
realloc_code();
current.code_left -= 2;
*current.codep++ = F_FUNCALL;
*current.codep++ = 1;
} else {
if (current.code_left < 3)
realloc_code();
if ((short)l->index < 0)
lambda_error("Variable not inherited\n");
if (l->index <= 0xff) {
current.code_left -= 2;
current.codep[0] = F_V_GLOBAL;
current.codep[1] = l->index;
current.codep += 2;
} else {
current.code_left -= 3;
current.codep[0] = F_V_GLOBAL16;
STORE16(current.codep + 1, l->index);
current.codep += 3;
}
}
break;
}
} /* end of switch on closure_type */
break;
} /* end of case T_ARRAY (block compiling code) */
case T_QUOTED:
{
int quotes;
quotes = SV_QUOTES(value);
value = SV_QUOTED(value);
if (--quotes) {
union svalue value2;
value2 = ALLOC(T_QUOTED, 1, sizeof(char *) + sizeof(union svalue));
if (!value2.p) {
lambda_error("Out of memory\n");
break;
}
SV_QUOTES(value2) = quotes;
SV_QUOTED(value2) = value;
value = value2;
} else if (SV_IS_STRING(value)) {
struct symbol *sym;
sym = make_symbol(value);
if (!sym)
break;
if (sym->index < 0) {
char *start;
mp_int len;
start = sv_string(sym->name, &len);
lambda_error("Symbol '%.*s' not bound\n", (int)len, start);
break;
}
if (current.code_left < 2)
realloc_code();
*current.codep++ = F_V_LOCAL;
*current.codep++ = sym->index;
current.code_left -= 2;
break;
}
/* fall through */
}
default:
goto ordinary_value;
} else {
/* SV_IS_NUMBER(value) */
mp_int i;
if ( (i = value.i) >= 0) {
if (i < 0x200) {
if (current.code_left < 2)
realloc_code();
if (!i) {
if (opt_flags & (VOID_ACCEPTED|ZERO_ACCEPTED)) {
opt_flags = VOID_GIVEN;
} else {
*current.codep++ = F_CONST0;
current.code_left--;
}
} else if (i == 2) {
*current.codep++ = F_CONST1;
current.code_left--;
} else {
*current.codep++ = F_CLIT;
*current.codep++ = i >> 1;
current.code_left -= 2;
}
} else {
goto ordinary_value;
}
} else if (i > -0x200) {
if (current.code_left < 2)
realloc_code();
*current.codep++ = F_NCLIT;
*current.codep++ = -i >> 1;
current.code_left -= 2;
} else {
ordinary_value:
insert_value_push(value);
}
}
current.levels_left++;
return opt_flags;
}
void compile_lvalue(union svalue arg, int flags) {
if (!SV_IS_NUMBER(arg)) switch(SV_TYPE(arg)) {
case T_QUOTED:
{
struct symbol *sym;
if (SV_QUOTES(arg) != 1 || !SV_IS_STRING(SV_QUOTED(arg)))
break;
sym = make_symbol(arg);
if (!sym)
return;
if (sym->index < 0)
sym->index = current.num_locals++;
if (current.code_left < 3)
realloc_code();
current.code_left -= 3;
*current.codep++ = F_LV_LOCAL;
*current.codep++ = sym->index;
return;
}
case T_ARRAY:
{
struct array *block;
union svalue *argp;
block = &SV_ARRAY(arg);
if (block != &nil_array &&
SV_TYPE(*(argp = block->member)) == T_CLOSURE)
{
union svalue first = *argp;
if (!SV_IS_NUMBER(first)) switch (SV_CLOSURE(first).g.closure_type)
{
case ULV_INDEX + ULV_CLOSURE_OFFSET + CLOSURE_EFUN:
case ULV_RINDEX + ULV_CLOSURE_OFFSET + CLOSURE_EFUN:
if (VEC_SIZE(block) == 3) {
compile_value(argp[2], 0);
compile_lvalue(argp[1], flags & PROTECT_LVALUE);
if (current.code_left < 1)
realloc_code();
current.code_left--;
if (flags & PROTECT_LVALUE) {
*current.codep++ =
SV_CLOSURE(first).g.closure_type +
ULV_PLV_INDEX - ULV_INDEX - ULV_CLOSURE_OFFSET;
} else {
*current.codep++ =
SV_CLOSURE(first).g.closure_type +
ULV_LV_INDEX - ULV_INDEX - ULV_CLOSURE_OFFSET;
}
return;
}
if (VEC_SIZE(block) == 4 &&
SV_CLOSURE(first).efun.closure_type ==
ULV_INDEX + ULV_CLOSURE_OFFSET + CLOSURE_EFUN)
{
compile_value(argp[2], 0);
compile_value(argp[3], 0);
compile_lvalue(argp[1], flags & PROTECT_LVALUE);
if (current.code_left < 1)
realloc_code();
current.code_left--;
if (flags & PROTECT_LVALUE) {
*current.codep++ = ULV_PLV_MAP_INDEX;
} else {
*current.codep++ = ULV_LV_MAP_INDEX;
}
return;
}
break;
case ULV_NN_RANGE + ULV_CLOSURE_OFFSET + CLOSURE_EFUN:
case ULV_NR_RANGE + ULV_CLOSURE_OFFSET + CLOSURE_EFUN:
case ULV_RN_RANGE + ULV_CLOSURE_OFFSET + CLOSURE_EFUN:
case ULV_RR_RANGE + ULV_CLOSURE_OFFSET + CLOSURE_EFUN:
if (VEC_SIZE(block) != 4)
break;
compile_value(*(argp += 2), 0);
compile_value(*++argp, 0);
compile_lvalue(argp[-2], flags & PROTECT_LVALUE);
if (current.code_left < 1)
realloc_code();
current.code_left--;
*current.codep++ =
SV_CLOSURE(first).efun.closure_type - CLOSURE_EFUN -
ULV_CLOSURE_OFFSET - ULV_NN_RANGE + ULV_LV_NN_RANGE;
return;
case ULV_MAP_INDEX + ULV_CLOSURE_OFFSET + CLOSURE_EFUN:
if (VEC_SIZE(block) != 4)
break;
compile_value(*++argp, 0);
compile_value(*++argp, 0);
compile_value(*++argp, 0);
if (current.code_left < 2)
realloc_code();
current.code_left -= 2;
if (flags & PROTECT_LVALUE) {
*current.codep++ =
ULV_PLV_MAP_INDEX;
} else {
*current.codep++ = ULV_LV_MAP_INDEX;
}
return;
case CLOSURE_IDENTIFIER:
{
struct lfun_closure *l;
if (VEC_SIZE(block) != 1)
break;
l = &SV_CLOSURE(first).lfun;
if (l->ob.p != current.lambda_origin.p)
break;
if (current.code_left < 4)
realloc_code();
if ((short)l->index < 0)
lambda_error("Variable not inherited\n");
if (l->index > 0xff) {
current.codep[0] = F_LV_GLOBAL16;
STORE16(current.codep + 1, l->index);
current.codep += 3;
current.code_left -= 4;
} else {
current.codep[0] = F_LV_GLOBAL;
current.codep[1] = l->index;
current.codep += 2;
current.code_left -= 3;
}
return;
}
}
}
break;
}
case T_CLOSURE:
{
switch (SV_CLOSURE(arg).g.closure_type) {
case CLOSURE_IDENTIFIER:
{
struct lfun_closure *l;
l = &SV_CLOSURE(arg).lfun;
if (l->ob.p != current.lambda_origin.p)
break;
if (current.code_left < 4)
realloc_code();
if ((short)l->index < 0)
lambda_error("Variable not inherited\n");
if (l->index > 0xff) {
current.code_left -= 4;
current.codep[0] = F_LV_GLOBAL16;
STORE16(current.codep + 1, l->index);
current.codep += 3;
} else {
current.code_left -= 3;
current.codep[0] = F_LV_GLOBAL;
current.codep[1] = l->index;
current.codep += 2;
}
return;
}
}
break;
}
}
compile_value(arg, REF_REJECTED);
if (current.code_left < 2)
realloc_code();
current.code_left -= 2;
*current.codep++ = F_LV_NIL;
}
struct lambda_closure *lambda(
struct array *args, union svalue block, union svalue origin)
{
mp_int i, j;
union svalue *argp;
mp_int num_values, values_size, code_size;
struct lambda_closure *l;
int void_given;
current.symbols_left = current.symbol_max =
sizeof current.symbols[0] * SYMTAB_START_SIZE;
current.symbol_mask = current.symbol_max- sizeof(struct symbol *);
current.last = 0;
current.code = 0;
current.values = 0;
current.symbols = alloc_gen(current.symbol_max);
if (!current.symbols)
goto enomem;
i = SYMTAB_START_SIZE - 1;
do {
current.symbols[i] = 0;
} while (--i >= 0);
switch_initialized = 0;
argp = args->member;
j = VEC_SIZE(args);
for (i = 0; i < j; i++, argp++) {
union svalue name;
struct symbol *sym;
if (SV_TYPE(name = *argp) != T_QUOTED ||
!SV_IS_STRING(name = SV_QUOTED(name)))
{
lambda_error("Illegal argument type to lambda()\n");
error:
free_symbols();
goto error0;
}
sym = make_symbol(name);
if (!sym)
goto error;
if (sym->index >= 0) {
lambda_error("Double symbol name in lambda arguments\n");
goto error;
}
sym->index = i;
}
current.num_locals = i;
current.stack_use = 0;
current.code_max = CODE_BUFFER_START_SIZE;
current.code_left = CODE_BUFFER_START_SIZE;
current.levels_left = MAX_LAMBDA_LEVELS;
if ( !(current.code = current.codep = x_alloc(current.code_max)) )
goto enomem2;
current.num_arg = current.num_locals;
current.value_max = current.values_left = VALUE_START_MAX;
if ( !(current.values =
x_alloc(current.value_max * sizeof current.values[0])) )
{
goto enomem3;
}
current.valuep = current.values + current.value_max;
current.lambda_origin = origin;
void_given = compile_value(block, ZERO_ACCEPTED|REF_REJECTED);
if (current.code_left < 1)
realloc_code();
current.code_left -= 1;
*current.codep++ = void_given & VOID_GIVEN ? F_RETURN0 : F_RETURN;
num_values = current.value_max - current.values_left;
values_size = num_values * sizeof (union svalue);
code_size = current.code_max - current.code_left;
if (code_size > sizeof (union svalue) * 0x10000 - sizeof *l) {
union svalue allocated;
mp_int size, offset;
char *codep;
size = ALIGNI(
offsetof(struct lambda_closure, big_shared_start) +
values_size + code_size, char *);
allocated = ALLOC(T_CLOSURE, 1, size);
if (!allocated.i) {
enomem4:
x_free(current.values);
enomem3:
x_free(current.code);
enomem2:
free_symbols();
enomem:
lambda_error("Out of memory\n");
error0:
return &bogus_closure;
}
l = &SV_CLOSURE(allocated).lambda;
offset = offsetof(struct lambda_closure, big_shared_start) -
offsetof(struct lambda_closure, code[1]) + values_size;
codep = &l->code[0];
if (*current.code == F_VARARGS)
*codep++ = F_VARARGS;
codep[0] = F_XLBRANCH;
codep[1] = offset >> 16;
codep[2] = offset >> 8;
codep[3] = offset;
l->big_size = size;
l->shared_start = offsetof(struct lambda_closure, big_shared_start) /
sizeof(union svalue);
memcpy(
(char *)((union svalue *)l + l->shared_start) + values_size,
current.code, code_size
);
} else {
union svalue allocated;
allocated = ALLOC( T_CLOSURE, 1, ALIGNI(
offsetof(struct lambda_closure, code) + code_size + values_size,
union svalue));
if (!allocated.i)
goto enomem4;
l = &SV_CLOSURE(allocated).lambda;
l->shared_start =
(code_size + sizeof(union svalue) - 1) / sizeof (union svalue);
memcpy(l->code, current.code, code_size);
}
memcpy(
(union svalue *)l + l->shared_start,
(char *)current.valuep, values_size
);
if (num_values >= 0xff) {
((union svalue *)l + l->shared_start)[0xff].i = num_values << 1;
l->num_shared = 0xff;
} else {
l->num_shared = num_values;
}
l->num_local = current.num_locals;
l->num_arg = current.num_arg;
free_symbols();
x_free(current.code);
x_free(current.values);
if (!origin.p) {
l->closure_type = CLOSURE_UNBOUND_LAMBDA;
} else {
l->closure_type = CLOSURE_LAMBDA;
}
return l;
}
static void insert_value_push(union svalue value) {
mp_int offset;
if (current.code_left < 3)
realloc_code();
offset = current.value_max - current.values_left;
if (offset < 0xff) {
current.code_left -= 2;
*current.codep++ = F_CSHARED0;
*current.codep++ = offset;
} else {
if (offset == 0xff) {
current.values_left--;
offset++;
current.valuep++;
}
current.code_left -= 3;
*current.codep = F_SHARED;
STORE16(current.codep+1, offset);
current.codep += 3;
}
if (!--current.values_left)
realloc_values();
*current.valuep++ = COPY_SVALUE(value);
}
void _free_lambda_closure(union svalue sv) {
union closure *l;
mp_int size;
mp_int num_shared;
union svalue *svp;
l = &SV_CLOSURE(sv);
num_shared = l->lambda.num_shared;
if (num_shared == 0xff)
num_shared =
((union svalue *)l + l->lambda.shared_start)[0xff].i >> 1;
if (l->lambda.shared_start ==
offsetof(struct lambda_closure, big_shared_start) / sizeof sv &&
(l->lambda.code[0] == F_XLBRANCH ||
l->lambda.code[0] == F_VARARGS && l->lambda.code[1] == F_XLBRANCH)
) {
size = l->lambda.big_size;
} else {
size = sizeof sv * (l->lambda.shared_start + num_shared);
}
svp = (union svalue *)l + l->lambda.shared_start;
while (--num_shared >= 0) {
union svalue sv2 = *svp++;
FREE_SVALUE(sv2);
}
free_block(sv.p, size);
return;
}
int symbol_operator(symbol, endp)
char *symbol, **endp;
{
char c;
int ret;
switch(*symbol) {
case '+':
c = symbol[1];
if (c == '=') {
symbol++;
ret = ULV_ADD + ULV_CLOSURE_OFFSET;
break;
} else if (c == '+') {
symbol++;
ret = ULV_POST_INC + ULV_CLOSURE_OFFSET;
break;
}
ret = F_ADD;
break;
case '-':
c = symbol[1];
if (c == '=') {
symbol++;
ret = ULV_SUB + ULV_CLOSURE_OFFSET;
break;
} else if (c == '-') {
symbol++;
ret = ULV_POST_DEC + ULV_CLOSURE_OFFSET;
break;
}
ret = F_SUB;
break;
case '*':
if (symbol[1] == '=') {
symbol++;
ret = ULV_MUL + ULV_CLOSURE_OFFSET;
break;
}
ret = F_MULTIPLY;
break;
case '/':
if (symbol[1] == '=') {
symbol++;
ret = ULV_DIV + ULV_CLOSURE_OFFSET;
break;
}
ret = F_DIVIDE;
break;
case '%':
if (symbol[1] == '=') {
symbol++;
ret = ULV_MOD + ULV_CLOSURE_OFFSET;
break;
}
ret = F_MOD;
break;
case ',':
ret = F_POP;
break;
case '^':
if (symbol[1] == '=') {
symbol++;
ret = ULV_XOR + ULV_CLOSURE_OFFSET;
break;
}
ret = F_XOR;
break;
case '|':
c = *++symbol;
if (c == '|') {
ret = F_LOR;
break;
} else if (c == '=') {
ret = ULV_OR + ULV_CLOSURE_OFFSET;
break;
}
symbol--;
ret = F_OR;
break;
case '&':
c = *++symbol;
if (c == '&') {
ret = F_LAND;
break;
} else if (c == '=') {
ret = ULV_AND + ULV_CLOSURE_OFFSET;
break;
}
symbol--;
ret = F_AND;
break;
case '~':
ret = F_COMPLEMENT;
break;
case '<':
c = *++symbol;
if (c == '=') {
ret = F_LE;
break;
} else if (c == '<') {
if (symbol[1] == '=') {
symbol++;
ret = ULV_LSH + ULV_CLOSURE_OFFSET;
break;
}
ret = F_LSH;
break;
}
symbol--;
ret = F_LT;
break;
case '>':
c = *++symbol;
if (c == '=') {
ret = F_GE;
break;
} else if (c == '>') {
if (symbol[1] == '=') {
symbol++;
ret = ULV_RSH + ULV_CLOSURE_OFFSET;
break;
}
ret = F_RSH;
break;
}
symbol--;
ret = F_GT;
break;
case '=':
if (symbol[1] == '=') {
symbol++;
ret = F_EQ;
break;
}
ret = ULV_ASSIGN + ULV_CLOSURE_OFFSET;
break;
case '!':
if (symbol[1] == '=') {
symbol++;
ret = F_NE;
break;
}
ret = F_NOT;
break;
case '?':
if (symbol[1] == '!') {
symbol++;
ret = F_BRANCH_ON_NON_ZERO;
break;
}
ret = F_BRANCH_ON_ZERO;
break;
case '[':
c = *++symbol;
if (c == '<') {
if (symbol[1] == '.' && symbol[2] == '.') {
c = *(symbol+=3);
if (c == ']') {
ret = ULV_RN_RANGE + ULV_CLOSURE_OFFSET;
break;
} else if (c == '<' && symbol[1] == ']') {
symbol++;
ret = ULV_RR_RANGE + ULV_CLOSURE_OFFSET;
break;
}
symbol--;
ret = F_R_RANGE2;
break;
}
ret = ULV_RINDEX + ULV_CLOSURE_OFFSET;
break;
} else if (c == '.' && symbol[1] == '.') {
c = *(symbol+=2);
if (c == ']') {
ret = ULV_NN_RANGE + ULV_CLOSURE_OFFSET;
break;
} else if (c == '<' && symbol[1] == ']') {
symbol++;
ret = ULV_NR_RANGE + ULV_CLOSURE_OFFSET;
break;
}
symbol--;
ret = F_RANGE2;
break;
} else if (c == ',' && symbol[1] == ']') {
symbol++;
ret = ULV_MAP_INDEX + ULV_CLOSURE_OFFSET;
break;
}
symbol--;
ret = ULV_INDEX + ULV_CLOSURE_OFFSET;
break;
case '(':
c = *++symbol;
if (c == '{') {
ret = F_AGGREGATE;
break;
} else if (c == '[') {
ret = F_M_CAGGREGATE;
break;
}
symbol--;
/* fall through */
default:
ret = -1;
symbol--;
}
*endp = symbol+1;
return ret;
}
void symbol_efun(union svalue *sp, struct frame *fp) {
int efun_override = 0;
char *str;
mp_int len;
union svalue l;
union svalue ob;
int hash;
SV_COUNT_STRING(*sp, str, len);
if (isalunum(*str)) {
struct ident *p;
if (len > 6 && *(int32*)str == C2I32('e','f','u','n') &&
*(int16*)(str+4) == (':' << 8) + ':' )
{
str += 6;
efun_override = 1;
hash = uhash(str, len);
} else {
hash = ahash(str, len);
}
p = make_shared_identifier(str, len, hash, I_TYPE_GLOBAL);
if (!p)
return;
while (p->type > I_TYPE_GLOBAL) {
if (p->type == I_TYPE_RESWORD) {
int value;
value = p->u.terminal.value;
if (!IS_RESWORD_CLOSURE(value)) {
if (p = p->inferior)
continue;
goto undefined_function;
}
l = ALLOC(T_CLOSURE, 1, sizeof(struct efun_closure));
if (!l.p)
return;
FREE_ALLOCED_SVALUE(*sp);
*sp = l;
SV_CLOSURE(l).efun.closure_type = RESWORD_TO_CLOSURE(value);
ob = fp->object;
SV_CLOSURE(l).efun.ob = REF_INC(ob);
return;
}
if ( !(p = p->inferior) )
break;
}
if (!p || p->type < I_TYPE_GLOBAL ||
( efun_override || p->u.global.sim_efun < 0 ) &&
p->u.global.efun < 0 )
{
if (p && p->type == I_TYPE_UNKNOWN)
free_shared_identifier(p);
undefined_function:
FREE_ALLOCED_SVALUE(*sp);
sp->i = 0;
return;
}
if (efun_override && p->u.global.sim_efun >= 0 &&
simul_efun_table[p->u.global.sim_efun].nomask)
{
svalue res;
inter_fp = fp;
inter_sp = sp;
PUSH_NUMBER(PV_NOMASK_SIMUL_EFUN << 1);
push_svalue(fp->object);
PUSH_REFERENCED_SVALUE(make_string(p->name, p->namelen));
res = call_hook(driver_hook[H_PRIVILEGE_VIOLATION], fp->object, 3);
if (!SV_IS_NUMBER(res) || res.i < 0)
{
error(IE_PRIVILEGED, "%d%O", PV_NOMASK_SIMUL_EFUN << 1, p->name);
} else if (!res.i) {
efun_override = 0;
}
}
l = ALLOC(T_CLOSURE, 1, sizeof(struct efun_closure));
if (!l.i)
return;
FREE_ALLOCED_SVALUE(*sp);
*sp = l;
ob = fp->object;
SV_CLOSURE(l).efun.ob = REF_INC(ob);
if (!efun_override && p->u.global.sim_efun >= 0) {
SV_CLOSURE(l).efun.closure_type =
p->u.global.sim_efun + CLOSURE_SIMUL_EFUN;
return;
}
/* p->u.global.efun >= 0 */
SV_CLOSURE(l).efun.closure_type = p->u.global.efun + CLOSURE_EFUN;
if (SV_CLOSURE(l).efun.closure_type >
LAST_INSTRUCTION_CODE + CLOSURE_EFUN)
{
SV_CLOSURE(l).efun.closure_type = CLOSURE_EFUN +
efun_aliases[
SV_CLOSURE(l).efun.closure_type - CLOSURE_EFUN -
LAST_INSTRUCTION_CODE - 1];
}
} else {
int i;
char *str_end, *op_end, clobbered;
/*
* We have to place a delimiter lest a valid operator is interpreted
* together with trailing garbage as a longer operator.
* We choose a valid operator that cannot be start nor continuation
* of a longer operator to make checks easier.
*/
str_end = &str[len];
clobbered = *str_end;
*str_end = '~';
i = symbol_operator(str, &op_end);
*str_end = clobbered;
FREE_ALLOCED_SVALUE(*sp);
if (op_end != str_end) {
sp->i = 0;
return;
}
l = ALLOC(T_CLOSURE, 1, sizeof(struct efun_closure));
if (!l.p)
return;
*sp = l;
ob = fp->object;
SV_CLOSURE(l).efun.ob = REF_INC(ob);
if (instrs[i].Default == -1) {
SV_CLOSURE(l).efun.closure_type = i + CLOSURE_OPERATOR;
} else {
SV_CLOSURE(l).efun.closure_type = i + CLOSURE_EFUN;
}
}
}
union svalue *f_unbound_lambda(union svalue *sp) {
struct lambda_closure *l;
struct array *args;
union svalue sv;
sv = sp[-1];
if (SV_IS_NUMBER(sv)) {
if (!sv.i) {
if ( !(args = &nil_array)->ref++)
nil_array.len++;
} else {
bad_efun_arg(1);
return sp;
}
} else if (SV_TYPE(sv) != T_ARRAY) {
bad_efun_arg(1);
return sp;
} else {
args = &SV_ARRAY(sv);
}
l = lambda(args, sp, SV_NULL);
l->ob.i = 0;
sv = *sp--;
FREE_SVALUE(sv);
FREE_ALLOCED_SVALUE(TO_SVALUE(args));
*sp = TO_SVALUE(l);
return sp;
}
union svalue *f_symbol_variable(union svalue *sp, struct frame *fp) {
union svalue str;
union svalue ob;
int n;
union svalue sv;
str = *sp;
ob = fp->object;
if (fp->variable < SV_OBJECT(ob).variable ||
fp->variable >= SV_OBJECT(ob).variable +
(PR_VARIABLE_NAME_END(SV_OBJECT(ob).program) -
SV_OBJECT(ob).program->variable_name) )
{
/* efun closures are called without setting current_prog nor
* inter_fp->variable. This keeps the program scope for
* variables for calls inside this_object(), but would give
* trouble with calling from other ones if it were not for
* this test.
*/
fp->program = SV_OBJECT(ob).program;
fp->variable = SV_OBJECT(ob).variable;
}
if (SV_IS_NUMBER(str)) {
n = str.i;
if (n < 0 || n >=
PR_VARIABLE_NAME_END(fp->program) -
fp->program->variable_name
) {
sp->i = 0;
return sp;
}
if (fp->program->variable_name[n].flags & TYPE__HIDDEN) {
if (_privilege_violation(PV_SYMBOL_VARIABLE << 1, *sp, sp) <= 0) {
sp->i = 0;
return sp;
}
}
} else switch(SV_TYPE(str)) {
case T_STRING:
case T_LSTRING:
case T_ISTRING:
case T_ILSTRING:
str = findstring(str);
goto got_string;
case T_QUOTED:
{
struct variable *var;
struct program *prog;
int num_var;
str = SV_QUOTED(str);
if (SV_IS_NUMBER(str) || !SV_IS_STRING(str)) {
default:
bad_efun_arg(1);
return sp;
}
got_string:
case T_GSTRING:
case T_GLSTRING:
FREE_ALLOCED_SVALUE(*sp);
prog = fp->program;
var = prog->variable_name;
num_var = PR_VARIABLE_NAME_END(prog) - prog->variable_name;
for (n = num_var; --n >= 0; var++) {
if (var->name.p == str.p && !(var->flags & TYPE__HIDDEN))
break;
}
if (n < 0) {
sp->i = 0;
return sp;
}
n = num_var - n - 1;
}
}
sv = ALLOC(T_CLOSURE, 1, sizeof SV_CLOSURE(sv).lfun);
*sp = sv;
if (sv.i) {
SV_CLOSURE(sv).lfun.closure_type = CLOSURE_IDENTIFIER;
ob = fp->object;
SV_CLOSURE(sv).lfun.ob = ob;
SV_CLOSURE(sv).lfun.index =
n + (fp->variable - SV_OBJECT(ob).variable);
SV_CLOSURE(sv).lfun.major_ref = 0;
REF_INC(ob);
}
return sp;
}
/* allocate case_list_entrys in contigous blocks to increase locality of
* reference
*/
struct case_list_entry *new_case_entry() {
struct case_list_entry *ret;
ret = --case_state.next_free;
if (ret == case_state.free_block) {
struct case_list_entry *next;
if ( !(next = case_state.free_block->next) ) {
next = (struct case_list_entry*)
alloc_gen(sizeof(struct case_list_entry[CASE_BLOCKING_FACTOR]));
next->next = 0;
case_state.free_block->next = next;
}
case_state.free_block = next;
case_state.next_free = ret = next + CASE_BLOCKING_FACTOR - 1;
}
case_state.next_free->next = case_state.list1;
ret->next = case_state.list1;
case_state.list1 = case_state.list0;
case_state.list0 = ret;
return ret;
}
int store_case_labels(
p_int total_length,
p_int default_addr,
int numeric,
struct case_list_entry *zero,
char *(*get_space)(p_int),
void (*move_instructions)(int, p_int),
void (*cerror)(char *),
int (*cerrorl)(char *, char*, int, int)
)
{
struct case_list_entry *list0, *list1;
int type;
mp_int runlength, key_num;
int len, i,o;
union svalue current_key,last_key;
mp_int current_addr,last_addr;
char tmp_short[2];
unsigned char *p;
mp_int tablen;
int i0;
list0 = case_state.list0;
list1 = case_state.list1;
if (numeric) {
type = 0;
} else {
type = 0x20;
if (zero) {
zero->key = (p_int)ZERO_AS_STR_CASE_LABEL;
}
}
/* length(list0) >= length(list1) */
if (!list0) {
(*cerror)("switch without case not supported");
return 0;
}
for (runlength = 1; list1; runlength <<= 1) {
struct case_list_entry *out_hook0, *out_hook1, **out0, **out1;
mp_int count0, count1;
out0 = &out_hook0;
out1 = &out_hook1;
while (list1) {
count0 = count1 = runlength;
while (1) {
if (list1->key.i < list0->key.i)
{
*out0 = list1;
out0 = &list1->next;
list1 = *out0;
if (!--count1 || !list1) {
*out0 = list0;
do {
out0 = &list0->next;
list0 = *out0;
} while (--count0 && list0);
break;
}
} else {
*out0 = list0;
out0 = &list0->next;
list0 = *out0;
if (!--count0 || !list0) {
*out0 = list1;
do {
out0 = &list1->next;
list1 = *out0;
} while (--count1 && list1);
break;
}
}
}
{
struct case_list_entry **temp;
temp = out0;
out0 = out1;
out1 = temp;
}
}
*out0 = list0;
*out1 = 0;
list0 = out_hook0;
list1 = out_hook1;
}
/* list0 now contains all entries, sorted. Scan the list for ranges. */
key_num = 0;
if (numeric) {
struct case_list_entry *table_start, *max_gain_end;
p_int keys, max_gain, cutoff;
for(last_addr=0xffffff, list1=list0; list1; list1 = list1->next) {
int curr_line,last_line;
struct case_list_entry *range_start;
key_num++;
current_key = list1->key ;
curr_line = list1->line ;
current_addr = list1->addr ;
if ( current_key.i == last_key.i && list1 != list0) {
if (!(*cerrorl)("Duplicate case%s", " in line %d and %d",
last_line, curr_line))
{
return 0;
}
}
/* range ends are left in the list without checks. */
if (curr_line) {
if (last_addr == 1) {
if (!(*cerrorl)(
"Discontinued case label list range%s",
", line %d by line %d",
last_line, curr_line))
{
return 0;
}
} else if (current_key.i == last_key.i + 2) {
if (current_addr == last_addr) {
/* range continuation with single value */
if (list1 != range_start->next) {
range_start->addr = 1;
range_start->next = list1;
/* lookup table building uses !end->line */
list1->line = 0;
key_num--;
}
} else if (current_addr == 1 &&
list1->next->addr == last_addr)
{
/* range continuation with range start */
key_num -= 1 + (list1 != range_start->next);
range_start->addr = 1;
range_start->next = list1->next;
/* list1->next was range end before, thus
* range_start->next->line == 0 .
*/
list1 = range_start;
} else {
range_start = list1;
}
} else {
range_start = list1;
}
}
last_key = current_key;
last_line = curr_line;
last_addr = current_addr;
}
if ( !( total_length + key_num*(sizeof(p_int)+1) & ~0xff) ) {
len = 1;
} else if ( !( total_length + key_num*(sizeof(p_int)+2) + 1 & ~0xffff) )
{
len = 2;
} else if ( !( total_length + key_num*(sizeof(p_int)+3) + 2 & ~0xffffff) )
{
len = 3;
} else {
(*cerror)("offset overflow");
return 0;
}
if (len > 1) {
(*move_instructions)(len-1, total_length);
total_length += len-1;
default_addr += len-1;
}
cutoff = sizeof(p_int)*2 + len*2;
list1 = list0;
table_start = list1;
for (max_gain = keys = 0; list1; list1 = list1->next) {
p_int span, gain;
struct case_list_entry *previous;
keys++;
if (list1->addr == 1) {
previous = list1;
continue;
}
list1->addr += len-1;
span = list1->key.i - table_start->key.i + 2 >> 1;
gain = keys * sizeof(p_int) - (span - keys)* len;
if (max_gain - gain > cutoff && max_gain >= cutoff) {
struct case_list_entry *tmp;
union svalue key;
p_int addr, size;
unsigned char *p0;
/* write table from table_start to max_gain_end */
span = max_gain_end->key.i - table_start->key.i + 2 >> 1;
size = span * len;
p0 = (*get_space)(size);
tmp = table_start;
key = tmp->key;
if (tmp->addr == 1) {
key_num--;
tmp = tmp->next;
}
do {
if (tmp->key.i < key.i) {
key_num--;
tmp = tmp->next;
if (tmp->addr == 1) {
key_num--;
tmp = tmp->next;
}
}
addr = default_addr;
if (key.i == tmp->key.i || !tmp->line)
addr = tmp->addr;
p0 += len;
p0[-1] = addr;
if (len >= 2) {
p0[-2] = addr >> 8;
if (len > 2) {
p0[-3] = addr >> 16;
}
}
} while (++key.i <= max_gain_end->key.i);
key_num += 1;
max_gain_end->addr = total_length;
total_length += size;
table_start->addr = 0;
table_start->next = max_gain_end;
gain = -1;
}
if (gain < 0) {
if (list1->line) {
table_start = list1;
keys = 1;
} else {
table_start = previous;
keys = 2;
}
table_start = list1->line ? list1 : previous;
max_gain = 0;
} else if (gain > max_gain) {
max_gain = gain;
max_gain_end = list1;
}
}
} else {
/* string case: neither ordinary nor lookup table ranges are viable.
* Thus, don't spend unnecesarily time with calculating them.
* Also, a more accurate calculation of len is possible.
*/
for (list1 = list0; list1; list1 = list1->next) {
int curr_line,last_line;
key_num++;
current_key = list1->key ;
curr_line = list1->line ;
if ( current_key.p == last_key.p && list1 != list0) {
(*cerrorl)("Duplicate case%s", " in line %d and %d",
last_line, curr_line);
}
last_key = current_key;
last_line = curr_line;
}
if ( !( (total_length | key_num*sizeof(p_int)) & ~0xff) ) {
len = 1;
} else if ( !( (total_length+1 | key_num*sizeof(p_int)) & ~0xffff) ) {
len = 2;
} else if ( !( (total_length+2 | key_num*sizeof(p_int)) & ~0xffffff) ) {
len = 3;
} else {
(*cerror)("offset overflow");
return 0;
}
if (len > 1) {
(*move_instructions)(len-1, total_length);
total_length += len-1;
default_addr += len-1;
for (list1 = list0; list1; list1 = list1->next) {
list1->addr += len-1;
}
}
}
/* calculate starting index for iterative search at execution time */
for(i=0,o=2;o <= key_num; )
i++,o<<=1;
/* and store it */
type |= i | len << 6;
tablen = key_num * sizeof(p_int);
p = get_space(tablen + key_num * len + 2 + len);
p[-total_length] = tablen;
p[-total_length+1] = type;
i0 = p[-total_length+1+len];
p[-total_length+2] = total_length;
if (len >= 2) {
*p++ = tablen >> 8;
p[-total_length+2] = total_length >> 8;
if (len > 2) {
*p++ = tablen >> 16;
p[-total_length+2] = total_length >> 16;
}
}
*(short*)tmp_short = default_addr;
*p++ = tmp_short[0];
*p++ = tmp_short[1];
*p++ = i0;
p += sizeof(p_int) - 4;
for (list1 = list0; list1; list1 = list1->next) {
memcpy(p, &list1->key, sizeof(list1->key));
p += sizeof(list1->key);
}
for (list1 = list0; list1; list1 = list1->next) {
p += len;
p[-1] = list1->addr;
if (len >= 2) {
p[-2] = list1->addr >> 8;
if (len > 2) {
p[-3] = list1->addr >> 16;
}
}
}
if (len > 2)
*(*get_space)(1) = default_addr >> 16;
return 1;
}
void align_switch(pc)
unsigned char *pc;
{
int len;
int32 tablen, offset, size;
unsigned char a2, abuf[sizeof(p_int)-1], *startu, *starta;
tablen = pc[0];
a2 = pc[1];
len = a2 >> 6;
pc[0] |= len;
pc[1] = offset = pc[2];
if (len >=2) {
offset += (pc[2] = pc[3]) << 8;
if (len > 2) {
offset += (pc[3] = pc[4]) << 16;
}
}
if (len >=2) {
tablen += pc[offset] << 8;
if (len > 2) {
tablen += pc[offset+1] << 16;
}
}
memcpy(abuf, pc+offset+len-1, 2);
pc[len+1] = pc[offset+len+1];
pc[offset+len+1] = abuf[2] = a2;
startu = pc+offset+len+2;
starta = (char *)((p_int)startu & ~(sizeof(char *)-1));
size = tablen + tablen / sizeof(char*) * len;
move_memory(starta, startu, size);
move_memory(starta+size, abuf + sizeof abuf - (startu-starta), startu-starta);
}
struct control_ret closure_frame(svalue cl, svalue *sp, struct frame *fp,
int num_arg, uint8 *pc, p_int return_mode)
{
struct control_ret ret;
int closure_type = SV_CLOSURE(cl).g.closure_type;
switch(closure_type) {
case CLOSURE_LFUN:
{
svalue ob;
int ix, fx, iix;
struct program *prog;
svalue *variables;
ob = SV_CLOSURE(cl).lfun.ob;
ix = SV_CLOSURE(cl).lfun.index;
prog = SV_OBJECT(ob).program;
variables = SV_OBJECT(ob).variable;
fx = ix;
iix = prog->flag.many_inherits ?
prog->virtual.function_16[fx] : prog->virtual.function_8[fx];
while(iix > 0) {
struct inherit *inheritp;
inheritp = &prog->inherit[iix];
prog = (struct program *)(inheritp->program & ~3);
fx -= inheritp->virtual_offset;
variables += inheritp->variable_offset;
iix = prog->virtual.function_8[fx];
}
ix -= fx;
if (iix < 0)
fx = iix + prog->redefine_offset;
ret =
make_frame(sp, num_arg, PR_PCODE(prog)+prog->new_function[fx].start);
ret.fp->variable = variables;
ret.fp->previous = fp;
ret.fp->virtual.function_8 =
SV_OBJECT(ob).program->virtual.function_8 + ix;
ret.fp->object = ob;
ret.fp->pc = pc;
ret.fp->program = prog;
ret.fp->shared = prog->shared;
ret.fp->return_mode.i = return_mode;
break;
}
default:
if (closure_type >= CLOSURE_EFUN) {
uint8 *cp;
ret.sp = sp;
ret.fp = ++inter_ex_fp;
closure_type -= CLOSURE_EFUN;
ret.fp->pc = pc;
ret.fp->return_mode.i = return_mode + IR_LOCAL_XF - IR_LOCAL;
ret.fp->previous = fp;
ret.fp->object = SV_CLOSURE(cl).efun.ob;
ret.fp->program = 0;
cp = (uint8 *)&ret.fp->shared;
*cp++ = 0;
*cp++ = 0;
ret.fp->funstart = cp;
if (closure_type > 0xff)
*cp++ = closure_type >> F_ESCAPE_BITS;
*cp++ = closure_type;
if (instrs[closure_type].min_arg != instrs[closure_type].max_arg)
*cp++ = num_arg;
*cp++ = F_RETURN;
break;
}
fatal("Unimplemented\n");
}
return ret;
}