Implement the remaining bytecodes. Adjust some of the numbering.
Also, use #<undefined> for "not yet initialized" and #f for "no value".
This commit is contained in:
parent
61e0583932
commit
10fbc269c5
180
doc/bytecode.txt
180
doc/bytecode.txt
|
|
@ -7,78 +7,85 @@ expression: up to 64, 1 out, 2 in
|
|||
00xxxxxx out in in: binary-expr, x > 1
|
||||
unary-expr: up to 255, 1 out, 1 in
|
||||
00 invalid / permanently reserved
|
||||
|
||||
01 (set! out in)
|
||||
02 (set! out (car in))
|
||||
03 (set! out (cdr in))
|
||||
04 (set! out (unbox in))
|
||||
05 (set! out (not in)) ; if in == #f then #t else #f
|
||||
06 (set! out (nil? in)) ; value => bool
|
||||
07 (set! out (pair? in)) ; value => bool
|
||||
08 (set! out (box? in)) ; value => bool
|
||||
09 (set! out (vector? in)) ; value => bool
|
||||
0a (set! out (byte-string? in)) ; value => bool
|
||||
0b (set! out (struct? in)) ; value => bool
|
||||
0c (set! out (fixnum? in)) ; value => bool
|
||||
0d (set! out (float? in)) ; value => bool
|
||||
0e (set! out (make-box in)) ; value => box
|
||||
0f (set! out (make-struct in)) ; metastruct => struct
|
||||
10 (set! out (make-float in)) ; fixnum => float
|
||||
11 (set! out (lambda in)) ; template-or-lambda => lambda
|
||||
12 (set! out (bit-not in)) ; one's complement / bitwise negation
|
||||
13 (set! out (fix- in)) ; two's complement / arithmetic negation
|
||||
14 (set! out (float- in)) ; floating-point negation
|
||||
02 (set! out (unbox in))
|
||||
03 (set! out (car in))
|
||||
04 (set! out (cdr in))
|
||||
|
||||
08 (set! out (boolean? in)) ; value => bool
|
||||
09 (set! out (fixnum? in)) ; value => bool
|
||||
0a (set! out (box? in)) ; value => bool
|
||||
0b (set! out (pair? in)) ; value => bool
|
||||
0c (set! out (vector? in)) ; value => bool
|
||||
0d (set! out (byte-string? in)) ; value => bool
|
||||
0e (set! out (struct? in)) ; value => bool
|
||||
0f (set! out (float? in)) ; value => bool
|
||||
10 (set! out (builtin? in)) ; value => bool
|
||||
|
||||
18 (set! out (make-box in)) ; value => box
|
||||
19 (set! out (make-struct in)) ; metastruct => struct
|
||||
1a (set! out (make-float in)) ; fixnum => float
|
||||
1b (set! out (lambda in)) ; template-or-lambda => lambda
|
||||
|
||||
20 (set! out (not in)) ; if in == #f then #t else #f
|
||||
21 (set! out (bit-not in)) ; one's complement / bitwise negation
|
||||
22 (set! out (fix- in)) ; two's complement / arithmetic negation
|
||||
23 (set! out (float- in)) ; floating-point negation
|
||||
|
||||
; ISO C floating-point
|
||||
20 (set! out (acos in))
|
||||
21 (set! out (asin in))
|
||||
22 (set! out (atan in))
|
||||
23 (set! out (cos in))
|
||||
24 (set! out (sin in))
|
||||
25 (set! out (tan in))
|
||||
26 (set! out (cosh in))
|
||||
27 (set! out (sinh in))
|
||||
28 (set! out (tanh in))
|
||||
29 (set! out (exp in))
|
||||
2a (set! out (frexp in)) ; float => (float . fixnum)
|
||||
2b (set! out (log in)) ; base e
|
||||
2c (set! out (log10 in))
|
||||
2d (set! out (modf in)) ; float => (float . float)
|
||||
2e (set! out (sqrt in))
|
||||
2f (set! out (ceil in))
|
||||
30 (set! out (fabs in))
|
||||
31 (set! out (floor in))
|
||||
30 (set! out (acos in))
|
||||
31 (set! out (asin in))
|
||||
32 (set! out (atan in))
|
||||
33 (set! out (cos in))
|
||||
34 (set! out (sin in))
|
||||
35 (set! out (tan in))
|
||||
36 (set! out (cosh in))
|
||||
37 (set! out (sinh in))
|
||||
38 (set! out (tanh in))
|
||||
39 (set! out (exp in))
|
||||
3a (set! out (frexp in)) ; float => (float . fixnum)
|
||||
3b (set! out (log in)) ; base e
|
||||
3c (set! out (log10 in))
|
||||
3d (set! out (modf in)) ; float => (float . float)
|
||||
3e (set! out (sqrt in))
|
||||
3f (set! out (ceil in))
|
||||
40 (set! out (fabs in))
|
||||
41 (set! out (floor in))
|
||||
|
||||
; SVID & X/Open
|
||||
40 (set! out (erf in))
|
||||
41 (set! out (erfc in))
|
||||
50 (set! out (erf in))
|
||||
51 (set! out (erfc in))
|
||||
; (set! out (gamma in)) ; obsolete
|
||||
42 (set! out (j0 in))
|
||||
43 (set! out (j1 in))
|
||||
44 (set! out (lgamma in)) ; float => (float . fixnum), actually lgamma_r
|
||||
45 (set! out (y0 in))
|
||||
46 (set! out (y1 in))
|
||||
52 (set! out (j0 in))
|
||||
53 (set! out (j1 in))
|
||||
54 (set! out (lgamma in)) ; float => (float . fixnum), actually lgamma_r
|
||||
55 (set! out (y0 in))
|
||||
56 (set! out (y1 in))
|
||||
|
||||
; SVID & XPG 4.2/5
|
||||
47 (set! out (asinh in))
|
||||
48 (set! out (acosh in))
|
||||
49 (set! out (atanh in))
|
||||
4a (set! out (cbrt in))
|
||||
4b (set! out (logb in))
|
||||
57 (set! out (asinh in))
|
||||
58 (set! out (acosh in))
|
||||
59 (set! out (atanh in))
|
||||
5a (set! out (cbrt in))
|
||||
5b (set! out (logb in))
|
||||
|
||||
; XPG 4.2/5
|
||||
4c (set! out (expm1 in))
|
||||
4d (set! out (ilogb in))
|
||||
4e (set! out (log1p in))
|
||||
5c (set! out (expm1 in))
|
||||
5d (set! out (ilogb in))
|
||||
5e (set! out (log1p in))
|
||||
; (set! out (rint in)) ; implies changing rounding mode; use floor or ceil
|
||||
binary-expr: up to 63 (01..3f), 1 out, 2 in
|
||||
00 unary-expr
|
||||
01 (set! out (cons in1 in2)) ; car cdr
|
||||
02 (set! out (make-vector in1 in2)) ; nelem iv, nelem >= 0
|
||||
03 (set! out (make-byte-string in1 in2)) ; nbytes iv, nbytes >= 0
|
||||
04 (set! out (vector-ref in1 in2)) ; vector n, 0 <= n < nelem
|
||||
05 (set! out (byte-string-ref in1 in2)) ; string n, 0 <= n < nbytes
|
||||
06 (set! out (struct-ref in1 in2)) ; struct n, 0 <= n < nslots
|
||||
07 (set! out (eq? in1 in2)) ; any values; superset of (fix= in2 in1)
|
||||
|
||||
01 (set! out (eq? in1 in2)) ; any values; superset of fix=
|
||||
02 (set! out (cons in1 in2)) ; car cdr
|
||||
03 (set! out (make-vector in1 in2)) ; nelem iv, nelem >= 0
|
||||
04 (set! out (make-byte-string in1 in2)) ; nbytes iv, nbytes >= 0
|
||||
05 (set! out (vector-ref in1 in2)) ; vector n, 0 <= n < nelem
|
||||
06 (set! out (byte-string-ref in1 in2)) ; string n, 0 <= n < nbytes
|
||||
07 (set! out (struct-ref in1 in2)) ; struct n, 0 <= n < nslots
|
||||
|
||||
08 (set! out (fix+ in1 in2))
|
||||
09 (set! out (fix- in1 in2))
|
||||
0a (set! out (fix* in1 in2))
|
||||
|
|
@ -86,35 +93,42 @@ binary-expr: up to 63 (01..3f), 1 out, 2 in
|
|||
0c (set! out (fix% in1 in2))
|
||||
0d (set! out (fix< in1 in2)) ; == (fix> in2 in1)
|
||||
0e (set! out (fix>= in1 in2)) ; == (fix<= in2 in1)
|
||||
0f (set! out (bit-and in1 in2))
|
||||
10 (set! out (bit-or in1 in2))
|
||||
11 (set! out (bit-xor in1 in2))
|
||||
12 (set! out (fix<< in1 in2)) ; arithmetic left-shift (2*x) w/ overflow into sign
|
||||
13 (set! out (fix>> in1 in2)) ; arithmetic right-shift (x/2)
|
||||
14 (set! out (fix>>> in1 in2)) ; logical right-shift; sign becomes zero (+)
|
||||
15 (set! out (float+ in1 in2))
|
||||
16 (set! out (float- in1 in2))
|
||||
17 (set! out (float* in1 in2))
|
||||
18 (set! out (float/ in1 in2))
|
||||
19 (set! out (float< in1 in2)) ; == (float> in2 in1)
|
||||
1a (set! out (float>= in1 in2)) ; == (float<= in2 in1)
|
||||
1b (set! out (atan2 in1 in2)) ; float float
|
||||
1c (set! out (pow in1 in2)) ; float float
|
||||
1d (set! out (ldexp in1 in2)) ; float fixnum
|
||||
1e (set! out (fmod in1 in2)) ; float float
|
||||
1f (set! out (hypot in1 in2)) ; float float
|
||||
20 (set! out (jn in1 in2)) ; fixnum float
|
||||
21 (set! out (yn in1 in2)) ; fixnum float
|
||||
22 (set! out (nextafter in1 in2)) ; float float
|
||||
23 (set! out (remainder in1 in2)) ; float float
|
||||
24 (set! out (scalb in1 in2)) ; float float
|
||||
|
||||
10 (set! out (bit-and in1 in2))
|
||||
11 (set! out (bit-or in1 in2))
|
||||
12 (set! out (bit-xor in1 in2))
|
||||
|
||||
14 (set! out (fix<< in1 in2)) ; arithmetic left-shift (2*x) w/ overflow into sign
|
||||
15 (set! out (fix>> in1 in2)) ; arithmetic right-shift (x/2)
|
||||
16 (set! out (fix>>> in1 in2)) ; logical right-shift; sign becomes zero (+)
|
||||
|
||||
18 (set! out (float+ in1 in2))
|
||||
19 (set! out (float- in1 in2))
|
||||
1a (set! out (float* in1 in2))
|
||||
1b (set! out (float/ in1 in2))
|
||||
1c (set! out (float= in1 in2))
|
||||
1d (set! out (float< in1 in2)) ; == (float> in2 in1)
|
||||
1e (set! out (float>= in1 in2)) ; == (float<= in2 in1)
|
||||
|
||||
20 (set! out (atan2 in1 in2)) ; float float
|
||||
21 (set! out (pow in1 in2)) ; float float
|
||||
22 (set! out (ldexp in1 in2)) ; float fixnum
|
||||
23 (set! out (fmod in1 in2)) ; float float
|
||||
24 (set! out (hypot in1 in2)) ; float float
|
||||
25 (set! out (jn in1 in2)) ; fixnum float
|
||||
26 (set! out (yn in1 in2)) ; fixnum float
|
||||
27 (set! out (nextafter in1 in2)) ; float float
|
||||
28 (set! out (remainder in1 in2)) ; float float
|
||||
29 (set! out (scalb in1 in2)) ; float float
|
||||
conditional: 1AAAAAAA; 1 out, 2 in + fA
|
||||
AA (set! out (if fA in1 in2)) ; in2 if fA == #f, in1 otherwise
|
||||
statement: up to 64 (40..7f), 3 in
|
||||
; binary statements
|
||||
40 (set-box! in in) ; box value
|
||||
41 (set-car! in in) ; pair value
|
||||
42 (set-cdr! in in) ; pair value
|
||||
|
||||
; ternary statements
|
||||
60 (vector-set! in in in) ; vector n value, 0 <= n < nelem
|
||||
61 (byte-string-set! in in in) ; string n value, 0 <= n < nbytes
|
||||
62 (struct-set! in in in) ; struct n value, 0 <= n < nslots
|
||||
|
|
@ -135,7 +149,7 @@ out:
|
|||
lambda:[
|
||||
global: vector of immutable values (g1..gN); shared between instances (lambdas)
|
||||
instance: vector of immutable values (i0..iN); shared between frames (calls)
|
||||
frame: number of frame variables; initially NIL
|
||||
frame: number of frame variables; initially #<undefined>
|
||||
code: byte-string containing sequence of 4-byte instruction words
|
||||
tail-call: in-ref of lambda to tail-call
|
||||
arguments: in-ref of argument list to pass to tail-call
|
||||
|
|
@ -158,7 +172,7 @@ Protocol:
|
|||
|
||||
Normal function calls (return to caller, or caller's continuation if tail-call):
|
||||
Call: Tail-call function with valid 'k' and original 'ctx'.
|
||||
Return: Tail-call 'k' with 'nil' continuation and context (ignored).
|
||||
Return: Tail-call 'k' with #f continuation and context (ignored).
|
||||
|
||||
Coroutines (cooperating, interleaved tail-call chains in CPS):
|
||||
Call: Tail-call function with valid 'k' and original 'ctx'.
|
||||
|
|
|
|||
392
interp.c
392
interp.c
|
|
@ -1,10 +1,19 @@
|
|||
#define _XOPEN_SOURCE 500
|
||||
#define _REENTRANT 1
|
||||
#define _SVID_SOURCE 1
|
||||
|
||||
/* Required for lgamma_r on Solaris */
|
||||
#define __EXTENSIONS__ 1
|
||||
|
||||
#include <inttypes.h>
|
||||
#include <math.h>
|
||||
#include <stdbool.h>
|
||||
#include <stdlib.h>
|
||||
#include <string.h>
|
||||
|
||||
#include "builtin.h"
|
||||
#include "gc.h"
|
||||
#include "builtin.h"
|
||||
#include "interp.h"
|
||||
|
||||
/* Ex: _SLOT_VALUE(STRUCTURE, v, NAME) */
|
||||
#define _SLOT_VALUE(t,v,s) (_get_struct(v)->slots[t ## _SLOT_ ## s])
|
||||
|
|
@ -15,18 +24,6 @@
|
|||
#define ST2 (state->in2.value)
|
||||
#define ST3 (state->in3.value)
|
||||
|
||||
typedef struct interp_state
|
||||
{
|
||||
gc_root_t lambda;
|
||||
gc_root_t frame;
|
||||
gc_root_t argv;
|
||||
gc_root_t k;
|
||||
gc_root_t ctx;
|
||||
gc_root_t in1;
|
||||
gc_root_t in2;
|
||||
gc_root_t in3;
|
||||
} interp_state_t;
|
||||
|
||||
/* Quick references to main builtins */
|
||||
static gc_root_t structure_type_root;
|
||||
static gc_root_t template_type_root;
|
||||
|
|
@ -79,21 +76,36 @@ value_t run_interpreter(value_t lambda, value_t argv)
|
|||
|
||||
register_state(&state, lambda, argv);
|
||||
|
||||
/* Keep going until something attempt to tail-call NIL, the original 'k', indicating completion. */
|
||||
while (!is_nil(state.lambda.value))
|
||||
/* Keep going until something attempts to tail-call FALSE_VALUE, the original 'k', indicating completion. */
|
||||
while (state.lambda.value != FALSE_VALUE)
|
||||
{
|
||||
/* 'lambda' may be a callable structure; if so, follow the 'callable' proxies and update argv. */
|
||||
translate_callable(&state);
|
||||
|
||||
/*
|
||||
* Now 'lambda' really is a lambda structure instance.
|
||||
* Now 'lambda' really is a lambda structure instance (or builtin).
|
||||
*/
|
||||
|
||||
/* Allocate frame variables */
|
||||
state.frame.value = make_vector(get_fixnum(_LAMBDA_SLOT(state.lambda.value, FRAME_VARS)), NIL);
|
||||
if (is_builtin_fn(state.lambda.value))
|
||||
{
|
||||
/* Builtin functions replace the byte-code and tail-call
|
||||
* steps; they also do not require frame variables. */
|
||||
_get_builtin_fn(state.lambda.value)(&state);
|
||||
}
|
||||
else
|
||||
{
|
||||
/* Allocate frame variables, initially undefined */
|
||||
state.frame.value = make_vector(get_fixnum(_LAMBDA_SLOT(state.lambda.value, FRAME_VARS)), UNDEFINED);
|
||||
|
||||
run_byte_code(&state);
|
||||
perform_tail_call(&state);
|
||||
}
|
||||
|
||||
/* Clear temporaries so they can be GC'd. */
|
||||
state.frame.value = UNDEFINED;
|
||||
state.in1.value = UNDEFINED;
|
||||
state.in2.value = UNDEFINED;
|
||||
state.in3.value = UNDEFINED;
|
||||
|
||||
if (run_finalizers)
|
||||
{
|
||||
|
|
@ -118,11 +130,11 @@ value_t run_interpreter(value_t lambda, value_t argv)
|
|||
|
||||
unregister_state(&state);
|
||||
|
||||
/* The arguments passed to NIL continuation are the final return value. */
|
||||
/* The arguments passed to continuation are the final return value. */
|
||||
return state.argv.value;
|
||||
}
|
||||
|
||||
/* TODO: Permit derivatives of 'structure'. */
|
||||
/* TODO: Permit derivatives of 'structure', and improve detection of cycles. */
|
||||
static bool struct_is_a(value_t s, value_t type)
|
||||
{
|
||||
/* Detect unbounded loops w/ cyclic 'parent' links. */
|
||||
|
|
@ -133,14 +145,11 @@ static bool struct_is_a(value_t s, value_t type)
|
|||
|
||||
for (value_t t = _get_struct(s)->type; t != type; t = _SLOT_VALUE(STRUCTURE, t, SUPER), --ttl)
|
||||
{
|
||||
if (is_nil(t))
|
||||
if (t == FALSE_VALUE)
|
||||
return false;
|
||||
|
||||
if (get_struct(t)->type != structure_type_root.value)
|
||||
abort();
|
||||
|
||||
if (ttl <= 0)
|
||||
abort();
|
||||
release_assert(get_struct(t)->type == structure_type_root.value);
|
||||
release_assert(ttl > 0);
|
||||
}
|
||||
|
||||
return true;
|
||||
|
|
@ -149,50 +158,35 @@ static bool struct_is_a(value_t s, value_t type)
|
|||
static value_t vector_ref(value_t v, fixnum_t idx)
|
||||
{
|
||||
vector_t *vec = get_vector(v);
|
||||
|
||||
if (idx < 0 || idx >= vec->size)
|
||||
abort();
|
||||
|
||||
release_assert((idx >= 0) && (idx < vec->size));
|
||||
return vec->elements[idx];
|
||||
}
|
||||
|
||||
static char byte_string_ref(value_t v, fixnum_t idx)
|
||||
{
|
||||
byte_string_t *str = get_byte_string(v);
|
||||
|
||||
if (idx < 0 || idx >= str->size)
|
||||
abort();
|
||||
|
||||
release_assert((idx >= 0) && (idx < str->size));
|
||||
return str->bytes[idx];
|
||||
}
|
||||
|
||||
static value_t struct_ref(value_t v, fixnum_t idx)
|
||||
{
|
||||
struct_t *s = get_struct(v);
|
||||
|
||||
if (idx < 0 || idx >= s->nslots)
|
||||
abort();
|
||||
|
||||
release_assert((idx >= 0) && (idx < s->nslots));
|
||||
return s->slots[idx];
|
||||
}
|
||||
|
||||
static void vector_set(value_t v, fixnum_t idx, value_t newval)
|
||||
{
|
||||
vector_t *vec = get_vector(v);
|
||||
|
||||
if (idx < 0 || idx >= vec->size)
|
||||
abort();
|
||||
|
||||
release_assert((idx >= 0) && (idx < vec->size));
|
||||
vec->elements[idx] = newval;
|
||||
}
|
||||
|
||||
static void byte_string_set(value_t v, fixnum_t idx, char newval)
|
||||
{
|
||||
byte_string_t *str = get_byte_string(v);
|
||||
|
||||
if (idx < 0 || idx >= str->size)
|
||||
abort();
|
||||
|
||||
release_assert((idx >= 0) && (idx < str->size));
|
||||
str->bytes[idx] = newval;
|
||||
}
|
||||
|
||||
|
|
@ -200,8 +194,9 @@ static void struct_set(value_t v, fixnum_t idx, value_t newval)
|
|||
{
|
||||
struct_t *s = get_struct(v);
|
||||
|
||||
if (idx < 0 || idx >= s->nslots)
|
||||
abort();
|
||||
release_assert(struct_is_a(s->type, structure_type_root.value));
|
||||
release_assert(_get_boolean(_SLOT_VALUE(STRUCTURE, s->type, MUTABLE)));
|
||||
release_assert((idx >= 0) && (idx < s->nslots));
|
||||
|
||||
s->slots[idx] = newval;
|
||||
}
|
||||
|
|
@ -209,7 +204,6 @@ static void struct_set(value_t v, fixnum_t idx, value_t newval)
|
|||
static value_t make_lambda(interp_state_t *state, value_t templ)
|
||||
{
|
||||
gc_root_t templ_root, lambda_root;
|
||||
value_t lval;
|
||||
struct_t *ls;
|
||||
struct_t *ts;
|
||||
vector_t *l_inst;
|
||||
|
|
@ -219,16 +213,14 @@ static value_t make_lambda(interp_state_t *state, value_t templ)
|
|||
register_gc_root(&lambda_root, make_struct(lambda_type_root.value, LAMBDA_SLOTS));
|
||||
|
||||
/* Need to do this first, since it can call the garbage collector. */
|
||||
_get_struct(lambda_root.value)->slots[LAMBDA_SLOT_INSTANCE_VARS] =
|
||||
_LAMBDA_SLOT(lambda_root.value, INSTANCE_VARS) =
|
||||
make_vector(get_vector(get_struct(templ_root.value)
|
||||
->slots[TEMPLATE_SLOT_INSTANCE_VARS])
|
||||
->size,
|
||||
NIL);
|
||||
UNDEFINED);
|
||||
|
||||
ls = _get_struct(lambda_root.value);
|
||||
ts = _get_struct(templ_root.value);
|
||||
l_inst = _get_vector(ls->slots[LAMBDA_SLOT_INSTANCE_VARS]);
|
||||
t_inst = get_byte_string(ts->slots[TEMPLATE_SLOT_INSTANCE_VARS]);
|
||||
|
||||
/* All but the instance variables are just shallow-copied. */
|
||||
ls->slots[LAMBDA_SLOT_GLOBAL_VARS] = ts->slots[TEMPLATE_SLOT_GLOBAL_VARS];
|
||||
|
|
@ -239,6 +231,9 @@ static value_t make_lambda(interp_state_t *state, value_t templ)
|
|||
ls->slots[LAMBDA_SLOT_CONTINUATION] = ts->slots[TEMPLATE_SLOT_CONTINUATION];
|
||||
ls->slots[LAMBDA_SLOT_CONTEXT] = ts->slots[TEMPLATE_SLOT_CONTEXT];
|
||||
|
||||
l_inst = _get_vector(ls->slots[LAMBDA_SLOT_INSTANCE_VARS]);
|
||||
t_inst = get_byte_string(ts->slots[TEMPLATE_SLOT_INSTANCE_VARS]);
|
||||
|
||||
for (size_t i = 0; i < t_inst->size; ++i)
|
||||
{
|
||||
l_inst->elements[i] = get_input(state, t_inst->bytes[i]);
|
||||
|
|
@ -252,10 +247,12 @@ static value_t make_lambda(interp_state_t *state, value_t templ)
|
|||
|
||||
static void translate_callable(interp_state_t *state)
|
||||
{
|
||||
while (!struct_is_a(state->lambda.value, lambda_type_root.value))
|
||||
while (!is_builtin_fn(state->lambda.value) &&
|
||||
!struct_is_a(state->lambda.value, lambda_type_root.value))
|
||||
{
|
||||
if (!struct_is_a(get_struct(state->lambda.value)->type, structure_type_root.value))
|
||||
abort();
|
||||
/* If it's not a lambda, built-in function, or typed structure, then
|
||||
* it's not callable and I have no idea what to do with it. */
|
||||
release_assert(struct_is_a(get_struct(state->lambda.value)->type, structure_type_root.value));
|
||||
|
||||
/* Prepend structure instance to argument list, per proxy protocol. */
|
||||
state->argv.value = cons(state->lambda.value, state->argv.value);
|
||||
|
|
@ -287,8 +284,9 @@ static void run_byte_code(interp_state_t *state)
|
|||
break;
|
||||
case 128 ... 255: /* conditional */
|
||||
set_output(state, bytes[0],
|
||||
get_input(state,
|
||||
is_true(get_input(state, bytes[1])) ? bytes[2] : bytes[3]));
|
||||
get_input(state, _get_boolean(get_input(state, bytes[1]))
|
||||
? bytes[2]
|
||||
: bytes[3]));
|
||||
break;
|
||||
}
|
||||
}
|
||||
|
|
@ -313,60 +311,53 @@ static void perform_tail_call(interp_state_t *state)
|
|||
|
||||
static value_t eval_expression(interp_state_t *state, uint8_t code, uint8_t in1, uint8_t in2)
|
||||
{
|
||||
if (code == 0)
|
||||
if (code != 0x00)
|
||||
{
|
||||
return eval_unary_expression(state, in1, in2);
|
||||
}
|
||||
|
||||
ST1 = get_input(state, in1);
|
||||
ST2 = get_input(state, in2);
|
||||
}
|
||||
|
||||
switch (code)
|
||||
{
|
||||
case 0x01:
|
||||
return cons(ST1, ST2);
|
||||
case 0x02:
|
||||
return make_vector(get_fixnum(ST1), ST2);
|
||||
case 0x03:
|
||||
return make_byte_string(get_fixnum(ST1), (char)get_fixnum(ST2));
|
||||
case 0x04:
|
||||
return vector_ref(ST1, get_fixnum(ST2));
|
||||
case 0x05:
|
||||
return make_fixnum(byte_string_ref(ST1, get_fixnum(ST2)));
|
||||
case 0x06:
|
||||
return struct_ref(ST1, get_fixnum(ST2));
|
||||
case 0x07:
|
||||
return ST1 == ST2;
|
||||
case 0x08:
|
||||
return make_fixnum(get_fixnum(ST1) + get_fixnum(ST2));
|
||||
case 0x09:
|
||||
return make_fixnum(get_fixnum(ST1) - get_fixnum(ST2));
|
||||
case 0x0a:
|
||||
return make_fixnum(get_fixnum(ST1) * get_fixnum(ST2));
|
||||
case 0x0b:
|
||||
return make_fixnum(get_fixnum(ST1) / get_fixnum(ST2));
|
||||
case 0x0c:
|
||||
return make_fixnum(get_fixnum(ST1) % get_fixnum(ST2));
|
||||
case 0x0d:
|
||||
return make_fixnum(get_fixnum(ST1) < get_fixnum(ST2));
|
||||
case 0x0e:
|
||||
return make_fixnum(get_fixnum(ST1) >= get_fixnum(ST2));
|
||||
case 0x0f:
|
||||
return make_fixnum(get_fixnum(ST1) & get_fixnum(ST2));
|
||||
case 0x10:
|
||||
return make_fixnum(get_fixnum(ST1) | get_fixnum(ST2));
|
||||
case 0x11:
|
||||
return make_fixnum(get_fixnum(ST1) ^ get_fixnum(ST2));
|
||||
case 0x12:
|
||||
return make_fixnum(get_fixnum(ST1) << get_fixnum(ST2));
|
||||
case 0x13:
|
||||
return make_fixnum(get_fixnum(ST1) >> get_fixnum(ST2));
|
||||
case 0x14:
|
||||
return make_fixnum((unsigned long)get_fixnum(ST1) >> get_fixnum(ST2));
|
||||
case 0x15 ... 0x24:
|
||||
return UNDEFINED;
|
||||
default:
|
||||
abort();
|
||||
case 0x00: return eval_unary_expression(state, in1, in2);
|
||||
case 0x01: return boolean_value(ST1 == ST2);
|
||||
case 0x02: return cons(ST1, ST2);
|
||||
case 0x03: return make_vector(get_fixnum(ST1), ST2);
|
||||
case 0x04: return make_byte_string(get_fixnum(ST1), (char)get_fixnum(ST2));
|
||||
case 0x05: return vector_ref(ST1, get_fixnum(ST2));
|
||||
case 0x06: return fixnum_value(byte_string_ref(ST1, get_fixnum(ST2)));
|
||||
case 0x07: return struct_ref(ST1, get_fixnum(ST2));
|
||||
case 0x08: return fixnum_value(get_fixnum(ST1) + get_fixnum(ST2));
|
||||
case 0x09: return fixnum_value(get_fixnum(ST1) - get_fixnum(ST2));
|
||||
case 0x0a: return fixnum_value(get_fixnum(ST1) * get_fixnum(ST2));
|
||||
case 0x0b: return fixnum_value(get_fixnum(ST1) / get_fixnum(ST2));
|
||||
case 0x0c: return fixnum_value(get_fixnum(ST1) % get_fixnum(ST2));
|
||||
case 0x0d: return boolean_value(get_fixnum(ST1) < get_fixnum(ST2));
|
||||
case 0x0e: return boolean_value(get_fixnum(ST1) >= get_fixnum(ST2));
|
||||
case 0x10: return fixnum_value(get_fixnum(ST1) & get_fixnum(ST2));
|
||||
case 0x11: return fixnum_value(get_fixnum(ST1) | get_fixnum(ST2));
|
||||
case 0x12: return fixnum_value(get_fixnum(ST1) ^ get_fixnum(ST2));
|
||||
case 0x14: return fixnum_value(get_fixnum(ST1) << get_fixnum(ST2));
|
||||
case 0x15: return fixnum_value(get_fixnum(ST1) >> get_fixnum(ST2));
|
||||
case 0x16: return fixnum_value((unsigned long)get_fixnum(ST1) >> get_fixnum(ST2));
|
||||
case 0x18: return make_float(get_float(ST1) + get_float(ST2));
|
||||
case 0x19: return make_float(get_float(ST1) - get_float(ST2));
|
||||
case 0x1a: return make_float(get_float(ST1) * get_float(ST2));
|
||||
case 0x1b: return make_float(get_float(ST1) / get_float(ST2));
|
||||
case 0x1c: return boolean_value(get_float(ST1) == get_float(ST2));
|
||||
case 0x1d: return boolean_value(get_float(ST1) < get_float(ST2));
|
||||
case 0x1e: return boolean_value(get_float(ST1) >= get_float(ST2));
|
||||
case 0x20: return make_float(atan2(get_float(ST1), get_float(ST2)));
|
||||
case 0x21: return make_float(pow(get_float(ST1), get_float(ST2)));
|
||||
case 0x22: return make_float(ldexp(get_float(ST1), get_fixnum(ST2)));
|
||||
case 0x23: return make_float(fmod(get_float(ST1), get_float(ST2)));
|
||||
case 0x24: return make_float(hypot(get_float(ST1), get_float(ST2)));
|
||||
case 0x25: return make_float(jn(get_fixnum(ST1), get_float(ST2)));
|
||||
case 0x26: return make_float(yn(get_fixnum(ST1), get_float(ST2)));
|
||||
case 0x27: return make_float(nextafter(get_float(ST1), get_float(ST2)));
|
||||
case 0x28: return make_float(remainder(get_float(ST1), get_float(ST2)));
|
||||
case 0x29: return make_float(scalb(get_float(ST1), get_float(ST2)));
|
||||
default: release_assert(NOTREACHED("Invalid byte-code!"));
|
||||
}
|
||||
|
||||
return UNDEFINED;
|
||||
|
|
@ -374,66 +365,87 @@ static value_t eval_expression(interp_state_t *state, uint8_t code, uint8_t in1,
|
|||
|
||||
static value_t eval_unary_expression(interp_state_t *state, uint8_t subcode, uint8_t in)
|
||||
{
|
||||
if (subcode == 0)
|
||||
{
|
||||
abort();
|
||||
}
|
||||
|
||||
release_assert(subcode != 0);
|
||||
ST1 = get_input(state, in);
|
||||
|
||||
switch (subcode)
|
||||
{
|
||||
case 0x01:
|
||||
return ST1;
|
||||
case 0x02:
|
||||
return get_pair(ST1)->car;
|
||||
case 0x03:
|
||||
return get_pair(ST1)->cdr;
|
||||
case 0x04:
|
||||
return get_box(ST1)->value;
|
||||
case 0x05:
|
||||
return make_boolean(is_false(ST1));
|
||||
case 0x06:
|
||||
return make_boolean(is_nil(ST1));
|
||||
case 0x07:
|
||||
return make_boolean(is_pair(ST1));
|
||||
case 0x08:
|
||||
return make_boolean(is_box(ST1));
|
||||
case 0x09:
|
||||
return make_boolean(is_vector(ST1));
|
||||
case 0x0a:
|
||||
return make_boolean(is_byte_string(ST1));
|
||||
case 0x0b:
|
||||
return make_boolean(is_struct(ST1));
|
||||
case 0x0c:
|
||||
return make_boolean(is_fixnum(ST1));
|
||||
case 0x0d:
|
||||
//return make_boolean(is_float(ST1));
|
||||
return FALSE_VALUE;
|
||||
case 0x0e:
|
||||
return make_box(ST1);
|
||||
case 0x0f:
|
||||
if (!struct_is_a(ST1, structure_type_root.value))
|
||||
abort();
|
||||
return make_struct(ST1, get_vector(_get_struct(ST1)->slots[STRUCTURE_SLOT_SLOTS])->size);
|
||||
case 0x10:
|
||||
//return make_float((float_t)get_fixnum(ST1));
|
||||
return UNDEFINED;
|
||||
case 0x11:
|
||||
return make_lambda(state, ST1);
|
||||
case 0x12:
|
||||
return make_fixnum(~get_fixnum(ST1));
|
||||
case 0x13:
|
||||
return make_fixnum(-get_fixnum(ST1));
|
||||
case 0x14:
|
||||
//return make_float(-from_float(ST1));
|
||||
return UNDEFINED;
|
||||
case 0x20 ... 0x31:
|
||||
case 0x40 ... 0x4e:
|
||||
return UNDEFINED;
|
||||
default:
|
||||
abort();
|
||||
case 0x01: return ST1;
|
||||
case 0x02: return get_box(ST1)->value;
|
||||
case 0x03: return get_pair(ST1)->car;
|
||||
case 0x04: return get_pair(ST1)->cdr;
|
||||
case 0x08: return boolean_value(is_boolean(ST1));
|
||||
case 0x09: return boolean_value(is_fixnum(ST1));
|
||||
case 0x0a: return boolean_value(is_box(ST1));
|
||||
case 0x0b: return boolean_value(is_pair(ST1));
|
||||
case 0x0c: return boolean_value(is_vector(ST1));
|
||||
case 0x0d: return boolean_value(is_byte_string(ST1));
|
||||
case 0x0e: return boolean_value(is_struct(ST1));
|
||||
case 0x0f: return boolean_value(is_float(ST1));
|
||||
case 0x10: return boolean_value(is_builtin_fn(ST1));
|
||||
case 0x18: return make_box(ST1);
|
||||
case 0x19: {
|
||||
vector_t *vec;
|
||||
release_assert(struct_is_a(ST1, structure_type_root.value));
|
||||
vec = get_vector(_SLOT_VALUE(STRUCTURE, ST1, SLOTS));
|
||||
return make_struct(ST1, vec->size);
|
||||
}
|
||||
case 0x1a: return make_float((native_float_t)get_fixnum(ST1));
|
||||
case 0x1b: return make_lambda(state, ST1);
|
||||
case 0x20: return boolean_value(!_get_boolean(ST1));
|
||||
case 0x21: return fixnum_value(~get_fixnum(ST1));
|
||||
case 0x22: return fixnum_value(-get_fixnum(ST1));
|
||||
case 0x23: return make_float(-get_float(ST1));
|
||||
case 0x30: return make_float(acos(get_float(ST1)));
|
||||
case 0x31: return make_float(asin(get_float(ST1)));
|
||||
case 0x32: return make_float(atan(get_float(ST1)));
|
||||
case 0x33: return make_float(cos(get_float(ST1)));
|
||||
case 0x34: return make_float(sin(get_float(ST1)));
|
||||
case 0x35: return make_float(tan(get_float(ST1)));
|
||||
case 0x36: return make_float(cosh(get_float(ST1)));
|
||||
case 0x37: return make_float(sinh(get_float(ST1)));
|
||||
case 0x38: return make_float(tanh(get_float(ST1)));
|
||||
case 0x39: return make_float(exp(get_float(ST1)));
|
||||
case 0x3a: {
|
||||
int exp;
|
||||
ST2 = make_float(frexp(get_float(ST1), &exp));
|
||||
return cons(ST2, fixnum_value(exp));
|
||||
}
|
||||
case 0x3b: return make_float(log(get_float(ST1)));
|
||||
case 0x3c: return make_float(log10(get_float(ST1)));
|
||||
case 0x3d: {
|
||||
double integral_part;
|
||||
ST2 = make_float(modf(get_float(ST1), &integral_part));
|
||||
ST3 = make_float(integral_part);
|
||||
return cons(ST2, ST3);
|
||||
}
|
||||
case 0x3e: return make_float(sqrt(get_float(ST1)));
|
||||
case 0x3f: return make_float(ceil(get_float(ST1)));
|
||||
case 0x40: return make_float(fabs(get_float(ST1)));
|
||||
case 0x41: return make_float(floor(get_float(ST1)));
|
||||
case 0x50: return make_float(erf(get_float(ST1)));
|
||||
case 0x51: return make_float(erfc(get_float(ST1)));
|
||||
case 0x52: return make_float(j0(get_float(ST1)));
|
||||
case 0x53: return make_float(j1(get_float(ST1)));
|
||||
case 0x54: {
|
||||
int signgamp;
|
||||
ST2 = make_float(lgamma_r(get_float(ST1), &signgamp));
|
||||
return cons(ST2, fixnum_value(signgamp));
|
||||
}
|
||||
case 0x55: return make_float(y0(get_float(ST1)));
|
||||
case 0x56: return make_float(y1(get_float(ST1)));
|
||||
case 0x57: return make_float(asinh(get_float(ST1)));
|
||||
case 0x58: return make_float(acosh(get_float(ST1)));
|
||||
case 0x59: return make_float(atanh(get_float(ST1)));
|
||||
case 0x5a: return make_float(cbrt(get_float(ST1)));
|
||||
case 0x5b: return make_float(logb(get_float(ST1)));
|
||||
case 0x5c: return make_float(expm1(get_float(ST1)));
|
||||
case 0x5d: return make_float(ilogb(get_float(ST1)));
|
||||
case 0x5e: return make_float(log1p(get_float(ST1)));
|
||||
default: release_assert(NOTREACHED("Invalid unary sub-bytecode."));
|
||||
}
|
||||
|
||||
return UNDEFINED;
|
||||
}
|
||||
|
||||
static void run_statement(interp_state_t *state, uint8_t code, uint8_t in1, uint8_t in2, uint32_t in3)
|
||||
|
|
@ -448,28 +460,19 @@ static void run_statement(interp_state_t *state, uint8_t code, uint8_t in1, uint
|
|||
|
||||
switch (code)
|
||||
{
|
||||
case 0x40:
|
||||
get_box(ST1)->value = ST2;
|
||||
break;
|
||||
case 0x41:
|
||||
get_pair(ST1)->car = ST2;
|
||||
break;
|
||||
case 0x42:
|
||||
get_pair(ST1)->cdr = ST2;
|
||||
break;
|
||||
case 0x60:
|
||||
vector_set(ST1, get_fixnum(ST2), ST3);
|
||||
break;
|
||||
case 0x61:
|
||||
byte_string_set(ST1, get_fixnum(ST2), (char)get_fixnum(ST3));
|
||||
break;
|
||||
case 0x62:
|
||||
struct_set(ST1, get_fixnum(ST2), ST3);
|
||||
case 0x40: get_box(ST1)->value = ST2; break;
|
||||
case 0x41: get_pair(ST1)->car = ST2; break;
|
||||
case 0x42: get_pair(ST1)->cdr = ST2; break;
|
||||
case 0x60: vector_set(ST1, get_fixnum(ST2), ST3); break;
|
||||
case 0x61: byte_string_set(ST1, get_fixnum(ST2), (char)get_fixnum(ST3)); break;
|
||||
case 0x62: struct_set(ST1, get_fixnum(ST2), ST3); break;
|
||||
}
|
||||
}
|
||||
|
||||
static value_t get_input(const interp_state_t *state, fixnum_t var)
|
||||
{
|
||||
release_assert((var >= 0) && (var <= 255));
|
||||
|
||||
switch (var)
|
||||
{
|
||||
case 0:
|
||||
|
|
@ -479,9 +482,7 @@ static value_t get_input(const interp_state_t *state, fixnum_t var)
|
|||
vector_t *vec = get_vector(_LAMBDA_SLOT(state->lambda.value, GLOBAL_VARS));
|
||||
var -= 1;
|
||||
|
||||
if (var >= vec->size)
|
||||
abort();
|
||||
|
||||
release_assert(var < vec->size);
|
||||
return vec->elements[var];
|
||||
}
|
||||
case 64 ... 127:
|
||||
|
|
@ -489,9 +490,7 @@ static value_t get_input(const interp_state_t *state, fixnum_t var)
|
|||
vector_t *vec = get_vector(_LAMBDA_SLOT(state->lambda.value, INSTANCE_VARS));
|
||||
var -= 64;
|
||||
|
||||
if (var >= vec->size)
|
||||
abort();
|
||||
|
||||
release_assert(var < vec->size);
|
||||
return vec->elements[var];
|
||||
}
|
||||
case 128 ... 247:
|
||||
|
|
@ -500,9 +499,7 @@ static value_t get_input(const interp_state_t *state, fixnum_t var)
|
|||
vector_t *vec = _get_vector(state->frame.value);
|
||||
var -= 128;
|
||||
|
||||
if (var >= vec->size)
|
||||
abort();
|
||||
|
||||
release_assert(var < vec->size);
|
||||
return vec->elements[var];
|
||||
}
|
||||
/* 248 ... 252 are reserved */
|
||||
|
|
@ -513,7 +510,7 @@ static value_t get_input(const interp_state_t *state, fixnum_t var)
|
|||
case 255:
|
||||
return state->ctx.value;
|
||||
default:
|
||||
abort();
|
||||
return UNDEFINED;
|
||||
}
|
||||
}
|
||||
|
||||
|
|
@ -522,22 +519,23 @@ static void set_output(const interp_state_t *state, fixnum_t var, value_t val)
|
|||
vector_t *vec = _get_vector(state->frame.value);
|
||||
|
||||
/* Only frame variables can be output targets for bytecode instructions. */
|
||||
if (var < 128 || var >= (128 + vec->size))
|
||||
abort();
|
||||
release_assert((var >= 128) && (var <= 255));
|
||||
|
||||
vec->elements[var-128] = val;
|
||||
var -= 128;
|
||||
release_assert(var < vec->size);
|
||||
vec->elements[var] = val;
|
||||
}
|
||||
|
||||
static void register_state(interp_state_t *state, value_t lambda, value_t argv)
|
||||
{
|
||||
register_gc_root(&state->lambda, lambda);
|
||||
register_gc_root(&state->frame, NIL);
|
||||
register_gc_root(&state->frame, UNDEFINED);
|
||||
register_gc_root(&state->argv, argv);
|
||||
register_gc_root(&state->k, NIL);
|
||||
register_gc_root(&state->ctx, NIL);
|
||||
register_gc_root(&state->in1, NIL);
|
||||
register_gc_root(&state->in2, NIL);
|
||||
register_gc_root(&state->in3, NIL);
|
||||
register_gc_root(&state->k, FALSE_VALUE);
|
||||
register_gc_root(&state->ctx, FALSE_VALUE);
|
||||
register_gc_root(&state->in1, FALSE_VALUE);
|
||||
register_gc_root(&state->in2, FALSE_VALUE);
|
||||
register_gc_root(&state->in3, FALSE_VALUE);
|
||||
}
|
||||
|
||||
static void unregister_state(interp_state_t *state)
|
||||
|
|
|
|||
15
interp.h
15
interp.h
|
|
@ -1,7 +1,20 @@
|
|||
/* Need to ensure gc.h is included first, because it depends on interp.h. */
|
||||
#include "gc.h"
|
||||
|
||||
#ifndef INTERP_H_9c7eea5c5cd0f7a32b79a8ca0ab2969f
|
||||
#define INTERP_H_9c7eea5c5cd0f7a32b79a8ca0ab2969f
|
||||
|
||||
#include "gc.h"
|
||||
typedef struct interp_state
|
||||
{
|
||||
gc_root_t lambda;
|
||||
gc_root_t frame;
|
||||
gc_root_t argv;
|
||||
gc_root_t k;
|
||||
gc_root_t ctx;
|
||||
gc_root_t in1;
|
||||
gc_root_t in2;
|
||||
gc_root_t in3;
|
||||
} interp_state_t;
|
||||
|
||||
void interpreter_init(void);
|
||||
value_t run_interpreter(value_t lambda, value_t argv);
|
||||
|
|
|
|||
Loading…
Reference in New Issue