/* Copyright 1991, 1993 - 1997 J"orn Rennecke */
#include <stdarg.h>
#include <stdio.h>
#include "common.h"
#include "interpret.h"
#include "instrs.h"
#include "object.h"
#include "uid.h"
unsigned char const_invalid[2] = { T_INVALID, 0 };
struct lvalue catch_value = {
T_LVALUE, /* type */
255, /* ref */
LVALUE_CATCH, /* lvalue_type */
};
static struct lvalue fresh_char_lvalue = { T_CHAR_LVALUE };
svalue fresh_char_lvalue_svalue = { (p_int)&fresh_char_lvalue.ref };
#if defined(i386)
/*
* With the current problems of gcc in register allocation, it is too
* expensive to keep fp in a register on i386. Thus we can consider
* everything that can be adressed with an 8 bit offset on the stack
* to be a 'register' in the same class. Plus there are two registers
* for sp and pc that are in a better class - being real registers.
*/
#define FP_CLASS_REGISTERS 34
#endif
#ifndef FP_CLASS_REGISTERS
#define FP_CLASS_REGISTERS 3
#endif
#if defined(i386) && defined(__GNUC__)
#if 1
#define RG0 asm("%ebx")
#endif
#if 1
#define RG1 asm("%esi")
#endif
#endif
#ifndef RG0
#define RG0
#endif
#ifndef RG1
#define RG1
#endif
#ifndef RG3
#define RG3
#endif
int inter_errno, last_eval_cost, eval_cost, tracing;
enum eval_state eval_switch;
struct inter_stack inter_stack;
svalue *inter_sp, *inter_general_stack_bottom;
struct frame *inter_fp, *inter_ex_fp, *inter_external_stack_bottom;
static void free_lvalue(svalue);
static svalue add_number(svalue, svalue);
static void do_trace(struct frame *fp, svalue* sp, uint8* pc);
#define CHECK_TIME (eval_switch &= eval_cost >> (8 * (sizeof eval_cost) - 1))
INLINE void transfer_svalue(svalue *dest, svalue source) {
svalue sv;
sv = *dest;
if (!SV_IS_NUMBER(sv)) {
if (IS_LVALUE(sv)) {
switch(SV_LVALUE(sv).type) {
default:
fatal("Unknown lvalue type\n");
return;
case LVALUE_SIMPLE:
case LVALUE_PROTECTED:
dest = SV_LVALUE(sv).lvalue;
sv = *dest;
}
}
FREE_SVALUE(sv);
}
*dest = source;
}
static svalue indexing_nirwana;
enum byte { z=0, m1 = 255};
svalue interpreter(
register struct frame *fp, register svalue *sp)
{
register uint8 *pc RG1;
#if FP_CLASS_REGISTERS > 3
svalue *fp_variable;
#else
#define fp_variable fp->variable
#endif
#if FP_CLASS_REGISTERS > 4
union control_virtual fp_virtual;
#else
#define fp_virtual fp->virtual
#endif
#if FP_CLASS_REGISTERS > 5
svalue *fp_shared;
#else
#define fp_shared fp->shared
#endif
new_function_call:
pc = fp->funstart;
#ifndef fp_variable
fp_variable = fp->variable;
#endif
#ifndef fp_virtual
fp_virtual = fp->virtual;
#endif
#ifndef fp_shared
fp_shared = fp->shared;
#endif
check_time:
CHECK_TIME;
for(;;) {
int instruction;
next_instruction:
instruction = *pc++ & eval_switch;
dispatch_anew:
eval_cost++;
switch((uint8)instruction) {
case F_ERROR:
if (!inter_errno) {
if (eval_cost >= 0) {
inter_errno = IE_EVALCOST;
} else if (eval_switch) {
fatal("Illegal Instruction 0\n");
break;
} else if (tracing) {
do_trace(fp, sp, pc);
instruction = pc[-1];
goto dispatch_anew;
}
}
return CONST_INVALID;
case 255:
fatal("Illegal Instruction (selected values to span the switch)\n");
return SV_NULL;
default:
fatal("Illegal Instruction\n");
return SV_NULL;
case F_RETURN0:
(*++sp).i = 0;
case F_RETURN:
{
svalue tos;
tos = *sp--;
/*
* Deallocate local variables, unpopped values from lazy popping, and
* break return adresses. No lvalues here.
* Usually, sp >= &fp->locals[-1]. But efun closures directly eat up
* the arguments, and fp > sp.
*/
while (sp >= &fp->locals[0]) {
svalue sv = *sp;
FREE_SVALUE(sv);
sp--;
}
switch(fp->return_mode.i) {
case IR_LOCAL_XF:
inter_ex_fp--;
case IR_LOCAL:
{
int i;
i = fp->funstart[-2];
sp = &fp->arguments[0];
if (i) do {
svalue arg;
arg = *sp--;
if (!SV_IS_NUMBER(arg)) {
if (IS_ALLOCED_LVALUE(arg)) {
free_lvalue(arg);
} else {
FREE_ALLOCED_SVALUE(arg);
}
}
} while (--i);
*++sp = tos;
pc = fp->pc;
fp = fp->previous;
break;
}
case IR_EXTERN_XF:
inter_ex_fp--;
case IR_EXTERN:
return tos;
case IR_CATCH:
sp = &fp->arguments[0];
fp = fp->previous;
*sp = tos;
break;
default:
{
/*
* New function call. We don't know how many arguments there are,
* thus (*fp->return_mode.fun)() has to call make_frame() .
*/
struct control_ret cntret;
cntret = (*fp->return_mode.fun)(tos, fp);
fp = cntret.fp;
sp = cntret.sp;
goto new_function_call;
}
}
break;
}
case F_CALL_FUNCTION_BY_INDEX:
{
int num_arg, ix, fx, iix;
struct program *prog;
svalue *variables;
struct control_ret cntret;
num_arg = *pc;
ix = UEXTRACT16(pc+1);
prog = SV_OBJECT(fp->object).program;
variables = fp->variable;
fx = ix;
iix = prog->flag.many_inherits ?
fp_virtual.function_16[fx] : fp_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;
cntret =
make_frame(sp, num_arg, PR_PCODE(prog) + prog->new_function[fx].start);
cntret.fp->variable = variables;
cntret.fp->previous = fp;
cntret.fp->virtual.function_8 = fp_virtual.function_8 + ix;
cntret.fp->object = fp->object;
fp = cntret.fp;
fp->pc = pc + 3;
fp->program = prog;
fp->shared = prog->shared;
fp->return_mode.i = IR_LOCAL;
sp = cntret.sp;
goto new_function_call;
}
case F_CALL_OTHER:
{
int num_arg;
svalue ob;
struct call_cache_entry *centry;
struct control_ret cntret;
struct program *prog;
num_arg = *pc++;
ob = sp[1-num_arg];
if (SV_IS_NUMBER(ob))
goto bad_arg_1;
if (SV_TYPE(ob) != T_OBJECT) {
if (!SV_IS_STRING(ob))
goto bad_arg_1;
inter_sp = sp;
inter_fp = fp;
ob = find_object(ob, MAX_INHERIT_DEPTH);
if (!ob.p)
goto bad_arg_1;
}
ASSIGN_EVAL_COST(&SV_OBJECT(fp->object));
{
struct cache_call_ret ccret;
ccret = cache_call(ob, sp[2-num_arg], fp);
ob = ccret.u.ob;
centry = ccret.entry;
}
if (!centry) {
svalue sv;
do {
sv = *sp--;
FREE_SVALUE(sv);
} while(--num_arg);
break;
}
cntret = make_frame(sp, num_arg - 2, centry->funstart);
cntret.fp->previous = fp;
fp = cntret.fp;
fp->pc = pc;
fp->funstart = centry->funstart;
fp->object = ob;
fp->variable =
SV_OBJECT(ob).variable + centry->cache_variable_index_offset;
prog = centry->program;
fp->program = prog;
fp->shared = prog->shared;
fp->virtual.function_8 =
prog->virtual.function_8 + centry->cache_virtual_index_offset;
fp->return_mode.i = IR_LOCAL;
sp = cntret.sp;
goto new_function_call;
}
case F_VARARGS:
if (!sp->i)
*sp = REF_INC(NIL_ARRAY);
break;
{
svalue sv;
case F_THIS_OBJECT:
sv = fp->object;
goto push;
case F_V_VIRTUAL:
sv = fp_variable[ fp_virtual.variable[pc[0]] + pc [1] ];
pc += 2;
goto push;
case F_V_GLOBAL16:
sv = fp->variable[UEXTRACT16(pc)];
pc += 2;
goto push;
case F_V_GLOBAL:
sv = fp->variable[*pc++];
goto push;
case F_V_LOCAL:
/* Could extend offset to -0x10f if compiler
would always use F_PICK? where appropriate. */
sv = sp[*pc++ - 0xff];
goto push;
case F_PICK0: case F_PICK1: case F_PICK2: case F_PICK3:
case F_PICK4: case F_PICK5: case F_PICK6: case F_PICK7:
case F_PICK8: case F_PICK9: case F_PICKA: case F_PICKB:
case F_PICKC: case F_PICKD: case F_PICKE: case F_PICKF:
sv = sp[ pc[-1] - F_PICK0 ];
goto push;
case F_V_PARAM:
sv = fp->arguments[*pc++ - 0xff];
goto push;
case F_SHARED:
sv = fp_shared[UEXTRACT16(pc)];
pc += 2;
goto push;
case F_CSHARED3:
sv = fp_shared[*pc++ + 0x300];
goto push;
case F_CSHARED2:
sv = fp_shared[*pc++ + 0x200];
goto push;
case F_CSHARED1:
sv = fp_shared[*pc++ + 0x100];
goto push;
case F_CSHARED0:
sv = fp_shared[*pc++];
push:
COPY_SVALUE_IN_VAR(sv);
*++sp = sv;
break;
}
case F_NCLIT:
(++sp)->i = -*pc++ << 1;
break;
case F_CLIT:
(++sp)->i = *pc++ << 1;
break;
case F_CONST0:
(++sp)->i = 0 << 1;
break;
case F_CONST1:
(++sp)->i = 1 << 1;
break;
{
svalue *svp;
enum use_lvalue_code code;
case F_LV_NIL:
{
svalue old, new;
pc++;
new = *sp;
if (SV_IS_NUMBER(new))
goto ulv_bad_left;
svp = &indexing_nirwana;
old = *svp;
FREE_SVALUE(old);
#ifndef RISC
/* preserving new across _free_svalue() makes svp go into memory on i386 */
new = *sp;
#endif
*svp = new;
sp--;
goto use_lvalue;
}
case F_LV_PARAM:
svp = &fp->arguments[*pc - 0xff];
pc += 2;
goto use_lvalue;
case F_LV_VIRTUAL:
{
svp = &fp_variable[ fp_virtual.variable[pc[0]] + pc [1] ];
pc += 3;
goto use_lvalue;
}
case F_LV_GLOBAL16:
svp = &fp_variable[UEXTRACT16(pc)];
pc += 3;
goto use_lvalue;
case F_LV_GLOBAL:
svp = &fp_variable[*pc];
pc += 2;
goto use_lvalue;
case F_LV_LOCAL16:
svp = &sp[UEXTRACT16(pc) - 0x100ff];
pc += 3;
goto use_lvalue;
case F_LV_LOCAL:
svp = &sp[*pc - 0xff];
pc += 2;
use_lvalue:
code = pc[-1];
use_lvalue_dispatch:
switch(code) {
case ULV_ASSIGN:
{
svalue sv = *svp;
FREE_SVALUE(sv);
sv = *sp;
*svp = sv;
COPY_SVALUE_IN_VAR(sv);
*sp = sv;
/* in case of ENOMEM, the bogus 0 is on the stack, not in the variable */
break;
}
case ULV_VOID_ASSIGN:
{
svalue sv = *svp;
FREE_SVALUE(sv);
*svp = *(sp--);
break;
}
case ULV_HAIRY_ASSIGN:
{
svalue sv = *sp;
/*
* In case of ENOMEM, we don't leave a value, but the assignment is
* correct.
*/
if (_COPY_SVALUE_IN_VAR(sv))
*++sp = sv;
}
case ULV_VOID_HAIRY_ASSIGN:
{
/*
* Inlining transfer_svalue() does not work right, because the source
* is fetched too early, resulting in a register loss.
*/
svalue sv;
sv = *svp;
if (!SV_IS_NUMBER(sv)) {
if (IS_LVALUE(sv)) {
switch(SV_LVALUE(sv).lvalue_type) {
default:
fatal("Unknown lvalue type\n");
continue;
case LVALUE_CBR_CHAR:
{
svalue sv2;
sv2 = *SV_LVALUE(sv).lvalue;
if (sv2.p != SV_LVALUE(sv).parent.p || !SV_IS_2REF_STRING(sv2))
{
sv2 = *sp;
if (!SV_IS_NUMBER(sv2))
deallocate_bogus_char:
FREE_ALLOCED_SVALUE(sv2);
} else {
case LVALUE_CHAR:
sv2 = *sp;
if (!SV_IS_NUMBER(sv2))
goto deallocate_bogus_char;
*SV_LVALUE(sv).index2.p = sv2.i >> 1;
}
sp--;
goto next_instruction;
}
case LVALUE_SIMPLE:
case LVALUE_PROTECTED:
svp = SV_LVALUE(sv).lvalue;
sv = *svp;
}
}
FREE_ALLOCED_SVALUE(sv);
}
*svp = *sp--;
break;
}
case ULV_LV_SINDEX:
(++sp)->i = UEXTRACT16(pc) << 1;
pc += 2;
goto ulv_lv_index;
case ULV_LV_CINDEX:
{
(++sp)->i = *pc++ << 1;
}
ulv_lv_index:
case ULV_LV_INDEX:
{
svalue sv = *svp;
switch(SV_TYPE(sv)) {
case T_LSTRING:
case T_ILSTRING:
case T_GLSTRING:
{
uint8 *str;
mp_uint len, i;
str = SV_LSTRING(sv);
len = SV_LSTRLEN(sv);
goto ulv_lv_index_got_string;
case T_STRING:
if (SV_REF(sv) != 1) {
do {
str = SV_STRING(sv);
len = SV_STRLEN(sv);
FREE_ALLOCED_SVALUE(sv);
*svp = sv = make_astring(str, len);
goto ulv_lv_index_got_strlen;
case T_GSTRING:
if (SV_REF(sv) == 1) {
*svp = unshare_string(sv);
goto ulv_lv_index_get_string;
}
case T_ISTRING:;
} while (SV_REF(sv) != 1);
SV_TYPE_LOC(sv) += T_STRING - T_ISTRING;
}
ulv_lv_index_get_string:
len = SV_STRLEN(sv);
ulv_lv_index_got_strlen:
str = SV_STRING(sv);
ulv_lv_index_got_string:
i = (sp--)->i;
if (i & 1)
goto ulv_lv_bad_right;
i >>= 1;
if (i >= len)
goto ulv_index_error;
fresh_char_lvalue.index2.p = &str[i];
svp = &fresh_char_lvalue_svalue;
break;
}
case T_MAPPING:
svp = get_map_lvalue(sv, *sp--, 1);
break;
case T_LARRAY:
{
mp_uint len, i;
len = SV_ARRAY(sv).x.x->len;
goto ulv_lv_index_got_alen;
case T_ARRAY:
len = SV_ARRAY(sv).len;
ulv_lv_index_got_alen:
i = (sp--)->i;
if (i & 1)
goto ulv_lv_bad_right;
i >>= 1;
if (i >= len) {
ulv_index_error:
/* The index has already been verified to be an integer,
thus it doesn't matter if sp points to it - and it thus
will be freed - or not. */
inter_errno = IE_BAD_INDEX;
error_arg[0].i = (pc[-1] + ULV_CLOSURE_OFFSET) << 1;
goto raise_error;
}
svp = SV_ARRAY(sv).member + i;
break;
}
}
code = eval_switch & *pc++;
goto use_lvalue_dispatch;
}
case ULV_LV_SRINDEX:
(++sp)->i = UEXTRACT16(pc) << 1;
pc += 2;
goto ulv_lv_rindex;
case ULV_LV_CRINDEX:
{
(++sp)->i = *pc++ << 1;
}
ulv_lv_rindex:
case ULV_LV_RINDEX:
{
svalue sv = *svp;
switch(SV_TYPE(sv)) {
case T_LSTRING:
case T_ILSTRING:
case T_GLSTRING:
{
uint8 *str;
mp_uint len, i;
str = SV_LSTRING(sv);
len = SV_LSTRLEN(sv);
goto ulv_lv_rindex_got_string;
case T_STRING:
case T_ISTRING:
case T_GSTRING:
str = SV_STRING(sv);
len = SV_STRLEN(sv);
ulv_lv_rindex_got_string:
i = (sp--)->i;
if (i & 1)
goto ulv_lv_bad_right;
i >>= 1;
i = -i;
i -= len;
if (i >= len)
goto ulv_index_error;
fresh_char_lvalue.index2.p = &str[i];
svp = &fresh_char_lvalue_svalue;
break;
}
case T_LARRAY:
{
mp_uint len, i;
len = SV_ARRAY(sv).x.x->len;
goto ulv_lv_rindex_got_len;
case T_ARRAY:
len = SV_ARRAY(sv).len;
ulv_lv_rindex_got_len:
i = (sp--)->i;
if (i & 1)
goto ulv_lv_bad_right;
i >>= 1;
i = -i;
i -= len;
if (i >= len)
goto ulv_index_error;
svp = SV_ARRAY(sv).member + i;
break;
}
}
code = eval_switch & *pc++;
goto use_lvalue_dispatch;
}
case ULV_SINDEX:
(++sp)->i = UEXTRACT16(pc) << 1;
pc += 2;
goto ulv_index;
case ULV_CINDEX:
{
(++sp)->i = *pc++ << 1;
}
ulv_index:
case ULV_INDEX:
{
svalue sv = *svp;
switch(SV_TYPE(sv)) {
case T_LSTRING:
case T_ILSTRING:
case T_GLSTRING:
{
uint8 *str;
mp_uint len, i;
str = SV_LSTRING(sv);
len = SV_LSTRLEN(sv);
goto ulv_index_got_string;
case T_STRING:
case T_ISTRING:
case T_GSTRING:
str = SV_STRING(sv);
len = SV_STRLEN(sv);
ulv_index_got_string:
i = sp->i;
if (i & 1)
goto ulv_bad_right;
i >>= 1;
if (i >= len)
goto ulv_index_error;
(sp)->i = str[i] << 1;
goto next_instruction;
}
case T_MAPPING:
svp = get_map_lvalue(sv, *sp, 0);
FREE_SVALUE(*sp);
break;
case T_LARRAY:
{
mp_uint len, i;
len = SV_ARRAY(sv).x.x->len;
goto ulv_index_got_len;
case T_ARRAY:
len = SV_ARRAY(sv).len;
ulv_index_got_len:
i = sp->i;
if (i & 1)
goto ulv_bad_right;
i >>= 1;
if (i >= len)
goto ulv_index_error;
svp = SV_ARRAY(sv).member + i;
break;
}
}
sv = *svp;
COPY_SVALUE_IN_VAR(sv);
*sp = sv;
break;
}
case ULV_RINDEX:
{
svalue sv = *svp;
switch(SV_TYPE(sv)) {
case T_LSTRING:
case T_ILSTRING:
case T_GLSTRING:
{
uint8 *str;
mp_uint len, i;
str = SV_LSTRING(sv);
len = SV_LSTRLEN(sv);
goto ulv_rindex_got_string;
case T_STRING:
case T_ISTRING:
case T_GSTRING:
str = SV_STRING(sv);
len = SV_STRLEN(sv);
ulv_rindex_got_string:
i = sp->i;
if (i & 1)
goto ulv_bad_right;
i >>= 1;
i = -i;
i -= len;
if (i >= len)
goto ulv_index_error;
sp->i = str[i] << 1;
goto next_instruction;
}
case T_LARRAY:
{
mp_uint len, i;
len = SV_ARRAY(sv).x.x->len;
goto ulv_rindex_got_len;
case T_ARRAY:
len = SV_ARRAY(sv).len;
ulv_rindex_got_len:
i = sp->i;
if (i & 1)
goto ulv_bad_right;
i >>= 1;
i = -i;
i -= len;
if (i >= len)
goto ulv_index_error;
svp = SV_ARRAY(sv).member + i;
break;
}
}
sv = *svp;
COPY_SVALUE_IN_VAR(sv);
*sp = sv;
break;
}
case ULV_PRE_DEC:
case ULV_POST_DEC:
case ULV_PRE_INC:
case ULV_POST_INC:
{
static int offtab[] = { 0, 2, 0, 0, 0, -2 };
svalue sv = *svp;
if (SV_IS_NUMBER(sv)) {
int index = code - ULV_PRE_DEC;
svp->i = sv.i = sv.i + (code & 4) - 2;
index = pc[-1] - ULV_PRE_DEC;
sv.i += offtab[index];
(++sp)->i = sv.i;
} else switch(SV_TYPE(sv)) {
}
break;
}
case ULV_PRE_DEC_BBRANCH:
{
svalue sv = *svp;
if (SV_IS_NUMBER(sv)) {
svp->i = sv.i - 2;
if (sv.i) goto bbranch;
goto branch_not_taken;
} else switch(SV_TYPE(sv)) {
}
break;
}
#ifdef RISC
#define TEST_VOID ULV_ASS_IS_VOID(code)
#else
#define TEST_VOID ULV_ASS_IS_VOID(pc[-1])
#endif
#define CHECK_VOID \
if (TEST_VOID) \
sp--; \
goto next_instruction;
#define INT_ASSIGN_OP(CODE, OP, ADJI, ADJC, RESMASK) \
case ULV_##CODE: case ULV_VOID_##CODE: \
{ \
for (;;) { \
svalue sv1; \
sv1 = *svp; \
if (SV_IS_NUMBER(sv1)) { \
svalue sv2; \
sv2 = *sp; \
if (!SV_IS_NUMBER(sv2)) \
goto ulv_check_right; \
ADJI(sv1.i, sv2.i); \
*sp = svp->i = (sv1.i OP sv2.i) & RESMASK; \
CHECK_VOID; \
} \
switch(SV_TYPE(sv1)) { \
/* case T_RAW_LVALUE: */ \
default: \
goto ulv_check_left; \
case T_LVALUE: \
svp = SV_LVALUE(sv1).lvalue; \
continue; \
case T_CBR_CHAR_LVALUE: \
{ \
svalue sv2 = *SV_LVALUE(sv1).lvalue; \
if (sv2.p != SV_LVALUE(sv1).parent.p || !SV_IS_2REF_STRING(sv2)) \
goto ulv_discard_char; \
sv1 = *svp; \
} \
case T_CHAR_LVALUE: \
{ \
svalue sv2; \
sv2 = *sp; \
if (!SV_IS_NUMBER(sv2)) \
goto ulv_check_right; \
sv2.i >>= 1; \
ADJC(*SV_LVALUE(sv1).index2.p, sv2.i); \
sv2.i = *SV_LVALUE(sv1).index2.p OP##= sv2.i; \
sp->i = sv2.i << 1; \
CHECK_VOID; \
} \
} \
} break; }
#define NIL_ADJ(v1,v2)
#define MUL_ADJ(v1,v2) ((v2) >>= 1)
#define RSHIFTIADJ(v1,v2) MUL_ADJ(v1,v2); \
if (v2 > sizeof(p_int)*8-1) v2 = sizeof(p_int)*8-1;
#define RSHIFTCADJ(v1,v2) if (v2 > 7) v2 = 7
#define LSHIFTIADJ(v1,v2) MUL_ADJ(v1,v2);if (v2 > sizeof(p_int)*8-1) v1=0, v2=0
#define LSHIFTCADJ(v1,v2) if (v2 > 7) v1 = 0, v2 = 0
INT_ASSIGN_OP(AND, &, NIL_ADJ, NIL_ADJ, ~0)
INT_ASSIGN_OP(OR, |, NIL_ADJ, NIL_ADJ, ~0)
INT_ASSIGN_OP(XOR, ^, NIL_ADJ, NIL_ADJ, ~0)
INT_ASSIGN_OP(MUL, *, MUL_ADJ, NIL_ADJ, ~0)
INT_ASSIGN_OP(DIV, /, MUL_ADJ, NIL_ADJ, ~1)
INT_ASSIGN_OP(MOD, %, NIL_ADJ, NIL_ADJ, ~0)
INT_ASSIGN_OP(RSH, >>, RSHIFTIADJ, RSHIFTCADJ, ~1)
INT_ASSIGN_OP(LSH, <<, LSHIFTIADJ, LSHIFTCADJ, ~0)
case ULV_SUB:
case ULV_VOID_SUB:
{
for (;;) {
svalue sv1 = *svp;
if (SV_IS_NUMBER(sv1)) {
svalue sv2;
sv2 = *sp;
if (!SV_IS_NUMBER(sv2))
goto ulv_check_right;
*sp = svp->i = sv1.i - sv2.i;
CHECK_VOID;
}
switch(SV_TYPE(sv1)) {
/* case T_RAW_LVALUE: */
default:
goto ulv_bad_left;
case T_LVALUE:
svp = SV_LVALUE(sv1).lvalue;
continue;
case T_CBR_CHAR_LVALUE:
{
svalue sv2 = *SV_LVALUE(sv1).lvalue;
if (sv2.p != SV_LVALUE(sv1).parent.p || !SV_IS_2REF_STRING(sv2))
goto ulv_discard_char;
}
case T_CHAR_LVALUE:
{
svalue sv2;
sv2 = *sp;
if (!SV_IS_NUMBER(sv2))
goto ulv_bad_right;
sv2.i >>= 1;
sv2.i = *SV_LVALUE(sv1).index2.p -= sv2.i;
sp->i = sv2.i << 1;
CHECK_VOID;
}
}
}
break;
}
case ULV_ADD:
case ULV_VOID_ADD:
{
svalue sv1;
for (;;) {
sv1 = *svp;
if (SV_IS_NUMBER(sv1)) {
svalue sv2;
sv2 = *sp;
if (SV_IS_NUMBER(sv2)) {
*sp = svp->i = sv1.i + sv2.i;
CHECK_VOID;
}
*svp = add_number(sv1, sv2);
if (TEST_VOID)
sp--;
else
*sp = REF_INC(*svp);
goto next_instruction;
}
switch(SV_TYPE(sv1)) {
case T_STRING:
case T_GSTRING:
case T_ISTRING:
case T_LSTRING:
case T_GLSTRING:
case T_ILSTRING:
*svp = add_string(sv1, *sp);
if (TEST_VOID) {
sp--;
} else {
*sp = REF_INC(*svp);
}
goto next_instruction;
/* case T_RAW_LVALUE: */
default:
goto ulv_bad_left;
case T_LVALUE:
svp = SV_LVALUE(sv1).lvalue;
continue;
#ifdef CBR
case T_CBR_CHAR_LVALUE:
{
svalue sv2 = *SV_LVALUE(sv1).lvalue;
if (sv2.p != SV_LVALUE(sv1).parent.p || !SV_IS_2REF_STRING(sv2))
goto ulv_discard_char;
}
#endif
case T_CHAR_LVALUE:
{
svalue sv2;
sv2 = *sp;
if (!SV_IS_NUMBER(sv2))
goto ulv_bad_right;
sv2.i >>= 1;
sv2.i = *SV_LVALUE(sv1).index2.p += sv2.i;
sp->i = sv2.i << 1;
CHECK_VOID;
}
}
}
break;
}
case ULV_INC:
case ULV_DEC:
{
svalue sv1;
for (;;) {
sv1 = *svp;
if (SV_IS_NUMBER(sv1)) {
svp->i = sv1.i + code - (ULV_DEC + 2);
break;
}
switch(SV_TYPE(sv1)) {
/* case T_RAW_LVALUE: */
default:
goto ulv_bad_left;
case T_LVALUE:
svp = SV_LVALUE(sv1).lvalue;
continue;
#ifndef CBR
case T_CBR_CHAR_LVALUE:
{
svalue sv2 = *SV_LVALUE(sv1).lvalue;
if (sv2.p != SV_LVALUE(sv1).parent.p || !SV_IS_2REF_STRING(sv2))
goto ulv_discard_char;
#if 0
goto next_instruction;
#endif
}
#endif
case T_CHAR_LVALUE:
{
#ifndef RISC
code = pc[-1];
#endif
*SV_LVALUE(sv1).index2.p += ( code - (ULV_DEC + 2) ) >> 1;
goto next_instruction;
}
}
}
break;
}
case ULV_ERROR:
/* Out of memory from get_map_lvalue */
goto raise_error;
case ULV_PLV_INDEX:
fatal("unimplemented\n");
return 0;
ulv_discard_char:
{
svalue sv = *sp;
if (!SV_IS_NUMBER(sv))
goto ulv_bad_right;
CHECK_VOID;
}
ulv_check_left:
{
svalue sv = *svp;
if (SV_TYPE(sv) == T_DESTRUCTED) {
FREE_ALLOCED_SVALUE(sv);
svp->i = 0;
goto use_lvalue;
}
}
ulv_bad_left:
if (!inter_errno) {
inter_errno = IE_BAD_EFUN_ARG;
error_arg[0].i = 1 << 1;
error_arg[1].i = (pc[-1] + ULV_CLOSURE_OFFSET) << 1;
}
goto raise_error;
ulv_check_right:
{
svalue sv = *sp;
if (SV_TYPE(sv) == T_DESTRUCTED) {
FREE_ALLOCED_SVALUE(sv);
sp->i = 0;
goto use_lvalue;
}
}
ulv_bad_right:
if (!inter_errno) {
inter_errno = IE_BAD_EFUN_ARG;
error_arg[1].i = (pc[-1] + ULV_CLOSURE_OFFSET) << 1;
}
goto raise_error;
ulv_lv_bad_right:
sp++;
goto ulv_bad_right;
}
break;
}
#define INT_OP(CODE, OP, ADJ, RESMASK) \
case F_##CODE: \
{ \
svalue sv, sv2; \
\
sv2 = *sp; \
sv = *--sp; \
if ((sv.i | sv2.i) & 1) \
goto check_arg1_2; \
ADJ(sv.i, sv2.i); \
sp->i = (sv.i OP sv2.i) & RESMASK; \
break; \
}
INT_OP(AND, &, NIL_ADJ, ~0)
INT_OP(OR, |, NIL_ADJ, ~0)
INT_OP(XOR, ^, NIL_ADJ, ~0)
INT_OP(MULTIPLY, *, MUL_ADJ, ~0)
INT_OP(DIVIDE, /, MUL_ADJ, ~1)
INT_OP(MOD, %, NIL_ADJ, ~0)
INT_OP(RSH, >>, RSHIFTIADJ, ~1)
INT_OP(LSH, <<, LSHIFTIADJ, ~0)
case F_SUB:
{
svalue sv, sv2;
sv2 = *sp;
sv = *--sp;
if ((sv.i | sv2.i) & 1)
goto check_arg1_2;
sp->i = sv.i - sv2.i;
break;
}
case F_ADD:
{
svalue sv, sv2;
sv2 = *sp;
sv = *--sp;
if (SV_IS_NUMBER(sv)) {
if (SV_IS_NUMBER(sv2)) {
sp->i = sv.i + sv2.i;
break;
}
*sp = add_number(sv, sv2);
break;
}
switch (SV_TYPE(sv)) {
case T_STRING:
case T_GSTRING:
case T_ISTRING:
case T_LSTRING:
case T_GLSTRING:
case T_ILSTRING:
*sp = add_string(sv, sv2);
break;
default:
goto check_arg1_2;
}
break;
}
check_arg1_2:
{
svalue sv;
sv = *sp++;
if (!SV_IS_NUMBER(sv)) {
if (SV_TYPE(sv) == T_DESTRUCTED) {
FREE_ALLOCED_SVALUE(sv);
sp[-1].i = 0;
instruction = pc[-1];
goto dispatch_anew;
}
goto bad_arg_1;
}
sv = *sp;
if (SV_TYPE(sv) == T_DESTRUCTED) {
FREE_ALLOCED_SVALUE(sv);
sp->i = 0;
instruction = pc[-1];
goto dispatch_anew;
}
goto bad_arg_2;
}
{
svalue sv;
case F_BBRANCH_ON_ZERO:
sv = *sp--;
if (!sv.i)
goto bbranch;
maybe_freeing_branch_not_taken:
if (SV_IS_NUMBER(sv)) {
branch_not_taken:
pc++;
break;
}
if (SV_TYPE(sv) == T_DESTRUCTED)
goto freeing_bbranch;
freeing_branch_not_taken:
pc++;
FREE_ALLOCED_SVALUE(sv);
break;
case F_BBRANCH_ON_NON_ZERO:
sv = *sp--;
if (!sv.i)
goto branch_not_taken;
if (SV_IS_NUMBER(sv))
goto bbranch;
if (SV_TYPE(sv) == T_DESTRUCTED)
goto freeing_branch_not_taken;
freeing_bbranch:
FREE_ALLOCED_SVALUE(sv);
bbranch:
pc -= *pc;
CHECK_TIME;
instruction = pc[-1] & eval_switch;
goto dispatch_anew;
case F_BRANCH_ON_ZERO:
sv = *sp--;
if (!sv.i)
goto branch_taken;
if (SV_IS_NUMBER(sv))
goto branch_not_taken;
if (SV_TYPE(sv) != T_DESTRUCTED)
goto freeing_branch_not_taken;
freeing_branch_taken:
FREE_ALLOCED_SVALUE(sv);
case F_BRANCH:
branch_taken:
pc += *pc;
break;
case F_BRANCH_ON_NON_ZERO:
sv = *sp--;
if (!sv.i)
goto branch_not_taken;
if (SV_IS_NUMBER(sv))
goto branch_taken;
if (SV_TYPE(sv) != T_DESTRUCTED)
goto freeing_branch_taken;
goto freeing_branch_not_taken;
case F_LAND:
sv = *sp;
if (!sv.i)
goto branch_taken;
sp--;
goto maybe_freeing_branch_not_taken;
case F_LOR:
sv = *sp;
if (sv.p)
goto branch_taken;
sp--;
goto branch_not_taken;
}
{
svalue sv;
case F_LBRANCH_ON_NON_ZERO:
sv = *sp--;
if (!sv.i)
goto lbranch_not_taken;
if (SV_IS_NUMBER(sv))
goto lbranch_taken;
if (SV_TYPE(sv) != T_DESTRUCTED)
goto freeing_lbranch_taken;
freeing_lbranch_not_taken:
pc += 2;
FREE_ALLOCED_SVALUE(sv);
break;
lbranch_not_taken:
pc += 2;
break;
case F_LBRANCH_ON_ZERO:
sv = *sp--;
if (!sv.i)
goto lbranch_taken;
if (SV_IS_NUMBER(sv))
goto lbranch_not_taken;
if (SV_TYPE(sv) != T_DESTRUCTED)
goto freeing_lbranch_not_taken;
freeing_lbranch_taken:
FREE_ALLOCED_SVALUE(sv);
case F_LBRANCH:
lbranch_taken:
pc += EXTRACT16(pc);
break;
}
{
svalue sv;
case F_XLBRANCH_ON_NON_ZERO:
sv = *sp--;
if (!sv.i)
goto xlbranch_not_taken;
if (SV_IS_NUMBER(sv))
goto xlbranch_taken;
if (SV_TYPE(sv) != T_DESTRUCTED)
goto freeing_xlbranch_taken;
freeing_xlbranch_not_taken:
pc += 3;
FREE_ALLOCED_SVALUE(sv);
break;
xlbranch_not_taken:
pc += 3;
break;
case F_XLBRANCH_ON_ZERO:
sv = *sp--;
if (!sv.i)
goto xlbranch_taken;
if (SV_IS_NUMBER(sv))
goto xlbranch_not_taken;
if (SV_TYPE(sv) != T_DESTRUCTED)
goto freeing_xlbranch_not_taken;
freeing_xlbranch_taken:
FREE_ALLOCED_SVALUE(sv);
case F_XLBRANCH:
xlbranch_taken:
pc += EXTRACT24(pc);
break;
}
case F_CATCH:
sp += 2;
sp[-1].p = pc;
*sp = TO_SVALUE(&catch_value);
pc++;
break;
case F_END_CATCH:
/* discard catch value and pc, and insert 0 */
(*--sp).i = 0;
break;
case F_POP:
{
svalue sv = *sp--;
FREE_SVALUE(sv);
break;
}
case F_NEGATE:
{
svalue sv = *sp;
if (SV_IS_NUMBER(sv))
sp->i = - sv.i;
else if (SV_TYPE(sv) == T_FLOAT)
SV_FLOAT(*sp) = - SV_FLOAT(sv);
else
goto bad_arg_1;
break;
}
case F_NOT:
{
svalue sv = *sp;
if (sv.i) {
if (!SV_IS_NUMBER(sv)) {
sp->i = (SV_TYPE(sv) == T_DESTRUCTED) << 1;
FREE_ALLOCED_SVALUE(sv);
break;
}
sp->i = 0;
} else {
sp->i = 2;
}
break;
}
case F_EQ:
{
svalue sv2 = *sp--;
svalue sv1 = *sp;
if (SV_IS_NUMBER(sv1)) {
if (SV_IS_NUMBER(sv2)) {
sp->i = (sv1.i == sv2.i) << 1;
break;
}
sp->i = (sv1.i == 0 && SV_TYPE(sv2) == T_DESTRUCTED) << 1;
FREE_ALLOCED_SVALUE(sv2);
break;
}
if (SV_IS_NUMBER(sv2)) {
sp->i = (sv2.i == 0 && SV_TYPE(sv1) == T_DESTRUCTED) << 1;
FREE_ALLOCED_SVALUE(sv1);
break;
}
switch (SV_TYPE(sv1)) {
case T_DESTRUCTED:
sp->i = (SV_TYPE(sv2) == T_DESTRUCTED) << 1;
break;
case T_STRING:
case T_LSTRING:
case T_ISTRING:
case T_ILSTRING:
sv1 = make_string_global(sv1);
case T_GSTRING:
case T_GLSTRING:
sv2 = make_string_global(sv2);
case T_OBJECT:
case T_ARRAY:
case T_MAPPING:
sp->i = (sv1.p == sv2.p) << 1;
break;
}
FREE_ALLOCED_SVALUE(sv1);
FREE_ALLOCED_SVALUE(sv2);
break;
}
case F_NE:
{
svalue sv2 = *sp--;
svalue sv1 = *sp;
if (SV_IS_NUMBER(sv1)) {
if (SV_IS_NUMBER(sv2)) {
sp->i = (sv1.i != sv2.i) << 1;
break;
}
sp->i = (sv1.i != 0 || SV_TYPE(sv2) != T_DESTRUCTED) << 1;
FREE_ALLOCED_SVALUE(sv2);
break;
}
if (SV_IS_NUMBER(sv2)) {
sp->i = (sv2.i != 0 || SV_TYPE(sv1) != T_DESTRUCTED) << 1;
FREE_ALLOCED_SVALUE(sv1);
break;
}
switch (SV_TYPE(sv1)) {
case T_DESTRUCTED:
sp->i = (SV_TYPE(sv2) != T_DESTRUCTED) << 1;
break;
case T_STRING:
case T_LSTRING:
case T_ISTRING:
case T_ILSTRING:
sv1 = make_string_global(sv1);
case T_GSTRING:
case T_GLSTRING:
sv2 = make_string_global(sv2);
case T_OBJECT:
case T_ARRAY:
case T_MAPPING:
sp->i = (sv1.p != sv2.p) << 1;
break;
}
FREE_ALLOCED_SVALUE(sv1);
FREE_ALLOCED_SVALUE(sv2);
break;
}
case F_GE:
{
svalue sv2 = *sp--;
svalue sv1 = *sp;
if (SV_IS_NUMBER(sv1)) {
if (SV_IS_NUMBER(sv2)) {
sp->i = (sv1.i >= sv2.i) << 1;
break;
}
if (SV_TYPE (sv2) == T_FLOAT) {
sp->i = (sv1.i >> 1 >= SV_FLOAT(sv2)) << 1;
FREE_ALLOCED_SVALUE(sv2);
}
sp++;
goto bad_arg_2;
}
if (SV_IS_STRING (sv1)) {
if (SV_IS_NUMBER(sv2) || !SV_IS_STRING(sv2)) {
sp++;
goto bad_arg_2;
}
sp->i = (sv_strcmp(sv1, sv2) >= 0) << 1;
FREE_ALLOCED_SVALUE(sv1);
FREE_ALLOCED_SVALUE(sv2);
break;
}
if (SV_TYPE (sv1) == T_FLOAT) {
if (SV_IS_NUMBER(sv2)) {
sp->i = (SV_FLOAT(sv1) >= sv2.i >> 1) << 1;
FREE_ALLOCED_SVALUE(sv1);
break;
}
if (SV_TYPE (sv2) != T_FLOAT) {
sp++;
goto bad_arg_2;
}
sp->i = (SV_FLOAT(sv1) >= SV_FLOAT(sv2)) << 1;
FREE_ALLOCED_SVALUE(sv1);
FREE_ALLOCED_SVALUE(sv2);
break;
}
goto bad_arg_1;
}
case F_LE:
{
svalue sv2 = *sp--;
svalue sv1 = *sp;
if (SV_IS_NUMBER(sv1)) {
if (SV_IS_NUMBER(sv2)) {
sp->i = (sv1.i <= sv2.i) << 1;
break;
}
if (SV_TYPE (sv2) == T_FLOAT) {
sp->i = (sv1.i >> 1 <= SV_FLOAT(sv2)) << 1;
FREE_ALLOCED_SVALUE(sv2);
}
sp++;
goto bad_arg_2;
}
if (SV_IS_STRING (sv1)) {
if (SV_IS_NUMBER(sv2) || !SV_IS_STRING(sv2)) {
sp++;
goto bad_arg_2;
}
sp->i = (sv_strcmp(sv1, sv2) <= 0) << 1;
FREE_ALLOCED_SVALUE(sv1);
FREE_ALLOCED_SVALUE(sv2);
break;
}
if (SV_TYPE (sv1) == T_FLOAT) {
if (SV_IS_NUMBER(sv2)) {
sp->i = (SV_FLOAT(sv1) <= sv2.i >> 1) << 1;
FREE_ALLOCED_SVALUE(sv1);
break;
}
if (SV_TYPE (sv2) != T_FLOAT) {
sp++;
goto bad_arg_2;
}
sp->i = (SV_FLOAT(sv1) <= SV_FLOAT(sv2)) << 1;
FREE_ALLOCED_SVALUE(sv1);
FREE_ALLOCED_SVALUE(sv2);
break;
}
goto bad_arg_1;
}
case F_GT:
{
svalue sv2 = *sp--;
svalue sv1 = *sp;
if (SV_IS_NUMBER(sv1)) {
if (SV_IS_NUMBER(sv2)) {
sp->i = (sv1.i > sv2.i) << 1;
break;
}
if (SV_TYPE (sv2) == T_FLOAT) {
sp->i = (sv1.i >> 1 > SV_FLOAT(sv2)) << 1;
FREE_ALLOCED_SVALUE(sv2);
}
sp++;
goto bad_arg_2;
}
if (SV_IS_STRING (sv1)) {
if (SV_IS_NUMBER(sv2) || !SV_IS_STRING(sv2)) {
sp++;
goto bad_arg_2;
}
sp->i = (sv_strcmp(sv1, sv2) > 0) << 1;
FREE_ALLOCED_SVALUE(sv1);
FREE_ALLOCED_SVALUE(sv2);
break;
}
if (SV_TYPE (sv1) == T_FLOAT) {
if (SV_IS_NUMBER(sv2)) {
sp->i = (SV_FLOAT(sv1) > sv2.i >> 1) << 1;
FREE_ALLOCED_SVALUE(sv1);
break;
}
if (SV_TYPE (sv2) != T_FLOAT) {
sp++;
goto bad_arg_2;
}
sp->i = (SV_FLOAT(sv1) > SV_FLOAT(sv2)) << 1;
FREE_ALLOCED_SVALUE(sv1);
FREE_ALLOCED_SVALUE(sv2);
break;
}
goto bad_arg_1;
}
case F_LT:
{
svalue sv2 = *sp--;
svalue sv1 = *sp;
if (SV_IS_NUMBER(sv1)) {
if (SV_IS_NUMBER(sv2)) {
sp->i = (sv1.i < sv2.i) << 1;
break;
}
if (SV_TYPE (sv2) == T_FLOAT) {
sp->i = (sv1.i >> 1 < SV_FLOAT(sv2)) << 1;
FREE_ALLOCED_SVALUE(sv2);
}
sp++;
goto bad_arg_2;
}
if (SV_IS_STRING (sv1)) {
if (SV_IS_NUMBER(sv2) || !SV_IS_STRING(sv2)) {
sp++;
goto bad_arg_2;
}
sp->i = (sv_strcmp(sv1, sv2) < 0) << 1;
FREE_ALLOCED_SVALUE(sv1);
FREE_ALLOCED_SVALUE(sv2);
break;
}
if (SV_TYPE (sv1) == T_FLOAT) {
if (SV_IS_NUMBER(sv2)) {
sp->i = (SV_FLOAT(sv1) < sv2.i >> 1) << 1;
FREE_ALLOCED_SVALUE(sv1);
break;
}
if (SV_TYPE (sv2) != T_FLOAT) {
sp++;
goto bad_arg_2;
}
sp->i = (SV_FLOAT(sv1) < SV_FLOAT(sv2)) << 1;
FREE_ALLOCED_SVALUE(sv1);
FREE_ALLOCED_SVALUE(sv2);
break;
}
goto bad_arg_1;
}
case F_SIZEOF:
{
svalue sv = *sp;
p_int size;
if (SV_IS_NUMBER (sv)) {
if (!sv.i)
break;
goto bad_arg_1;
}
switch (SV_TYPE(sv)) {
default:
goto bad_arg_1;
case T_STRING:
case T_GSTRING:
case T_ISTRING:
size = SV_STRLEN(sv);
break;
case T_LSTRING:
case T_GLSTRING:
case T_ILSTRING:
size = SV_LSTRLEN(sv);
break;
case T_ARRAY:
size = SV_ARRAY_LEN(sv);
break;
case T_LARRAY:
size = SV_LARRAY_LEN(sv);
break;
case T_MAPPING:
{
struct hmap_x *hm = SV_MAPPING(sv).x.hash;
size = CMAP_SIZE(SV_MAPPING(sv).condensed) +
(MAPX_TYPE(hm) == IT_X_HMAP ? hm->used - hm->condensed_deleted : 0);
break;
}
}
FREE_ALLOCED_SVALUE(sv);
sp->i = size << 1;
break;
}
case F_CLONE_OBJECT:
sp = clone_object(sp, fp);
break;
case F_TEXT_MESSAGE:
sp = f_text_message(sp, fp);
break;
case F_RANGE:
{
svalue sv = *sp--;
sp = f_range(sp, fp, sv, 0);
break;
}
case F_RANGE2:
*++sp = INT_SVALUE(1);
case F_NR_RANGE:
{
svalue sv = *sp--;
sp = f_range(sp, fp, sv, 1);
break;
}
case F_MEMBER:
sp = f_member(sp);
break;
case F_CLOSURE:
{
int ix = UEXTRACT16(pc);
svalue sv;
pc += 2;
if (ix >= CLOSURE_EFUN_OFFS) {
if (ix < CLOSURE_SIMUL_EFUN_OFFS &&
instrs[ix - CLOSURE_EFUN_OFFS].Default == -1)
ix += CLOSURE_OPERATOR - CLOSURE_EFUN;
sv = ALLOC_TTS(T_CLOSURE, 1, ix, sizeof(struct efun_closure));
if (sv.p)
SV_CLOSURE(sv).efun.ob = fp->object;
} else if (ix >= CLOSURE_IDENTIFIER_OFFS) {
sv = ALLOC_TTS(T_CLOSURE, 1, CLOSURE_IDENTIFIER,
sizeof(struct lfun_closure));
ix += -CLOSURE_IDENTIFIER_OFFS +
(fp_variable - SV_OBJECT(fp->object).variable);
if (sv.p) {
SV_CLOSURE(sv).lfun.index = ix;
SV_CLOSURE(sv).lfun.ob = fp->object;
}
} else {
sv = ALLOC_TTS(T_CLOSURE, 1, CLOSURE_LFUN, sizeof(struct lfun_closure));
ix += fp_virtual.function_8
- SV_OBJECT(fp->object).program->virtual.function_8;
if (sv.p) {
SV_CLOSURE(sv).lfun.index = ix;
SV_CLOSURE(sv).lfun.ob = fp->object;
}
}
*++sp = sv;
break;
}
case F_SPRINTF:
sp = f_sprintf(sp, *pc++);
break;
case F_ESCAPE:
#define XCASE(n) case n - 0x100
switch(*pc++) {
default:
fatal("Illegal Instruction\n");
return SV_NULL;
XCASE(F_SET_INTERACTIVE_HOOK):
sp = f_set_interactive_hook(sp, fp);
break;
XCASE(F_SHADOW):
sp = f_shadow(sp, fp);
break;
XCASE(F_PREVIOUS_OBJECT):
{
svalue sv = *sp;
struct frame *pfp = fp;
if (!SV_IS_NUMBER(sv))
goto bad_xarg_1;
do
pfp = pfp->previous;
while (pfp && (sv.i -= 2) >= 0);
if (pfp)
*sp = REF_INC(pfp->object);
else
sp->i = 0;
break;
}
XCASE(F_RN_RANGE):
{
svalue sv = *sp--;
sp = f_range(sp, fp, sv, -2);
break;
}
XCASE(F_R_RANGE2):
*++sp = INT_SVALUE(1);
XCASE(F_RR_RANGE):
{
svalue sv = *sp--;
sp = f_range(sp, fp, sv, -1);
break;
}
XCASE(F_GET_DIR):
sp = f_get_dir(sp, fp);
break;
XCASE(F_WRITE_FILE):
sp = f_write_file(sp, fp);
break;
XCASE(F_TYPEOF):
{
svalue sv = (*sp);
int i = SV_TYPE(sv);
FREE_SVALUE(sv);
sp->i = i << 1;
break;
}
XCASE(F_UNDEF):
{
if (!inter_errno) {
inter_errno = IE_UNDEF;
}
goto raise_error;
}
}
break;
case F_TEFUN:
sp = (*efun_table[*pc++ - 128])(sp);
break;
}} /* end main switch and for(;;) */
bad_xarg_1:
pc--;
bad_arg_1:
if (inter_errno)
goto raise_error;
error_arg[0].i = 1 << 1;
goto bad_arg_x;
bad_arg_2:
if (inter_errno)
goto raise_error;
error_arg[0].i = 2 << 1;
bad_arg_x:
inter_errno = IE_BAD_EFUN_ARG;
goto raise_error;
raise_error:
for(;fp->return_mode.i < IR_CATCH;) {
fp = fp->previous;
}
fatal("Error handling unimplemented\n");
return SV_NULLP;
}
#define CACHE_SIZE (1 << CALL_CACHE_BITS)
#define LEAF_INHERIT_CACHE_SIZE (1 << LEAF_INHERIT_CACHE_BITS)
struct call_cache_cell call_cache[CACHE_SIZE];
struct leaf_inherit_cache_cell leaf_inherit_cache[LEAF_INHERIT_CACHE_SIZE];
struct cache_call_ret cache_call_1(struct program *prog, svalue fun) {
register p_int id;
register struct call_cache_cell *cell;
register struct cache_call_ret ret;
if (prog->flag.leaf_inherit) {
int fx;
static struct call_cache_entry entry;
ret =
cache_call_1((struct program *)(prog->inherit[1].program & ~3), fun);
if ((int8)ret.u.unstatic <= 0)
/* Found in superclass. Because this is a leaf inherit, offsets
for virtual and variable are both 0, no matter if inherited or
not. Thus, we can return the unaltered result. */
return ret;
if (prog->function.search.offset <= 8) {
/* No more than 15 functions to search (max four iterations).
Don't bother with the cache. */
fx = leaf_inherit_find_function(prog, fun);
} else {
register p_int id;
register struct leaf_inherit_cache_cell *cell;
id = prog->id_number;
cell = &leaf_inherit_cache[
( id ^ fun.i ^
(fun.i >> LEAF_INHERIT_CACHE_BITS) ) & (LEAF_INHERIT_CACHE_SIZE-1) ];
if (cell->tag[0].cache_id == id && cell->tag[0].name.p == fun.p)
fx = cell->index[0];
else if (cell->tag[1].cache_id == id && cell->tag[1].name.p == fun.p)
fx = cell->index[1];
else if (cell->tag[2].cache_id == id && cell->tag[2].name.p == fun.p)
fx = cell->index[2];
else {
int i;
i = cell->last_written - 1;
if (i < 0)
i = 2;
cell->last_written = i;
cell->tag[i].cache_id = id;
FREE_ALLOCED_SVALUE(cell->tag[i].name);
REF_INC_IN_VAR(fun);
cell->tag[i].name = fun;
fx = leaf_inherit_find_function(prog, fun);
cell->index[i] = fx;
}
}
if (fx < 0) {
ret.u.unstatic = 1;
} else {
entry.program = prog;
entry.funstart = PR_PCODE(prog) + prog->new_function[fx].start;
ret.u.unstatic = (prog->new_function[fx].flags & TYPE__STATIC)
/ (0x80 / TYPE__STATIC);
ret.entry = &entry;
}
return ret;
}
id = prog->id_number;
cell = &call_cache[
( id ^ fun.i ^ ( fun.i >> CALL_CACHE_BITS ) ) & (CACHE_SIZE-1) ];
if (cell->entry[0].cache_id == id &&
cell->entry[0].name.p == fun.p)
{
cell->last_written = 0;
ret.u.unstatic = cell->unstatic[0];
ret.entry = &cell->entry[0];
return ret;
} else if (cell->entry[1].cache_id == id &&
cell->entry[1].name.p == fun.p)
{
cell->last_written = 1;
ret.u.unstatic = cell->unstatic[1];
ret.entry = &cell->entry[1];
return ret;
} else if (cell->entry[2].cache_id == id &&
cell->entry[2].name.p == fun.p)
{
cell->last_written = 2;
ret.u.unstatic = cell->unstatic[2];
ret.entry = &cell->entry[2];
return ret;
} else {
int i, fx;
i = cell->last_written - 1;
if (i < 0)
i = 2;
cell->last_written = i;
ret.entry = &cell->entry[i];
ret.entry->cache_id = id;
FREE_ALLOCED_SVALUE(ret.entry->name);
ret.entry->name = fun;
REF_INC_IN_VAR(fun);
fx = find_function(prog, fun);
if (fx >= 0) {
int function_offset, variable_offset, iix;
uint8 *funstart;
ret.u.unstatic = 1;
iix = prog->flag.many_inherits ?
prog->virtual.function_16[fx] : prog->virtual.function_8[fx];
function_offset = fx;
variable_offset = 0;
while(iix) {
struct inherit *inheritp;
p_int progi;
inheritp = &prog->inherit[iix];
progi = inheritp->program;
ret.u.unstatic &= progi;
prog = (struct program *)(progi & ~3);
fx -= inheritp->virtual_offset;
variable_offset += inheritp->variable_offset;
iix = prog->virtual.function_8[fx];
}
ret.u.unstatic <<= 7;
ret.u.unstatic &= prog->new_function[fx].flags;
funstart = PR_PCODE(prog) + prog->new_function[fx].start;
cell->unstatic[i] = ret.u.unstatic;
ret.entry->program = prog;
ret.entry->funstart = funstart;
ret.entry->cache_virtual_index_offset = function_offset - fx;
ret.entry->cache_variable_index_offset = variable_offset;
return ret;
}
cell->unstatic[i] = ret.u.unstatic = 1;
return ret;
}
}
/*
* If the function is static, check fp->object for match.
* return a 'not found' cell for static w/ object mismatch
*/
struct cache_call_ret cache_call(svalue ob, svalue fun, struct frame *fp) {
register struct cache_call_ret ret;
/* DONT call make_string_global here, since this would mean we would have
to free fun right here, lest the copy of the caller could be trans-
formed to a dangling pointer if it was an ISTRING with ref count 1. */
fun = findstring(fun);
if (OP_X_FLAGS(SV_OBJECTP(ob)) & O_X_SHADOWED) {
do {
ob = SV_OBJECT(ob).x.x->shadowed_by;
} while (SV_OBJECT(ob).x.x->shadowed_by.i);
}
retry_for_shadowee:
if (SV_OBJECT(ob).flags & O_SWAPPED) {
if (load_ob_from_swap(ob) < 0) {
/* IE_NOMEM */
static uint8 error_pcode[] = { 0, 1, /* eat variable as argument */
F_RAISE_ERROR >> F_ESCAPE_BITS, F_RAISE_ERROR & 0xff
};
static struct call_cache_entry error_entry = {
NIL_STRING, 0, &nil_program, &error_pcode[2]
};
ret.entry = &error_entry;
goto do_return;
}
}
ret = cache_call_1(SV_OBJECT(ob).program, fun);
if (!(ret.u.unstatic & 0x80) && ret.u.unstatic + ob.p != fp->object.p)
{
if (O_HAS_X(&SV_OBJECT(ob)) && (ob = SV_OBJECT(ob).x.x->shadowing).i )
{
goto retry_for_shadowee;
}
ret.entry = 0;
}
do_return:
ret.u.ob = ob;
return ret;
}
/*
* having make_varargs_frame as a separate function at least keeps
* the other parts of make_varargs() free of bogus register allocations
*/
static INLINE struct control_ret make_varargs_frame(
svalue *sp, int num_arg, uint8 *funstart)
{
struct control_ret ret;
int i;
svalue a, v, *dest;
struct varargs_lv_field *lvp;
ret.sp = sp;
a = ALLOC(T_ARRAY, 1,
sizeof SV_ARRAY(a) - 4 - sizeof SV_ARRAY(a).member +
sizeof SV_ARRAY(a).member[0] * num_arg);
if (!a.i) {
do {
svalue sv = *ret.sp--;
FREE_SVALUE(sv);
} while(--num_arg);
v.i = 0;
} else {
SV_ARRAY(a).len = num_arg;
dest = &SV_ARRAY(a).member[num_arg];
v.i = 0;
do {
svalue sv = *--sp;
if (!SV_IS_NUMBER(sv) && SV_TYPE(sv) == T_LVALUE) {
if (!v.i) {
mp_int size;
size = sizeof SV_VARARGS(v) - 4 -
sizeof SV_VARARGS(v).lvalues +
sizeof SV_VARARGS(v).lvalues[0] * num_arg;
v = ALLOC(T_VARARGS, 1, size);
/*
* In oder to be able to use a scratchpad register for sv,
* we have to re-read it after this function call.
*/
sv = *sp;
if (!v.i)
goto get_copy;
SV_VARARGS(v).alloced_size = size;
SV_ARRAY(a).ref = 2;
SV_VARARGS(v).array = a;
lvp = &SV_VARARGS(v).lvalues[0];
}
lvp->index = num_arg;
lvp->lvalue = sv;
lvp++;
get_copy:
sv = *SV_LVALUE(sv).lvalue;
COPY_SVALUE_IN_VAR(sv);
}
*--dest = sv;
} while (--num_arg);
}
ret.fp = (struct frame *)ret.sp;
ret.fp->funstart = funstart;
ret.sp = (svalue *)&ret.fp[1];
*++ret.sp = v;
i = funstart[-1] - 2;
if (i) do {
(++ret.sp)->i = 0;
} while (--i);
*++ret.sp = a;
return ret;
}
struct control_ret make_frame(svalue *sp, int num_arg, uint8 *funstart) {
/* funstart[-2] : num_arg funstart[-1]: num_local */
/*
* If there is an out of memory condition, errno and eval_switch will
* be set appropriately by alloc(). We have still to make sure that
* we don't dereference the NULL pointers and that subsequent operations
* leave the heap in a consistent state.
*/
struct control_ret ret;
int i;
ret.sp = sp;
num_arg -= funstart[-2];
if (num_arg) {
if (num_arg > 0) {
if (funstart[0] == F_VARARGS) {
return make_varargs_frame(ret.sp, num_arg, funstart);
} else {
do {
svalue sv = *ret.sp--;
FREE_SVALUE(sv);
} while(--num_arg);
}
} else {
do {
(++ret.sp)->i = 0;
} while (++num_arg);
}
}
ret.fp = (struct frame *)ret.sp;
ret.fp->funstart = funstart;
ret.sp = CONTROL_LOCALS(ret.fp) - 1;
i = funstart[-1];
if (i) do {
(++ret.sp)->i = 0;
} while (--i);
return ret;
}
void push_svalue(svalue sv) {
*++inter_sp = COPY_SVALUE(sv);
}
svalue call_hook(svalue hook, svalue object, int num_arg) {
svalue *sp;
if (SV_IS_NUMBER(hook)) {
sp = inter_sp;
} else {
switch(SV_TYPE(hook)) {
default:
REF_INC_IN_VAR(hook);
sp = inter_sp;
break;
case T_STRING: case T_ISTRING: case T_GSTRING:
case T_LSTRING: case T_ILSTRING: case T_GLSTRING:
{
struct call_cache_entry *centry;
struct control_ret cntret;
{
struct cache_call_ret ccret;
ccret = cache_call(object, hook, inter_fp);
centry = ccret.entry;
object = ccret.u.ob;
}
hook.i = 0;
sp = inter_sp;
if (centry) {
struct program *prog;
cntret = make_frame(sp, num_arg, centry->funstart);
cntret.fp->previous = inter_fp;
cntret.fp->object = object;
cntret.fp->variable = SV_OBJECT(object).variable +
centry->cache_variable_index_offset;
cntret.fp->program = prog = centry->program;
cntret.fp->virtual.function_8 = prog->virtual.function_8;
cntret.fp->shared = prog->shared;
cntret.fp->return_mode.i = IR_EXTERN;
hook = interpreter(cntret.fp, cntret.sp);
sp = &cntret.fp->arguments[0];
num_arg = FUNSTART2NARGS(cntret.fp->funstart);
}
break;
}
case T_CLOSURE:
{
struct control_ret cntret =
closure_frame(hook, inter_sp, inter_fp, num_arg, 0, IR_EXTERN);
hook = interpreter(cntret.fp, cntret.sp);
sp = &cntret.fp->arguments[0];
num_arg = FUNSTART2NARGS(cntret.fp->funstart);
break;
}
}
}
while (--num_arg >= 0) {
svalue sv = *sp--;
FREE_SVALUE(sv);
}
inter_sp = sp;
return hook;
}
static void free_lvalue(svalue sv) {
switch(SV_LVALUE(sv).type) {
default:
fatal("Unknown lvalue type\n");
return;
case LVALUE_SIMPLE:
return;
case LVALUE_CBR_CHAR:
FREE_SVALUE(SV_LVALUE(sv).index1); /* svalue lvalue points into (0 if none) */
case LVALUE_PROTECTED:
case LVALUE_NN_INDEXED:
case LVALUE_NR_INDEXED:
case LVALUE_RN_INDEXED:
case LVALUE_RR_INDEXED:
sv = SV_LVALUE(sv).parent;
FREE_SVALUE(sv);
return;
}
}
void free_varargs(svalue sv) {
/* FIXME: assign values from the array, free the latter */
free_block(sv.p, SV_VARARGS(sv).alloced_size);
}
static svalue add_number(svalue sv0, svalue sv1) {
svalue sv2;
if (SV_IS_STRING(sv2)) {
char buf[P_INT_PRINT_SIZE];
sprintf(buf, "%ld", sv0.i >> 1);
sv0 = make_string(buf, strlen(buf));
sv2 = add_string(sv0, sv1);
} else if (SV_TYPE(sv1) == T_FLOAT) {
sv2 = ALLOC_FLOAT;
SV_FLOAT(sv2) = (sv0.i >> 1) + SV_FLOAT(sv1);
} else if (SV_TYPE(sv1) == T_DESTRUCTED) {
sv2 = sv0;
} else {
bad_efun_arg(2);
return sv1;
}
FREE_ALLOCED_SVALUE(sv1);
return sv2;
}
void error(int ie_errno, ...) {
extern char error_nargs[];
int nargs, i;
va_list va;
svalue *dest, sv;
nargs = error_nargs[ie_errno];
PUSH_NUMBER(ie_errno);
dest = inter_sp += nargs;
va_start(va, ie_errno);
for (i = 0; i < nargs; i++) {
dest[i] = va_arg(va, svalue);
}
va_end(va);
sv = call_hook(driver_hook[H_RUNTIME_ERROR], master_ob, nargs+1);
FREE_SVALUE(sv);
}
static void do_trace(struct frame *fp, svalue* sp, uint8* pc) {
fatal("tracing unimplemented\n");
}
void bad_efun_arg(int n) {
if (!inter_errno) {
eval_switch = 0;
inter_errno = IE_BAD_EFUN_ARG;
error_arg[0].i = n << 1;
}
}
void fpe_handler() {
if (!inter_errno) {
inter_errno = IE_SIGFPE;
eval_switch = off;
}
}
p_int _privilege_violation(p_int what, svalue where, svalue *sp) {
svalue fp_object = inter_fp->object;
svalue sv;
if (SV_OBJECT(fp_object).x.uid->self->name.p ==
driver_hook[H_PRIVILEGED_UID].p)
return 1;
(++sp)->i = what;
REF_INC_IN_VAR(fp_object);
*++sp = fp_object;
REF_INC_IN_VAR(where);
*++sp = where;
inter_sp = sp;
sv = call_hook(driver_hook[H_PRIVILEGE_VIOLATION], fp_object, 3);
if (!SV_IS_NUMBER(sv) || sv.i < 0) {
error(IE_PRIVILEGED, "%d%O", what, where);
}
return sv.i;
}
void assert_master_ob_loaded() {
master_ob = find_object(master_name, MAX_INHERIT_DEPTH);
}
svalue *f_set_driver_hook(svalue *sp) {
svalue hn, hv, sv, *svp;
hn = sp[-1];
if (!SV_IS_NUMBER(hn)) {
bad_efun_arg(1);
return sp;
}
hv = sp[0];
svp = &driver_hook[hn.i >> 1];
sv = *svp;
*svp = hv;
FREE_SVALUE(sv);
return sp - 2;
}
void nilframe() {
struct frame *fp = (struct frame *)(inter_stack.general-1);
inter_fp = fp;
inter_sp = (svalue *)&fp[1];
fp->object = TO_SVALUE(&nil_object);
inter_ex_fp = inter_stack.external-1;
}
void initialize_interpreter() {
int i;
SV_STRREF(NIL_STRING) = ~0;
for (i = NELEM(call_cache); --i >= 0; ) {
call_cache[i].entry[0].name = NIL_STRING;
call_cache[i].entry[1].name = NIL_STRING;
call_cache[i].entry[2].name = NIL_STRING;
}
nilframe();
eval_cost = -MAX_COST;
eval_switch = on;
}