/* 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; }