mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-01-05 00:40:48 -08:00
Code Issues Projects Releases Packages Wiki Activity

New bytecodes compiler and interpreter, which use 8-bits large bytecodes and

Browse source 
16-bits large arguments.
Macros are implemented as two-argument functions, leaving argument checking
to funcall() and apply() and thus saving space.
AND, WHEN and OR are plain macros. No optimizer is required in the bytecodes
compiler.
This commit is contained in:
jjgarcia 2003-08-05 10:01:57 +00:00
parent cc94282771
commit ee391629b6
21 changed files with 705 additions and 740 deletions
Download patch file Download diff file Expand all files Collapse all files

16
src/CHANGELOG
View file

@ -1450,6 +1450,22 @@ ECLS 0.9b
- EQL specializers were compared to the arguments using EQ instead
of EQL.
* System design:
- The bytecodes compiler now works with character arrays. Bytecodes
are thus 8 bits large, while their arguments are 16 bits large.
Lisp objects referenced in the code are kept in a separate array
to simplify garbage collection. This strategy limits the size of
bytecode objects to about 32000 bytes and about 32000 constants,
but reduces the use of memory by about 25%.
- Macros are implemented in C as functions with two arguments.
Argument checking is thus left to funcall() and apply(), saving
space.
- AND, OR and WHEN are now just macros, without any special
treatment in the bytecodes compiler.
* Visible changes:
- New special form C-INLINE, allows inserting C/C++ code in any

8
src/c/alloc.d
View file

@ -221,8 +221,8 @@ cl_alloc_object(cl_type t)
return CODE_CHAR('\0'); /* Immediate character */
default:
}
start_critical_section();
start_critical_section();
tm = tm_of(t);
ONCE_MORE:
if (interrupt_flag) {
@ -346,7 +346,9 @@ ONCE_MORE:
obj->bytecodes.name = Cnil;
obj->bytecodes.definition = Cnil;
obj->bytecodes.specials = Cnil;
obj->bytecodes.size = 0;
obj->bytecodes.code_size = 0;
obj->bytecodes.code = NULL;
obj->bytecodes.data_size = 0;
obj->bytecodes.data = NULL;
break;
case t_cfun:

5
src/c/cfun.d
View file

@ -65,9 +65,10 @@ cl_def_c_function(cl_object sym, cl_object (*self)(), int narg)
}
void
cl_def_c_macro_va(cl_object sym, cl_objectfn self)
cl_def_c_macro(cl_object sym, cl_object (*self)(cl_object, cl_object))
{
si_fset(3, sym, cl_make_cfun_va(self, sym, symbol_value(@'si::*cblock*')),
si_fset(3, sym,
cl_make_cfun(self, sym, symbol_value(@'si::*cblock*'), 2),
Ct);
}

3
src/c/cinit.d
View file

@ -33,12 +33,11 @@ static cl_object si_simple_toplevel ()
cl_load(1, arg);
}
while (1) {
cl_object bytecodes = Cnil;
printf("\n> ");
sentence = @read(3, Cnil, Cnil, OBJNULL);
if (sentence == OBJNULL)
@(return);
prin1(eval(sentence, &bytecodes, Cnil), Cnil);
prin1(si_eval_with_env(sentence, Cnil), Cnil);
#ifdef TK
StdinResume();
#endif

510
src/c/compiler.d
View file

@ -12,9 +12,23 @@
See file '../Copyright' for full details.
*/
/* Remarks:
[1] The virtual machine has a word size of 16 bits. Operands and arguments
have this very size, so that for instance, a jump
OP_JMP increment
takes two words of memory: one for the operator and one for the argument.
The interpreter is written with this assumption in mind, but it should be
easily modifed, because arguments are retrieved with "next_arg" and
operators with "next_op". Parts which will require a careful modification
are marked with flag [1].
*/
#include <string.h>
#include "ecl.h"
#include "ecl-inl.h"
#include "internal.h"
#include "bytecodes.h"
/********************* EXPORTS *********************/
@ -34,9 +48,11 @@
#define FLAG_USEFUL (FLAG_PUSH | FLAG_VALUES)
typedef struct {
bool coalesce;
cl_object variables;
cl_object macros;
cl_fixnum lexical_level;
cl_object constants;
#ifdef CL_COMP_OWN_STACK
cl_object bytecodes;
#endif
@ -52,24 +68,20 @@ static void set_pc(cl_index pc);
static cl_object asm_ref(register cl_index where);
static cl_index asm_begin(void);
static void asm_clear(cl_index);
static void asm1(register cl_object op);
static void asm_at(register cl_index where, register cl_object what);
static void asm_op(register int op);
#else
#define asm_begin() cl_stack_index()
#define asm_clear(h) cl_stack_set_index(h)
#define current_pc() cl_stack_index()
#define set_pc(n) cl_stack_set_index(n)
#define asm1(o) cl_stack_push(o)
#define asm_ref(n) cl_stack[n]
#define asm_at(n,o) cl_stack[n] = o
#define asm_op(o) cl_stack_push((cl_object)(o))
#define asm_ref(n) (cl_fixnum)(cl_stack[n])
#endif
#define asm_op(n) asm1(MAKE_FIXNUM(n))
static cl_object asm_end(cl_index handle, cl_object bytecodes);
static void asm_list(register cl_object l);
static void asm_op2(int op, int arg);
static cl_object asm_end(cl_index handle);
static cl_index asm_jmp(register int op);
static void asm_complete(register int op, register cl_index original);
static int c_and(cl_object args, int flags);
static int c_block(cl_object args, int flags);
static int c_case(cl_object args, int flags);
static int c_catch(cl_object args, int flags);
@ -96,7 +108,6 @@ static int c_multiple_value_prog1(cl_object args, int flags);
static int c_multiple_value_setq(cl_object args, int flags);
static int c_not(cl_object args, int flags);
static int c_nth_value(cl_object args, int flags);
static int c_or(cl_object args, int flags);
static int c_prog1(cl_object args, int flags);
static int c_progv(cl_object args, int flags);
static int c_psetq(cl_object args, int flags);
@ -108,7 +119,6 @@ static int c_symbol_macrolet(cl_object args, int flags);
static int c_tagbody(cl_object args, int flags);
static int c_throw(cl_object args, int flags);
static int c_unwind_protect(cl_object args, int flags);
static int c_when(cl_object args, int flags);
static int compile_body(cl_object args, int flags);
static int compile_form(cl_object args, int push);
@ -145,7 +155,7 @@ pop_maybe_nil(cl_object *l) {
static cl_object
alloc_bytecodes()
{
cl_object vector = cl_alloc_simple_vector(128, aet_object);
cl_object vector = cl_alloc_simple_vector(128, aet_fix);
array_allocself(vector);
vector->vector.hasfillp = TRUE;
vector->vector.fillp = 0;
@ -175,21 +185,14 @@ asm_grow(void) {
}
static void
asm1(register cl_object op) {
asm_op(register int op) {
int where = c_env.bytecodes->vector.fillp;
if (where >= c_env.bytecodes->vector.dim)
asm_grow();
c_env.bytecodes->vector.self.t[where] = op;
c_env.bytecodes->vector.self.fix[where] = op;
c_env.bytecodes->vector.fillp++;
}
static void
asm_at(register cl_index where, register cl_object what) {
if (where > c_env.bytecodes->vector.fillp)
FEprogram_error("Internal error at asm_at()",0);
c_env.bytecodes->vector.self.t[where] = what;
}
static cl_index
current_pc(void) {
return c_env.bytecodes->vector.fillp;
@ -200,86 +203,94 @@ set_pc(cl_index pc) {
c_env.bytecodes->vector.fillp = pc;
}
static cl_object
static cl_fixnum
asm_ref(register cl_index n) {
return c_env.bytecodes->vector.self.t[n];
return c_env.bytecodes->vector.self.fix[n];
}
#endif /* CL_COMP_OWN_STACK */
static cl_object
asm_end(cl_index beginning, cl_object bytecodes) {
cl_object new_bytecodes;
cl_index length, bytes;
asm_end(cl_index beginning) {
cl_object bytecodes;
cl_index code_size, data_size, i;
/* Save bytecodes from this session in a new vector */
length = current_pc() - beginning;
bytes = length * sizeof(cl_object);
if (!Null(bytecodes))
new_bytecodes = bytecodes;
else {
new_bytecodes = cl_alloc_object(t_bytecodes);
new_bytecodes->bytecodes.size = 0;
}
new_bytecodes->bytecodes.lex = Cnil;
if (new_bytecodes->bytecodes.size < length) {
new_bytecodes->bytecodes.data = (cl_object *)cl_alloc(bytes);
new_bytecodes->bytecodes.size = length;
} else {
memset(new_bytecodes->bytecodes.data, 0,
new_bytecodes->bytecodes.size * sizeof(cl_object));
}
code_size = current_pc() - beginning;
data_size = length(c_env.constants);
bytecodes = cl_alloc_object(t_bytecodes);
bytecodes->bytecodes.code_size = code_size;
bytecodes->bytecodes.data_size = data_size;
bytecodes->bytecodes.code = cl_alloc(code_size * sizeof(cl_opcode));
bytecodes->bytecodes.data = cl_alloc(data_size * sizeof(cl_object));
bytecodes->bytecodes.lex = Cnil;
for (i = 0; i < code_size; i++) {
bytecodes->bytecodes.code[i] =
#ifdef CL_COMP_OWN_STACK
memcpy(new_bytecodes->bytecodes.data,
&c_env.bytecodes->vector.self.t[beginning],
bytes);
c_env.bytecodes->vector.self.fix[beginning+i];
#else
memcpy(new_bytecodes->bytecodes.data,
&cl_stack[beginning],
bytes);
#endif
(cl_fixnum)cl_stack[beginning+i];
#endif
}
for (i=0; i < data_size; i++) {
bytecodes->bytecodes.data[i] = CAR(c_env.constants);
c_env.constants = CDR(c_env.constants);
}
asm_clear(beginning);
return new_bytecodes;
return bytecodes;
}
static void
asm_arg(int n) {
#ifdef WORDS_BIGENDIAN
asm_op((n >> 8));
asm_op(n & 0xFF);
#else
asm_op(n & 0xFF);
asm_op((n >> 8));
#endif
}
static void
asm_op2(register int code, register cl_fixnum n) {
cl_object op = MAKE_FIXNUM(code);
cl_object new_op = SET_OPARG(op, n);
asm_op2(register int code, register int n) {
if (n < -MAX_OPARG || MAX_OPARG < n)
FEprogram_error("Argument to bytecode is too large", 0);
else
asm1(new_op);
asm_op(code);
asm_arg(n);
}
static void
asm_list(register cl_object l) {
if (ATOM(l))
asm1(l);
while(!endp(l)) {
asm1(CAR(l));
l = CDR(l);
}
asm_constant(cl_object c)
{
c_env.constants = nconc(c_env.constants, CONS(c, Cnil));
}
static cl_index
asm_jmp(register int op) {
cl_index output = current_pc();
cl_index output;
asm_op(op);
output = current_pc();
asm_arg(0);
return output;
}
static void
asm_complete(register int op, register cl_index original) {
cl_fixnum delta = current_pc() - original;
cl_object code = asm_ref(original);
cl_object new_code = SET_OPARG(code, delta);
if (code != MAKE_FIXNUM(op))
asm_complete(register int op, register cl_index pc) {
cl_fixnum delta = current_pc() - pc; /* [1] */
if (op && (asm_ref(pc-1) != op))
FEprogram_error("Non matching codes in ASM-COMPLETE2", 0);
else if (delta < -MAX_OPARG || delta > MAX_OPARG)
FEprogram_error("Too large jump", 0);
else
asm_at(original, new_code);
else {
char low = delta & 0xFF;
char high = delta >> 8;
#ifdef ECL_OWN_STACK
c_env.bytecodes->vector.self.fix[pc] = low;
c_env.bytecodes->vector.self.fix[pc+1] = low;
#else
cl_stack[pc] = (cl_object)(cl_fixnum)low;
cl_stack[pc+1] = (cl_object)(cl_fixnum)high;
#endif
}
}
/* ------------------------------ COMPILER ------------------------------ */
@ -291,7 +302,6 @@ typedef struct {
} compiler_record;
static compiler_record database[] = {
{@'and', c_and, 1},
{@'block', c_block, 1},
{@'case', c_case, 1},
{@'catch', c_catch, 1},
@ -319,7 +329,6 @@ static compiler_record database[] = {
{@'not', c_not, 1},
{@'nth-value', c_nth_value, 1},
{@'null', c_not, 1},
{@'or', c_or, 1},
{@'progn', compile_body, 0},
{@'prog1', c_prog1, 1},
{@'progv', c_progv, 1},
@ -332,7 +341,6 @@ static compiler_record database[] = {
{@'throw', c_throw, 1},
{@'unwind-protect', c_unwind_protect, 1},
{@'values', c_values, 1},
{@'when', c_when, 1},
{NULL, NULL, 1}
};
@ -350,6 +358,30 @@ FEill_formed_input()
FEprogram_error("Improper list handled to the compiler.", 0);
}
static int
c_register_constant(cl_object c)
{
cl_object p = c_env.constants;
int n;
for (n = 0; !Null(p); n++, p=CDR(p)) {
if (c_env.coalesce && eql(CAR(p), c)) {
return n;
}
}
asm_constant(c);
return n;
}
static void
asm_c(register cl_object o) {
asm_arg(c_register_constant(o));
}
static void
asm_op2c(register int code, register cl_object o) {
asm_op2(code, c_register_constant(o));
}
static void
c_register_block(cl_object name)
{
@ -398,6 +430,8 @@ c_register_var(register cl_object var, bool special)
static void
c_new_env(cl_object env)
{
c_env.coalesce = TRUE;
c_env.constants = Cnil;
c_env.variables = Cnil;
c_env.macros = Cnil;
if (Null(env)) {
@ -506,12 +540,11 @@ c_pbind(cl_object var, cl_object specials)
FEillegal_variable_name(var);
else if (special = c_declared_special(var, specials)) {
c_register_var(var, TRUE);
asm_op(OP_PBINDS);
asm_op2c(OP_PBINDS, var);
} else {
c_register_var(var, FALSE);
asm_op(OP_PBIND);
asm_op2c(OP_PBIND, var);
}
asm1(var);
return special;
}
@ -523,12 +556,11 @@ c_bind(cl_object var, cl_object specials)
FEillegal_variable_name(var);
else if (special = c_declared_special(var, specials)) {
c_register_var(var, TRUE);
asm_op(OP_BINDS);
asm_op2c(OP_BINDS, var);
} else {
c_register_var(var, FALSE);
asm_op(OP_BIND);
asm_op2c(OP_BIND, var);
}
asm1(var);
return special;
}
@ -563,16 +595,13 @@ compile_setq(int op, cl_object var)
if (!SYMBOLP(var))
FEillegal_variable_name(var);
ndx = c_var_ref(var);
if (ndx >= 0) {
asm_op2(op, ndx); /* Lexical variable */
return;
} else if (var->symbol.stype == stp_constant)
FEassignment_to_constant(var);
else if (op == OP_SETQ)
asm_op(OP_SETQS); /* Special variable */
else
asm_op(OP_PSETQS); /* Special variable */
asm1(var);
if (ndx < 0) { /* Not a lexical variable */
if (var->symbol.stype == stp_constant)
FEassignment_to_constant(var);
ndx = c_register_constant(var);
op = (op == OP_SETQ)? OP_SETQS : OP_PSETQS;
}
asm_op2(op, ndx);
}
/*
@ -594,32 +623,15 @@ maybe_values(int flags) {
/* -------------------- THE COMPILER -------------------- */
static int
c_and(cl_object args, int flags) {
if (Null(args)) {
return compile_form(Ct, flags);
} else if (ATOM(args)) {
FEill_formed_input();
} else {
compile_form(pop(&args), FLAG_VALUES);
if (!endp(args)) {
cl_index label = asm_jmp(OP_JNIL);
c_and(args, FLAG_VALUES);
asm_complete(OP_JNIL, label);
}
return FLAG_VALUES;
}
}
/*
The OP_BLOCK operator encloses several forms within a block
named BLOCK_NAME, thus catching any OP_RETFROM whose argument
matches BLOCK_NAME. The end of this block is marked both by
the OP_EXIT operator and the LABELZ which is packed within
the OP_BLOCK operator.
[OP_BLOCK + labelz]
block_name
name
....
OP_EXIT_FRAME
labelz: ...
@ -640,7 +652,7 @@ c_block(cl_object body, int flags) {
labelz = asm_jmp(OP_DO);
else {
labelz = asm_jmp(OP_BLOCK);
asm1(name);
asm_c(name);
}
compile_body(body, flags);
asm_op(OP_EXIT_FRAME);
@ -667,8 +679,9 @@ c_block(cl_object body, int flags) {
while OP_PCALL and OP_PFCALL leave the first argument in the
stack.
OP_CALL and OP_PCALL use the following symbol to retrieve the
function, while OP_FCALL and OP_PFCALL use the value in VALUES(0).
OP_CALL and OP_PCALL use the value in VALUES(0) to retrieve the
function, while OP_FCALL and OP_PFCALL use a value from the
stack.
*/
static int
c_arguments(cl_object args) {
@ -689,16 +702,13 @@ c_call(cl_object args, int flags) {
name = pop(&args);
nargs = c_arguments(args);
if (SYMBOLP(name) &&
((flags & FLAG_GLOBAL) || Null(c_tag_ref(name, @':function'))))
{
/* Globally defined function */
asm_op2(push? OP_PCALLG : OP_CALLG, nargs);
asm1(name);
if (SYMBOLP(name) && (flags & FLAG_GLOBAL)) {
asm_op2c(OP_FUNCTION, name);
} else {
asm_function(name, FLAG_VALUES);
asm_op2(push? OP_PCALL : OP_CALL, nargs);
/* Fixme!! We can optimize the case of global functions! */
asm_function(name, (flags & FLAG_GLOBAL) || FLAG_VALUES);
}
asm_op2(push? OP_PCALL : OP_CALL, nargs);
return flags;
}
@ -747,24 +757,27 @@ perform_c_case(cl_object args, int flags) {
cl_index labeln, labelz;
if (CONSP(test)) {
cl_index n = length(test);
while (n > 1) {
while (n-- > 1) {
cl_object v = pop(&test);
cl_fixnum jump = (n--) * 2;
asm_op2(OP_JEQL, jump);
asm1(v);
asm_op(OP_JEQL);
asm_c(v);
asm_arg(n * (OPCODE_SIZE + OPARG_SIZE * 2)
+ OPARG_SIZE);
}
test = CAR(test);
}
labeln = asm_jmp(OP_JNEQL);
asm1(test);
asm_op(OP_JNEQL);
asm_c(test);
labeln = current_pc();
asm_arg(0);
compile_body(clause, flags);
if (endp(args) && !(flags & FLAG_USEFUL)) {
/* Ther is no otherwise. The test has failed and
we need no output value. We simply close jumps. */
asm_complete(OP_JNEQL, labeln);
asm_complete(0 & OP_JNEQL, labeln);
} else {
labelz = asm_jmp(OP_JMP);
asm_complete(OP_JNEQL, labeln);
asm_complete(0 & OP_JNEQL, labeln);
perform_c_case(args, flags);
asm_complete(OP_JMP, labelz);
}
@ -834,14 +847,7 @@ c_compiler_let(cl_object args, int flags) {
is retrieved so that if the label is in vector[0], then the
destination is roughly vector + vector[0].
2) There are two types of labels, "packed labels" and "simple
labels". The first ones are packed in the upper bits of an
operator so that
destination = vector + vector[0]>>16
Simple labels take the whole word and thus
destination = vector + fix(vector[0])
3) The three jump forms are
2) The three jump forms are
[OP_JMP + label] ; Unconditional jump
[OP_JNIL + label] ; Jump if VALUES(0) == Cnil
@ -895,8 +901,8 @@ c_cond(cl_object args, int flags) {
the lexical environment is restored, and all bindings undone.
[OP_DO + labelz]
labelz
... ; bindings
[JMP + labelt]
labelb: ... ; body
... ; stepping forms
labelt: ... ; test form
@ -982,7 +988,8 @@ c_do_doa(int op, cl_object args, int flags) {
/* Compile test */
asm_complete(OP_JMP, labelt);
compile_form(pop(&test), FLAG_VALUES);
asm_op2(OP_JNIL, labelb - current_pc());
asm_op(OP_JNIL);
asm_arg(labelb - current_pc());
/* Compile output clauses */
flags = maybe_values(flags);
@ -1016,9 +1023,9 @@ c_do(cl_object args, int flags) {
termination, the lexical environment is restored, and all
bindings undone.
[OP_DOTIMES/OP_DOLIST + labelz]
[OP_DOTIMES/OP_DOLIST + labelz + labelo]
... ; bindings
[OP_EXIT + labelo]
OP_EXIT
... ; body
... ; stepping forms
OP_EXIT
@ -1046,6 +1053,7 @@ c_dolist_dotimes(int op, cl_object args, int flags) {
/* Compute list and enter loop */
compile_form(list, FLAG_VALUES);
labelz = asm_jmp(op);
labelo = current_pc(); asm_arg(0);
/* Bind block */
c_register_block(Cnil);
@ -1053,7 +1061,7 @@ c_dolist_dotimes(int op, cl_object args, int flags) {
/* Initialize the variable */
compile_form((op == OP_DOLIST)? Cnil : MAKE_FIXNUM(0), FLAG_VALUES);
c_bind(var, specials);
labelo = asm_jmp(OP_EXIT);
asm_op(OP_EXIT);
/* From here on, declarations apply */
c_register_vars(specials);
@ -1064,7 +1072,7 @@ c_dolist_dotimes(int op, cl_object args, int flags) {
asm_op(OP_EXIT);
/* Output */
asm_complete(OP_EXIT, labelo);
asm_complete(0, labelo);
if (head != Cnil && CDR(head) != Cnil)
FEprogram_error("DOLIST: Too many output forms.", 0);
flags = maybe_values(flags);
@ -1113,7 +1121,7 @@ c_eval_when(cl_object args, int flags) {
[OP_FLET/OP_FLABELS + nfun]
fun1
...
funn
fun2
...
OP_EXIT
labelz:
@ -1153,7 +1161,7 @@ c_labels_flet(int op, cl_object args, int flags) {
for (l = def_list; !endp(l); ) {
cl_object definition = pop(&l);
cl_object name = pop(&definition);
asm1(make_lambda(name, definition));
asm_c(make_lambda(name, definition));
}
/* If compiling a FLET form, add the function names to the lexical
@ -1168,6 +1176,7 @@ c_labels_flet(int op, cl_object args, int flags) {
c_undo_bindings(old_c_env.variables);
/* Restore and return */
old_c_env.constants = c_env.constants;
c_env = old_c_env;
return flags;
@ -1183,8 +1192,7 @@ c_flet(cl_object args, int flags) {
/*
There are two operators that produce functions. The first one
is
OP_FUNCTION
symbol
[OP_FUNCTION + name]
which takes the function binding of SYMBOL. The second one is
OP_CLOSE
interpreted
@ -1205,20 +1213,17 @@ asm_function(cl_object function, int flags) {
cl_object ndx = c_tag_ref(function, @':function');
if (Null(ndx)) {
/* Globally defined function */
asm_op(OP_FUNCTION);
asm1(function);
asm_op2c(OP_FUNCTION, function);
} else {
/* Function from a FLET/LABELS form */
asm_op2(OP_LFUNCTION, fix(ndx));
}
} else if (CONSP(function) && CAR(function) == @'lambda') {
asm_op(OP_CLOSE);
asm1(make_lambda(Cnil, CDR(function)));
asm_op2c(OP_CLOSE, make_lambda(Cnil, CDR(function)));
} else if (CONSP(function) && CAR(function) == @'lambda-block') {
cl_object name = CADR(function);
cl_object body = CDDR(function);
asm_op(OP_CLOSE);
asm1(make_lambda(name, body));
asm_op2c(OP_CLOSE, make_lambda(name, body));
} else {
FEprogram_error("FUNCTION: Not a valid argument ~S.", 1, function);
}
@ -1235,7 +1240,7 @@ c_go(cl_object args, int flags) {
if (!Null(args))
FEprogram_error("GO: Too many arguments.",0);
asm_op2(OP_GO, fix(CAR(info)));
asm1(CDR(info));
asm_c(CDR(info));
return flags;
}
@ -1296,14 +1301,14 @@ c_labels(cl_object args, int flags) {
OP_EXIT
There are four forms which perform bindings
OP_PBIND ; Bind NAME in the lexical env. using
name ; a value from the stack
OP_PBINDS ; Bind NAME as special variable using
name ; a value from the stack
OP_BIND ; Bind NAME in the lexical env. using
name ; VALUES(0)
OP_BINDS ; Bind NAME as special variable using
name ; VALUES(0)
OP_PBIND name ; Bind NAME in the lexical env. using
; a value from the stack
OP_PBINDS name ; Bind NAME as special variable using
; a value from the stack
OP_BIND name ; Bind NAME in the lexical env. using
; VALUES(0)
OP_BINDS name ; Bind NAME as special variable using
; VALUES(0)
After a variable has been bound, there are several ways to
refer to it.
@ -1456,7 +1461,7 @@ c_multiple_value_bind(cl_object args, int flags)
c_register_var(var, FALSE);
asm_op2(OP_VBIND, n);
}
asm1(var);
asm_c(var);
}
flags = compile_body(body, flags);
c_undo_bindings(old_variables);
@ -1556,13 +1561,12 @@ c_multiple_value_setq(cl_object args, int flags) {
if (!SYMBOLP(var))
FEillegal_variable_name(var);
ndx = c_var_ref(var);
if (ndx >= 0)
asm1(MAKE_FIXNUM(ndx)); /* Lexical variable */
else if (var->symbol.stype == stp_constant)
FEassignment_to_constant(var);
else {
asm1(var);
if (ndx < 0) { /* Global variable */
if (var->symbol.stype == stp_constant)
FEassignment_to_constant(var);
ndx = -1-c_register_constant(var);
}
asm_arg(ndx);
}
/* Assign to symbol-macros */
@ -1612,24 +1616,6 @@ c_nth_value(cl_object args, int flags) {
}
static int
c_or(cl_object args, int flags) {
if (Null(args)) {
return compile_form(Cnil, flags);
} else if (ATOM(args)) {
FEill_formed_input();
} else {
compile_form(pop(&args), FLAG_VALUES);
if (!endp(args)) {
cl_index label = asm_jmp(OP_JT);
c_or(args, FLAG_VALUES);
asm_complete(OP_JT, label);
}
}
return FLAG_VALUES;
}
static int
c_prog1(cl_object args, int flags) {
cl_object form = pop(&args);
@ -1690,8 +1676,7 @@ c_progv(cl_object args, int flags) {
[OP_SETQ + n]
2) Assign VALUES(0) to the special variable NAME
OP_SETQS
name
[OP_SETQS + name]
3) Pop a value from the stack and assign it to the lexical
variable in the N-th position.
@ -1699,8 +1684,7 @@ c_progv(cl_object args, int flags) {
4) Pop a value from the stack and assign it to the special
variable denoted by NAME
OP_PSETQS
name
[OP_PSETQS + name]
*/
static int
c_psetq(cl_object old_args, int flags) {
@ -1855,15 +1839,15 @@ c_tagbody(cl_object args, int flags)
asm_op2(OP_TAGBODY, nt);
tag_base = current_pc();
for (i = nt; i; i--)
asm1(Cnil);
asm_arg(0);
for (body = args; !endp(body); body = CDR(body)) {
label = CAR(body);
item_type = type_of(label);
if (item_type == t_symbol || item_type == t_fixnum ||
item_type == t_bignum) {
asm_at(tag_base, MAKE_FIXNUM(current_pc()-tag_base));
tag_base++;
asm_complete(0, tag_base);
tag_base += OPARG_SIZE;
} else {
compile_form(label, FLAG_IGNORE);
}
@ -1947,29 +1931,12 @@ c_values(cl_object args, int flags) {
}
static int
c_when(cl_object form, int flags) {
cl_fixnum label;
flags = maybe_values(flags);
/* Compile test */
compile_form(pop(&form), FLAG_VALUES);
label = asm_jmp(OP_JNIL);
/* Compile body */
flags = compile_body(form, flags);
asm_complete(OP_JNIL, label);
return flags;
}
static int
compile_form(cl_object stmt, int flags) {
compiler_record *l;
cl_object function;
bool push = flags & FLAG_PUSH;
int new_flags;
/* FIXME! We should protect this region with error handling */
BEGIN:
@ -1977,9 +1944,9 @@ compile_form(cl_object stmt, int flags) {
* First try with variable references and quoted constants
*/
if (ATOM(stmt)) {
cl_fixnum index;
if (SYMBOLP(stmt) && stmt != Cnil) {
cl_object stmt1 = c_macro_expand1(stmt);
cl_fixnum index;
if (stmt1 != stmt) {
stmt = stmt1;
goto BEGIN;
@ -1988,23 +1955,18 @@ compile_form(cl_object stmt, int flags) {
if (index >= 0) {
asm_op2(push? OP_PUSHV : OP_VAR, index);
} else {
asm_op(push? OP_PUSHVS : OP_VARS);
asm1(stmt);
asm_op2c(push? OP_PUSHVS : OP_VARS, stmt);
}
goto OUTPUT;
}
} else
QUOTED:
if (!(flags & FLAG_USEFUL))
goto OUTPUT;
if (stmt == Cnil) {
asm_op(push? OP_PUSHNIL : OP_NIL);
goto OUTPUT;
if ((flags & FLAG_USEFUL)) {
if (stmt == Cnil) {
asm_op(push? OP_PUSHNIL : OP_NIL);
} else {
asm_op2c(push? OP_PUSHQ : OP_QUOTE, stmt);
}
}
if (push)
asm_op(OP_PUSHQ);
else if (FIXNUMP(stmt))
asm_op(OP_QUOTE);
asm1(stmt);
new_flags = flags;
goto OUTPUT;
}
/*
@ -2022,11 +1984,8 @@ compile_form(cl_object stmt, int flags) {
}
for (l = database; l->symbol != OBJNULL; l++)
if (l->symbol == function) {
int new_flags;
c_env.lexical_level += l->lexical_increment;
new_flags = (*(l->compiler))(CDR(stmt), flags);
if (push && !(new_flags & FLAG_PUSH))
asm_op(OP_PUSH);
goto OUTPUT;
}
/*
@ -2046,8 +2005,10 @@ for special form ~S.", 1, function);
/*
* Finally resort to ordinary function calls.
*/
c_call(stmt, flags);
new_flags = c_call(stmt, flags);
OUTPUT:
if (push && !(new_flags & FLAG_PUSH))
asm_op(OP_PUSH);
return flags;
}
@ -2063,9 +2024,14 @@ compile_body(cl_object body, int flags) {
asm_op(OP_HALT);
VALUES(0) = Cnil;
NValues = 0;
bytecodes = asm_end(handle, Cnil);
interpret(bytecodes->bytecodes.data);
bytecodes = asm_end(handle);
interpret(bytecodes, bytecodes->bytecodes.code);
asm_clear(handle);
#ifdef GBC_BOEHM
GC_free(bytecodes->bytecodes.code);
GC_free(bytecodes->bytecodes.data);
GC_free(bytecodes);
#endif
body = CDR(body);
}
}
@ -2374,22 +2340,22 @@ ILLEGAL_LAMBDA:
FEprogram_error("LAMBDA: Illegal lambda list ~S.", 1, org_lambda_list);
}
static void
c_default(cl_index deflt_pc) {
cl_object deflt = asm_ref(deflt_pc);
static cl_object
c_default(cl_fixnum base_pc, cl_object deflt) {
cl_type t = type_of(deflt);
if (((t == t_symbol) && (deflt->symbol.stype == stp_constant) &&
!FIXNUMP(SYM_VAL(deflt)))) {
/* FIXME! Shouldn't this happen only in unsafe mode */
asm_at(deflt_pc, SYM_VAL(deflt));
deflt = SYM_VAL(deflt);
} else if (CONSP(deflt) && (CAR(deflt) == @'quote') && !FIXNUMP(CADR(deflt))) {
asm_at(deflt_pc, CADR(deflt));
deflt = CADR(deflt);
} else if ((t == t_symbol) || (t == t_cons) || (t == t_fixnum)) {
cl_index pc = current_pc();
asm_at(deflt_pc, MAKE_FIXNUM(pc-deflt_pc));
cl_fixnum pc = current_pc()-base_pc;
compile_form(deflt, FLAG_VALUES);
asm_op(OP_EXIT);
deflt = MAKE_FIXNUM(pc);
}
return deflt;
}
static void
@ -2412,12 +2378,13 @@ cl_object
make_lambda(cl_object name, cl_object lambda) {
cl_object reqs, opts, rest, key, keys, auxs, allow_other_keys;
cl_object specials, doc, decl, body, output;
cl_index opts_pc, keys_pc, label;
cl_index label;
int nopts, nkeys;
cl_index handle;
cl_compiler_env old_c_env = c_env;
c_env.lexical_level++;
c_env.coalesce = 0;
reqs = si_process_lambda(lambda);
opts = VALUES(1);
@ -2437,58 +2404,59 @@ make_lambda(cl_object name, cl_object lambda) {
if (Null(si_valid_function_name_p(name)))
FEprogram_error("LAMBDA: Not a valid function name ~S",1,name);
asm_list(reqs); /* Special arguments */
c_env.constants = reqs; /* Special arguments */
reqs = CDR(reqs);
while (!endp(reqs)) {
cl_object v = pop(&reqs);
c_register_var2(v, &specials);
}
opts_pc = current_pc()+1; /* Optional arguments */
nopts = fix(CAR(opts));
asm_list(opts);
nopts = fix(CAR(opts)); /* Optional arguments */
c_env.constants = nconc(c_env.constants, opts);
asm1(rest); /* Name of &rest argument */
asm_constant(rest); /* Name of &rest argument */
if (Null(key)) {
asm1(MAKE_FIXNUM(0)); /* &key was not supplied */
asm_constant(MAKE_FIXNUM(0)); /* &key was not supplied */
nkeys = 0;
} else {
asm1(allow_other_keys); /* Value of &allow-other-keys */
keys_pc = current_pc()+1; /* Keyword arguments */
nkeys = fix(CAR(keys));
asm_list(keys);
asm_constant(allow_other_keys); /* Value of &allow-other-keys */
nkeys = fix(CAR(keys)); /* Keyword arguments */
c_env.constants = nconc(c_env.constants, keys);
}
asm1(doc);
asm1(decl);
asm_constant(doc);
asm_constant(decl);
label = asm_jmp(OP_JMP);
opts = CDR(opts);
while (nopts--) {
c_default(opts_pc+1);
c_register_var2(asm_ref(opts_pc), &specials);
c_register_var2(asm_ref(opts_pc+2), &specials);
opts_pc+=3;
CADR(opts) = c_default(handle, CADR(opts));
c_register_var2(CAR(opts), &specials);
c_register_var2(CADDR(opts), &specials);
opts = CDDDR(opts);
}
c_register_var2(rest, &specials);
keys = CDR(keys);
while (nkeys--) {
c_default(keys_pc+2);
c_register_var2(asm_ref(keys_pc+1), &specials);
c_register_var2(asm_ref(keys_pc+3), &specials);
keys_pc+=4;
CADDR(keys) = c_default(handle, CADDR(keys));
c_register_var2(CADR(keys), &specials);
c_register_var2(CADDDR(keys), &specials);
keys = CDDDDR(keys);
}
c_env.coalesce = TRUE;
if (!Null(name))
c_register_block(si_function_block_name(name));
if ((current_pc() - label) == 1)
set_pc(label);
set_pc(handle);
else
asm_complete(OP_JMP, label);
while (!endp(auxs)) { /* Local bindings */
cl_object var = pop(&auxs);
cl_object value = pop(&auxs);
compile_form(value, FLAG_VALUES);
c_bind(var, specials);
}
@ -2496,7 +2464,7 @@ make_lambda(cl_object name, cl_object lambda) {
compile_body(body, FLAG_VALUES);
asm_op(OP_HALT);
output = asm_end(handle, Cnil);
output = asm_end(handle);
output->bytecodes.name = name;
output->bytecodes.specials = specials;
output->bytecodes.definition = Null(SYM_VAL(@'si::*keep-definitions*'))?
@ -2548,7 +2516,7 @@ si_make_lambda(cl_object name, cl_object rest)
}
cl_object
eval(cl_object form, cl_object *new_bytecodes, cl_object env)
si_eval_with_env(cl_object form, cl_object env)
{
volatile cl_compiler_env old_c_env = c_env;
volatile cl_index handle;
@ -2561,12 +2529,7 @@ eval(cl_object form, cl_object *new_bytecodes, cl_object env)
compile_form(form, FLAG_VALUES);
asm_op(OP_EXIT);
asm_op(OP_HALT);
if (new_bytecodes == NULL)
bytecodes = asm_end(handle, Cnil);
else {
bytecodes = asm_end(handle, *new_bytecodes);
*new_bytecodes = bytecodes;
}
bytecodes = asm_end(handle);
} CL_UNWIND_PROTECT_EXIT {
#ifdef CL_COMP_OWN_STACK
asm_clear(handle);
@ -2577,7 +2540,12 @@ eval(cl_object form, cl_object *new_bytecodes, cl_object env)
lex_env = env;
VALUES(0) = Cnil;
NValues = 0;
interpret(bytecodes->bytecodes.data);
interpret(bytecodes, bytecodes->bytecodes.code);
#ifdef GBC_BOEHM
GC_free(bytecodes->bytecodes.code);
GC_free(bytecodes->bytecodes.data);
GC_free(bytecodes);
#endif
ihs_pop();
return VALUES(0);
}

343
src/c/disassembler.d
View file

@ -16,11 +16,9 @@
#include "ecl-inl.h"
#include "bytecodes.h"
#define next_code(v) (*(v++))
static char *disassemble(cl_object bytecodes, char *vector);
static cl_object *disassemble(cl_object *vector);
static cl_object *base = NULL;
static char *base = NULL;
static void
print_noarg(const char *s) {
@ -48,134 +46,124 @@ print_oparg_arg(const char *s, cl_fixnum n, cl_object x) {
}
static cl_object *
disassemble_vars(const char *message, cl_object *vector, cl_index step) {
cl_index n = fix(next_code(vector));
disassemble_vars(const char *message, cl_object *data, cl_index step) {
cl_object o = *(data++);
cl_index n = fix(o);
if (n) {
terpri(Cnil);
print_noarg(message);
for (; n; n--, vector+=step) {
prin1(vector[0], Cnil);
for (; n; n--, data+=step) {
prin1(data[0], Cnil);
if (n > 1) print_noarg(", ");
}
}
return vector;
return data;
}
static void
disassemble_lambda(cl_object bytecodes) {
cl_object *vector = bytecodes->bytecodes.data;
cl_object *data;
char *vector;
/* Name of LAMBDA */
print_arg("\nName:\t\t", bytecodes->bytecodes.name);
/* Print required arguments */
vector = disassemble_vars("Required:\t", vector, 1);
data = bytecodes->bytecodes.data;
data = disassemble_vars("Required:\t", data, 1);
/* Print optional arguments */
vector = disassemble_vars("Optionals:\t", vector, 3);
data = disassemble_vars("Optionals:\t", data, 3);
/* Print rest argument */
if (vector[0] != Cnil) {
print_arg("\nRest:\t\t", vector[0]);
if (data[0] != Cnil) {
print_arg("\nRest:\t\t", data[0]);
}
vector++;
data++;
/* Print keyword arguments */
if (vector[0] == MAKE_FIXNUM(0)) {
vector++;
if (data[0] == MAKE_FIXNUM(0)) {
data++;
goto NO_KEYS;
}
if (vector[0] != Cnil) {
print_arg("\nOther keys:\t", vector[0]);
if (data[0] != Cnil) {
print_arg("\nOther keys:\t", data[0]);
}
vector++;
vector = disassemble_vars("Keywords:\t", vector, 4);
data++;
data = disassemble_vars("Keywords:\t", data, 4);
NO_KEYS:
/* Print aux arguments */
print_arg("\nDocumentation:\t", next_code(vector));
print_arg("\nDeclarations:\t", next_code(vector));
print_arg("\nDocumentation:\t", *(data++));
print_arg("\nDeclarations:\t", *(data++));
base = vector;
while (vector[0] != MAKE_FIXNUM(OP_HALT))
vector = disassemble(vector);
}
/* -------------------- DISASSEMBLER AIDS -------------------- */
static inline cl_fixnum
get_oparg(cl_object o) {
return GET_OPARG(o);
}
static inline cl_fixnum
packed_label(cl_object *v) {
return v + get_oparg(v[0]) - base;
}
static inline cl_fixnum
simple_label(cl_object *v) {
return v + fix(v[0]) - base;
base = vector = bytecodes->bytecodes.code;
while (vector[0] != OP_HALT)
vector = disassemble(bytecodes, vector);
}
/* -------------------- DISASSEMBLER CORE -------------------- */
/* OP_DOLIST label
/* OP_DOLIST labelz, labelo
... ; code to bind the local variable
OP_EXIT
... ; code executed on each iteration
OP_EXIT
labelo:
... ; code executed at the end
OP_EXIT
label:
labelz:
High level construct for the DOLIST iterator. The list over which
we iterate is stored in VALUES(0).
*/
static cl_object *
disassemble_dolist(cl_object *vector) {
cl_fixnum exit;
static char *
disassemble_dolist(cl_object bytecodes, char *vector) {
char *exit, *output;
cl_object lex_old = lex_env;
lex_copy();
exit = packed_label(vector-1);
print_oparg("DOLIST\t", exit);
vector = disassemble(vector);
GET_LABEL(exit, vector);
GET_LABEL(output, vector);
print_oparg("DOLIST\t", exit-base);
vector = disassemble(bytecodes, vector);
print_noarg("\t\t; dolist binding");
vector = disassemble(vector);
vector = disassemble(bytecodes, vector);
print_noarg("\t\t; dolist body");
vector = disassemble(vector);
vector = disassemble(bytecodes, vector);
print_noarg("\t\t; dolist");
lex_env = lex_old;
return vector;
}
/* OP_TIMES label
/* OP_TIMES labelz, labelo
... ; code to bind the local variable
OP_EXIT
... ; code executed on each iteration
OP_EXIT
labelo:
... ; code executed at the end
OP_EXIT
label:
labelz:
High level construct for the DOTIMES iterator. The number of times
we iterate is stored in VALUES(0).
*/
static cl_object *
disassemble_dotimes(cl_object *vector) {
cl_fixnum exit;
static char *
disassemble_dotimes(cl_object bytecodes, char *vector) {
char *exit, *output;
cl_object lex_old = lex_env;
lex_copy();
exit = packed_label(vector-1);
print_oparg("DOTIMES\t", exit);
vector = disassemble(vector);
GET_LABEL(exit, vector);
GET_LABEL(output, vector);
print_oparg("DOTIMES\t", exit-base);
vector = disassemble(bytecodes, vector);
print_noarg("\t\t; dotimes times");
vector = disassemble(vector);
vector = disassemble(bytecodes, vector);
print_noarg("\t\t; dotimes body");
vector = disassemble(vector);
vector = disassemble(bytecodes, vector);
print_noarg("\t\t; dotimes");
lex_env = lex_old;
@ -191,19 +179,19 @@ disassemble_dotimes(cl_object *vector) {
Executes the enclosed code in a lexical enviroment extended with
the functions "fun1" ... "funn".
*/
static cl_object *
disassemble_flet(cl_object *vector) {
static char *
disassemble_flet(cl_object bytecodes, char *vector) {
cl_object lex_old = lex_env;
cl_index nfun = get_oparg(vector[-1]);
cl_index nfun = GET_OPARG(vector);
print_noarg("FLET");
lex_copy();
while (nfun--) {
cl_object fun = next_code(vector);
cl_object fun = GET_DATA(vector, bytecodes);
print_noarg("\n\tFLET\t");
@prin1(1, fun->bytecodes.name);
}
vector = disassemble(vector);
vector = disassemble(bytecodes, vector);
print_noarg("\t\t; flet");
lex_env = lex_old;
@ -219,18 +207,18 @@ disassemble_flet(cl_object *vector) {
Executes the enclosed code in a lexical enviroment extended with
the functions "fun1" ... "funn".
*/
static cl_object *
disassemble_labels(cl_object *vector) {
static char *
disassemble_labels(cl_object bytecodes, char *vector) {
cl_object lex_old = lex_env;
cl_index nfun = get_oparg(vector[-1]);
cl_index nfun = GET_OPARG(vector);
print_noarg("LABELS");
lex_copy();
while (nfun--) {
cl_object fun = next_code(vector);
cl_object fun = GET_DATA(vector, bytecodes);
print_arg("\n\tLABELS\t", fun->bytecodes.name);
}
vector = disassemble(vector);
vector = disassemble(bytecodes, vector);
print_noarg("\t\t; labels");
lex_env = lex_old;
@ -238,35 +226,37 @@ disassemble_labels(cl_object *vector) {
}
/* OP_MSETQ n{arg}
{fixnumn}|{symboln}
{fixnumn}
...
{fixnum1}|{symbol1}
{fixnum1}
Sets N variables to the N values in VALUES(), filling with
NIL when there are values missing. Local variables are denoted
with an integer which points a position in the lexical environment,
while special variables are denoted just with the name.
while special variables are denoted with a negative index X, which
denotes the value -1-X in the table of constants.
*/
static cl_object *
disassemble_msetq(cl_object *vector)
static char *
disassemble_msetq(cl_object bytecodes, char *vector)
{
int i, n = get_oparg(vector[-1]);
int i, n = GET_OPARG(vector);
bool newline = FALSE;
for (i=0; i<n; i++) {
cl_object var = next_code(vector);
cl_fixnum var = GET_OPARG(vector);
if (newline) {
print_noarg("\n\t");
} else
newline = TRUE;
if (FIXNUMP(var)) {
if (var >= 0) {
cl_format(4, Ct,
make_constant_string("MSETQ\t~D,VALUES(~D)"),
var, MAKE_FIXNUM(i));
MAKE_FIXNUM(var), MAKE_FIXNUM(i));
} else {
cl_object name = bytecodes->bytecodes.data[-1-var];
cl_format(4, Ct,
make_constant_string("MSETQS\t~A,VALUES(~D)"),
var, MAKE_FIXNUM(i));
name, MAKE_FIXNUM(i));
}
}
return vector;
@ -279,19 +269,17 @@ disassemble_msetq(cl_object *vector)
Execute the code enclosed with the special variables in BINDINGS
set to the values in the list which was passed in VALUES(0).
*/
static cl_object *
disassemble_progv(cl_object *vector) {
static char *
disassemble_progv(cl_object bytecodes, char *vector) {
print_noarg("PROGV");
vector = disassemble(vector);
vector = disassemble(bytecodes, vector);
print_noarg("\t\t; progv");
return vector;
}
/* OP_TAGBODY n{arg}
tag1
label1
...
tagn
labeln
label1:
...
@ -301,64 +289,55 @@ labeln:
High level construct for the TAGBODY form.
*/
static cl_object *
disassemble_tagbody(cl_object *vector) {
cl_index i, ntags = get_oparg(vector[-1]);
static char *
disassemble_tagbody(cl_object bytecodes, char *vector) {
cl_index i, ntags = GET_OPARG(vector);
cl_object lex_old = lex_env;
char *destination;
lex_copy();
print_noarg("TAGBODY");
for (i=0; i<ntags; i++, vector++) {
for (i=0; i<ntags; i++) {
GET_LABEL(destination, vector);
cl_format(4, Ct,
make_constant_string("\n\tTAG\t~D @@ ~D"),
MAKE_FIXNUM(i), MAKE_FIXNUM(simple_label(vector)));
MAKE_FIXNUM(i), MAKE_FIXNUM(destination-base));
}
vector = disassemble(vector);
vector = disassemble(bytecodes, vector);
print_noarg("\t\t; tagbody");
lex_env = lex_old;
return vector;
}
static cl_object *
disassemble(cl_object *vector) {
static char *
disassemble(cl_object bytecodes, char *vector) {
const char *string;
cl_type t;
cl_object s;
cl_object o;
cl_fixnum n;
cl_object line_format = make_constant_string("~%~4d\t");
BEGIN:
cl_format(3, Ct, line_format, MAKE_FIXNUM(vector-base));
s = next_code(vector);
t = type_of(s);
if (t == t_symbol) {
string = "QUOTE\t";
goto ARG;
}
if (t != t_fixnum) {
@prin1(1, s);
goto BEGIN;
}
switch (GET_OP(s)) {
switch (GET_OPCODE(vector)) {
/* OP_NOP
Sets VALUES(0) = NIL and NValues = 1
*/
*/
case OP_NOP: string = "NOP"; goto NOARG;
/* OP_QUOTE
Sets VALUES(0) to an immediate value.
*/
case OP_QUOTE: string = "QUOTE\t";
s = next_code(vector);
o = GET_DATA(vector, bytecodes);
goto ARG;
/* OP_VAR n{arg}
Sets NValues=1 and VALUES(0) to the value of the n-th local.
*/
case OP_VAR: string = "VAR\t";
n = get_oparg(s);
n = GET_OPARG(vector);
goto OPARG;
/* OP_VARS var{symbol}
@ -366,7 +345,7 @@ disassemble(cl_object *vector) {
VAR should be either a special variable or a constant.
*/
case OP_VARS: string = "VARS\t";
s = next_code(vector);
o = GET_DATA(vector, bytecodes);
goto ARG;
/* OP_PUSH
@ -379,7 +358,7 @@ disassemble(cl_object *vector) {
Pushes the value of the n-th local onto the stack.
*/
case OP_PUSHV: string = "PUSHV\t";
n = get_oparg(s);
n = GET_OPARG(vector);
goto OPARG;
/* OP_PUSHVS var{symbol}
@ -387,14 +366,14 @@ disassemble(cl_object *vector) {
VAR should be either a special variable or a constant.
*/
case OP_PUSHVS: string = "PUSHVS\t";
s = next_code(vector);
o = GET_DATA(vector, bytecodes);
goto ARG;
/* OP_PUSHQ value{object}
Pushes "value" onto the stack.
*/
case OP_PUSHQ: string = "PUSH\t'";
s = next_code(vector);
o = GET_DATA(vector, bytecodes);
goto ARG;
/* OP_PUSHVALUES
@ -428,19 +407,7 @@ disassemble(cl_object *vector) {
to the first instruction after OP_EXIT.
*/
case OP_BLOCK: string = "BLOCK\t";
n = packed_label(vector - 1);
s = next_code(vector);
goto OPARG_ARG;
/* OP_CALLG n{arg}, function-name{symbol}
Calls the global function with N arguments which have
been deposited in the stack. The output values are
left in VALUES(...)
*/
case OP_CALLG: string = "CALLG\t";
n = get_oparg(s);
s = next_code(vector);
goto OPARG_ARG;
goto JEQL;
/* OP_CALL n{arg}
Calls the function in VALUES(0) with N arguments which
@ -448,7 +415,7 @@ disassemble(cl_object *vector) {
are left in VALUES(...)
*/
case OP_CALL: string = "CALL\t";
n = get_oparg(s);
n = GET_OPARG(vector);
goto OPARG;
/* OP_FCALL n{arg}
@ -457,26 +424,16 @@ disassemble(cl_object *vector) {
are left in VALUES(...)
*/
case OP_FCALL: string = "FCALL\t";
n = get_oparg(s);
n = GET_OPARG(vector);
goto OPARG;
/* OP_PCALLG n{arg}, function-name{symbol}
Calls the global function with N arguments which have
been deposited in the stack. The first output value is
left on the stack.
*/
case OP_PCALLG: string = "PCALLG\t";
n = get_oparg(s);
s = next_code(vector);
goto OPARG_ARG;
/* OP_PCALL n{arg}
Calls the function in VALUES(0) with N arguments which
have been deposited in the stack. The first output value
is pushed on the stack.
*/
case OP_PCALL: string = "PCALL\t";
n = get_oparg(s);
n = GET_OPARG(vector);
goto OPARG;
/* OP_PFCALL n{arg}
@ -485,7 +442,7 @@ disassemble(cl_object *vector) {
is pushed on the stack.
*/
case OP_PFCALL: string = "PFCALL\t";
n = get_oparg(s);
n = GET_OPARG(vector);
goto OPARG;
/* OP_MCALL
@ -504,9 +461,7 @@ disassemble(cl_object *vector) {
first instruction after the end (OP_EXIT) of the block
*/
case OP_CATCH: string = "CATCH\t";
n = packed_label(vector - 1);
goto OPARG;
goto JMP;
/* OP_EXIT
Marks the end of a high level construct (DOLIST, DOTIMES...)
*/
@ -529,9 +484,9 @@ disassemble(cl_object *vector) {
case OP_HALT: print_noarg("HALT");
return vector-1;
case OP_FLET: vector = disassemble_flet(vector);
case OP_FLET: vector = disassemble_flet(bytecodes, vector);
break;
case OP_LABELS: vector = disassemble_labels(vector);
case OP_LABELS: vector = disassemble_labels(bytecodes, vector);
break;
/* OP_LFUNCTION name{symbol}
@ -540,7 +495,7 @@ disassemble(cl_object *vector) {
environment. This last value takes precedence.
*/
case OP_LFUNCTION: string = "LOCFUNC\t";
n = get_oparg(s);
n = GET_OPARG(vector);
goto OPARG;
/* OP_FUNCTION name{symbol}
@ -549,26 +504,27 @@ disassemble(cl_object *vector) {
environment. This last value takes precedence.
*/
case OP_FUNCTION: string = "SYMFUNC\t";
s = next_code(vector);
o = GET_DATA(vector, bytecodes);
goto ARG;
/* OP_CLOSE name{symbol}
/* OP_CLOSE name{arg}
Extracts the function associated to a symbol. The function
may be defined in the global environment or in the local
environment. This last value takes precedence.
*/
case OP_CLOSE: string = "CLOSE\t";
s = next_code(vector);
o = GET_DATA(vector, bytecodes);
goto ARG;
/* OP_GO n{arg}, tag-name{symbol}
/* OP_GO n{arg}
OP_QUOTE tag-name{symbol}
Jumps to the tag which is defined at the n-th position in
the lexical environment. TAG-NAME is kept for debugging
purposes.
*/
case OP_GO: string = "GO\t";
n = get_oparg(s);
s = next_code(vector);
n = GET_OPARG(vector);
o = GET_DATA(vector, bytecodes);
goto OPARG_ARG;
/* OP_RETURN n{arg}
@ -576,7 +532,7 @@ disassemble(cl_object *vector) {
occuppies the n-th position.
*/
case OP_RETURN: string = "RETFROM";
n = get_oparg(s);
n = GET_OPARG(vector);
goto OPARG;
/* OP_THROW
@ -596,22 +552,23 @@ disassemble(cl_object *vector) {
comparing with the value of VALUES(0).
*/
case OP_JMP: string = "JMP\t";
n = packed_label(vector-1);
goto OPARG;
goto JMP;
case OP_JNIL: string = "JNIL\t";
n = packed_label(vector-1);
goto OPARG;
goto JMP;
case OP_JT: string = "JT\t";
n = packed_label(vector-1);
JMP: { cl_oparg jmp = GET_OPARG(vector);
n = vector + jmp - OPARG_SIZE - base;
goto OPARG;
}
case OP_JEQL: string = "JEQL\t";
s = next_code(vector);
n = packed_label(vector-2);
goto OPARG_ARG;
goto JEQL;
case OP_JNEQL: string = "JNEQL\t";
s = next_code(vector);
n = packed_label(vector-2);
JEQL: { cl_oparg jmp;
o = GET_DATA(vector, bytecodes);
jmp = GET_OPARG(vector);
n = vector + jmp - OPARG_SIZE - base;
goto OPARG_ARG;
}
case OP_NOT: string = "NOT\t";
goto NOARG;
@ -619,13 +576,13 @@ disassemble(cl_object *vector) {
Undo "n" bindings of lexical variables.
*/
case OP_UNBIND: string = "UNBIND\t";
n = get_oparg(s);
n = GET_OPARG(vector);
goto OPARG;
/* OP_UNBINDS n{arg}
Undo "n" bindings of special variables.
*/
case OP_UNBINDS: string = "UNBINDS\t";
n = get_oparg(s);
n = GET_OPARG(vector);
goto OPARG;
/* OP_BIND name{symbol}
OP_PBIND name{symbol}
@ -636,24 +593,24 @@ disassemble(cl_object *vector) {
to the n-th value of VALUES(...).
*/
case OP_BIND: string = "BIND\t";
s = next_code(vector);
o = GET_DATA(vector, bytecodes);
goto ARG;
case OP_PBIND: string = "PBIND\t";
s = next_code(vector);
o = GET_DATA(vector, bytecodes);
goto ARG;
case OP_VBIND: string = "VBIND\t";
n = get_oparg(s);
s = next_code(vector);
n = GET_OPARG(vector);
o = GET_DATA(vector, bytecodes);
goto OPARG_ARG;
case OP_BINDS: string = "BINDS\t";
s = next_code(vector);
o = GET_DATA(vector, bytecodes);
goto ARG;
case OP_PBINDS: string = "PBINDS\t";
s = next_code(vector);
o = GET_DATA(vector, bytecodes);
goto ARG;
case OP_VBINDS: string = "VBINDS\t";
n = get_oparg(s);
s = next_code(vector);
n = GET_OPARG(vector);
o = GET_DATA(vector, bytecodes);
goto OPARG_ARG;
/* OP_SETQ n{arg}
OP_PSETQ n{arg}
@ -664,28 +621,28 @@ disassemble(cl_object *vector) {
first value on the stack (OP_PSETQ[S]).
*/
case OP_SETQ: string = "SETQ\t";
n = get_oparg(s);
n = GET_OPARG(vector);
goto OPARG;
case OP_PSETQ: string = "PSETQ\t";
n = get_oparg(s);
n = GET_OPARG(vector);
goto OPARG;
case OP_SETQS: string = "SETQS";
s = next_code(vector);
o = GET_DATA(vector, bytecodes);
goto ARG;
case OP_PSETQS: string = "PSETQS";
s = next_code(vector);
o = GET_DATA(vector, bytecodes);
goto ARG;
case OP_MSETQ: vector = disassemble_msetq(vector);
case OP_MSETQ: vector = disassemble_msetq(bytecodes, vector);
break;
case OP_PROGV: vector = disassemble_progv(vector);
case OP_PROGV: vector = disassemble_progv(bytecodes, vector);
break;
/* OP_VALUES n{arg}
Pop N values from the stack and store them in VALUES(...)
*/
case OP_VALUES: string = "VALUES\t";
n = get_oparg(s);
n = GET_OPARG(vector);
goto OPARG;
/* OP_NTHVAL
Set VALUES(0) to the N-th value of the VALUES(...) list.
@ -693,9 +650,9 @@ disassemble(cl_object *vector) {
*/
case OP_NTHVAL: string = "NTHVAL\t";
goto NOARG;
case OP_DOLIST: vector = disassemble_dolist(vector);
case OP_DOLIST: vector = disassemble_dolist(bytecodes, vector);
break;
case OP_DOTIMES: vector = disassemble_dotimes(vector);
case OP_DOTIMES: vector = disassemble_dotimes(bytecodes, vector);
break;
/* OP_DO label
... ; code executed within a NIL block
@ -705,9 +662,8 @@ disassemble(cl_object *vector) {
High level construct for the DO and BLOCK forms.
*/
case OP_DO: string = "DO\t";
n = packed_label(vector - 1);
goto OPARG;
case OP_TAGBODY: vector = disassemble_tagbody(vector);
goto JMP;
case OP_TAGBODY: vector = disassemble_tagbody(bytecodes, vector);
break;
/* OP_PROTECT label
... ; code to be protected and whose value is output
@ -723,8 +679,7 @@ disassemble(cl_object *vector) {
first piece of code.
*/
case OP_PROTECT: string = "PROTECT\t";
n = packed_label(vector - 1);
goto OPARG;
goto JMP;
case OP_PROTECT_NORMAL: string = "PROTECT\tNORMAL";
goto NOARG;
case OP_PROTECT_EXIT: string = "PROTECT\tEXIT";
@ -739,11 +694,11 @@ disassemble(cl_object *vector) {
NOARG: print_noarg(string);
break;
ARG: print_noarg(string);
@prin1(1, s);
@prin1(1, o);
break;
OPARG: print_oparg(string, n);
break;
OPARG_ARG: print_oparg_arg(string, n, s);
OPARG_ARG: print_oparg_arg(string, n, o);
break;
}
goto BEGIN;
@ -766,7 +721,7 @@ si_bc_split(cl_object b)
if (type_of(b) != t_bytecodes)
@(return Cnil Cnil)
vector = cl_alloc_simple_vector(b->bytecodes.size, aet_object);
vector->vector.self.t = b->bytecodes.data;
vector = cl_alloc_simple_vector(b->bytecodes.code_size, aet_fix);
vector->vector.self.fix = b->bytecodes.code;
@(return b->bytecodes.lex vector)
}

14
src/c/eval.d
View file

@ -226,17 +226,11 @@ si_unlink_symbol(cl_object s)
cl_object
cl_eval(cl_object form)
{
return eval(form, NULL, Cnil);
return si_eval_with_env(form, Cnil);
}
cl_object
si_eval_with_env(cl_object form, cl_object env)
{
return eval(form, NULL, env);
}
cl_object
cl_safe_eval(cl_object form, cl_object *new_bytecodes, cl_object env, cl_object err_value)
cl_safe_eval(cl_object form, cl_object env, cl_object err_value)
{
cl_object output;
@ -244,7 +238,7 @@ cl_safe_eval(cl_object form, cl_object *new_bytecodes, cl_object env, cl_object
output = err_value;
} else {
bds_bind(@'si::*ignore-errors*', Ct);
output = eval(form, new_bytecodes, env);
output = si_eval_with_env(form, env);
bds_unwind1;
}
frs_pop();
@ -253,7 +247,7 @@ cl_safe_eval(cl_object form, cl_object *new_bytecodes, cl_object env, cl_object
@(defun si::safe-eval (form &optional (err_value @'error') env)
@
return cl_safe_eval(form, NULL, env, err_value);
return cl_safe_eval(form, env, err_value);
@)
@(defun constantp (arg &optional env)

4
src/c/gbc.d
View file

@ -339,10 +339,12 @@ BEGIN:
case t_bytecodes: {
cl_index i, size;
size = x->bytecodes.size;
mark_object(x->bytecodes.name);
mark_object(x->bytecodes.lex);
mark_object(x->bytecodes.specials);
size = x->bytecodes.code_size;
mark_contblock(x->bytecodes.code, size);
size = x->bytecodes.data_size;
mark_contblock(x->bytecodes.data, size * sizeof(cl_object));
for (i=0; i<size; i++)
mark_object(x->bytecodes.data[i]);

374
src/c/interpreter.d
View file

@ -17,7 +17,6 @@
#include "ecl-inl.h"
#include "bytecodes.h"
#define next_code(v) *(v++)
#undef frs_pop
#define frs_pop() { cl_stack_top = cl_stack + frs_top->frs_sp; frs_top--; }
@ -226,23 +225,23 @@ lambda_bind_var(cl_object var, cl_object val, cl_object specials)
bind_special(var, val);
}
static cl_object *
lambda_bind(int narg, cl_object lambda_list, cl_index sp)
static void
lambda_bind(int narg, cl_object lambda, cl_index sp)
{
cl_object *data = lambda_list->bytecodes.data;
cl_object specials = lambda_list->bytecodes.specials;
cl_object *data = lambda->bytecodes.data;
cl_object specials = lambda->bytecodes.specials;
int i, n;
bool check_remaining = TRUE;
/* 1) REQUIRED ARGUMENTS: N var1 ... varN */
n = fix(next_code(data));
n = fix(*(data++));
if (narg < n)
FEwrong_num_arguments(lambda_list->bytecodes.name);
FEwrong_num_arguments(lambda->bytecodes.name);
for (; n; n--, narg--)
lambda_bind_var(next_code(data), cl_stack[sp++], specials);
lambda_bind_var(*(data++), cl_stack[sp++], specials);
/* 2) OPTIONAL ARGUMENTS: N var1 value1 flag1 ... varN valueN flagN */
for (n = fix(next_code(data)); n; n--, data+=3) {
for (n = fix(*(data++)); n; n--, data+=3) {
if (narg) {
lambda_bind_var(data[0], cl_stack[sp], specials);
sp++; narg--;
@ -251,7 +250,7 @@ lambda_bind(int narg, cl_object lambda_list, cl_index sp)
} else {
cl_object defaults = data[1];
if (FIXNUMP(defaults)) {
interpret(&data[1] + fix(defaults));
interpret(lambda, lambda->bytecodes.code + fix(defaults));
defaults = VALUES(0);
}
lambda_bind_var(data[0], defaults, specials);
@ -275,19 +274,21 @@ lambda_bind(int narg, cl_object lambda_list, cl_index sp)
data++;
if (narg && check_remaining)
FEprogram_error("LAMBDA: Too many arguments to function ~S.", 1,
lambda_list->bytecodes.name);
lambda->bytecodes.name);
} else {
/*
* Only when ALLOW-OTHER-KEYS /= 0, we process this:
* 5) KEYWORDS: N key1 var1 value1 flag1 ... keyN varN valueN flagN
*/
bool allow_other_keys = !Null(next_code(data));
bool allow_other_keys = !Null(*(data++));
bool allow_other_keys_found = allow_other_keys;
int n = fix(next_code(data));
int n = fix(*(data++));
cl_object *keys;
cl_object spp[n];
bool other_found = FALSE;
void *unbound = spp; /* not a valid lisp object */
if ((narg & 1) != 0)
FEprogram_error("Function called with odd number of keyword arguments.", 0);
for (i=0; i<n; i++)
spp[i] = unbound;
for (; narg; narg-=2) {
@ -316,14 +317,14 @@ lambda_bind(int narg, cl_object lambda_list, cl_index sp)
}
if (other_found && !allow_other_keys)
FEprogram_error("LAMBDA: Unknown keys found in function ~S.",
1, lambda_list->bytecodes.name);
1, lambda->bytecodes.name);
for (i=0; i<n; i++, data+=4) {
if (spp[i] != unbound)
lambda_bind_var(data[1],spp[i],specials);
else {
cl_object defaults = data[2];
if (FIXNUMP(defaults)) {
interpret(&data[2] + fix(defaults));
interpret(lambda, lambda->bytecodes.code + fix(defaults));
defaults = VALUES(0);
}
lambda_bind_var(data[1],defaults,specials);
@ -332,14 +333,13 @@ lambda_bind(int narg, cl_object lambda_list, cl_index sp)
lambda_bind_var(data[3],(spp[i] != unbound)? Ct : Cnil,specials);
}
}
return data;
}
cl_object
lambda_apply(int narg, cl_object fun)
{
cl_index args = cl_stack_index() - narg;
cl_object name, *body;
cl_object name;
bds_ptr old_bds_top;
struct ihs_frame ihs;
@ -352,20 +352,20 @@ lambda_apply(int narg, cl_object fun)
old_bds_top = bds_top;
/* Establish bindings */
body = lambda_bind(narg, fun, args);
lambda_bind(narg, fun, args);
/* If it is a named lambda, set a block for RETURN-FROM */
VALUES(0) = Cnil;
NValues = 0;
name = fun->bytecodes.name;
if (Null(name))
interpret(body);
interpret(fun, fun->bytecodes.code);
else {
/* Accept (SETF name) */
if (CONSP(name)) name = CADR(name);
CL_BLOCK_BEGIN(id) {
bind_block(name, id);
interpret(body);
interpret(fun, fun->bytecodes.code);
} CL_BLOCK_END;
}
bds_unwind(old_bds_top);
@ -376,21 +376,6 @@ lambda_apply(int narg, cl_object fun)
/* -------------------- AIDS TO THE INTERPRETER -------------------- */
static inline cl_fixnum
get_oparg(cl_object o) {
return GET_OPARG(o);
}
static inline cl_object *
packed_label(cl_object *v) {
return v + GET_OPARG(v[0]);
}
static inline cl_object *
simple_label(cl_object *v) {
return v + fix(v[0]);
}
static cl_object
search_global(register cl_object s) {
cl_object x = SYM_VAL(s);
@ -398,7 +383,7 @@ search_global(register cl_object s) {
FEunbound_variable(s);
return x;
}
/* Similar to funcall(), but registers calls in the IHS stack. */
static cl_object
@ -471,45 +456,46 @@ interpret_funcall(int narg, cl_object fun) {
/* -------------------- THE INTERPRETER -------------------- */
/* OP_DOLIST label
/* OP_DOLIST labelz, labelo
... ; code to bind the local variable
OP_EXIT
... ; code executed on each iteration
OP_EXIT
labelo:
... ; code executed at the end
OP_EXIT
label:
labelz:
High level construct for the DOLIST iterator. The list over which
we iterate is stored in VALUES(0).
*/
static cl_object *
interpret_dolist(cl_object *vector) {
cl_object *volatile exit = packed_label(vector - 1);
static char *
interpret_dolist(cl_object bytecodes, char *vector) {
char *volatile exit;
char *output;
GET_LABEL(exit, vector);
GET_LABEL(output, vector);
/* 1) Set NIL block */
CL_BLOCK_BEGIN(id) {
cl_object *output;
cl_object list;
cl_object list = VALUES(0);
bind_block(Cnil, id);
list = VALUES(0);
exit = packed_label(vector - 1);
/* 2) Build list & bind variable*/
vector = interpret(vector);
output = packed_label(vector-1);
vector = interpret(bytecodes, vector);
/* 3) Repeat until list is exahusted */
while (!endp(list)) {
NValues = 1;
VALUES(0) = CAR(list);
interpret(vector);
interpret(bytecodes, vector);
list = CDR(list);
}
VALUES(0) = Cnil;
NValues = 1;
interpret(output);
interpret(bytecodes, output);
/* 4) Restore environment */
lex_env = frs_top->frs_lex;
@ -518,49 +504,53 @@ interpret_dolist(cl_object *vector) {
return exit;
}
/* OP_TIMES label
/* OP_TIMES labelz, labelo
... ; code to bind the local variable
OP_EXIT
... ; code executed on each iteration
OP_EXIT
labelo:
... ; code executed at the end
OP_EXIT
label:
labelz:
High level construct for the DOTIMES iterator. The number of times
we iterate is stored in VALUES(0).
*/
static cl_object *
interpret_dotimes(cl_object *vector) {
cl_object *volatile exit = packed_label(vector - 1);
static char *
interpret_dotimes(cl_object bytecodes, char *vector) {
char *volatile exit;
char *output;
GET_LABEL(exit, vector);
GET_LABEL(output, vector);
CL_BLOCK_BEGIN(id) {
cl_object *output, length = VALUES(0);
cl_object length = VALUES(0);
/* 1) Set up a nil block */
bind_block(Cnil, id);
/* 2) Retrieve number and bind variables */
exit = packed_label(vector - 1);
vector = interpret(vector);
output = packed_label(vector-1);
vector = interpret(bytecodes, vector);
if (FIXNUMP(length)) {
cl_fixnum i, l = fix(length);
/* 3) Loop while needed */
for (i = 0; i < l;) {
interpret(vector);
interpret(bytecodes, vector);
NValues = 1;
VALUES(0) = MAKE_FIXNUM(++i);
}
} else {
cl_object i = MAKE_FIXNUM(0);
while (number_compare(i, length) < 0) {
interpret(vector);
interpret(bytecodes, vector);
NValues = 1;
VALUES(0) = i = one_plus(i);
}
}
interpret(output);
interpret(bytecodes, output);
/* 4) Restore environment */
lex_env = frs_top->frs_lex;
@ -587,9 +577,9 @@ close_around(cl_object fun, cl_object lex) {
Executes the enclosed code in a lexical enviroment extended with
the functions "fun1" ... "funn".
*/
static cl_object *
interpret_flet(cl_object *vector) {
cl_index nfun = get_oparg(vector[-1]);
static char *
interpret_flet(cl_object bytecodes, char *vector) {
cl_index nfun = GET_OPARG(vector);
/* 1) Copy the environment so that functions get it without references
to themselves. */
@ -597,7 +587,7 @@ interpret_flet(cl_object *vector) {
/* 3) Add new closures to environment */
while (nfun--) {
cl_object fun = next_code(vector);
cl_object fun = GET_DATA(vector, bytecodes);
cl_object f = close_around(fun,lex);
bind_function(f->bytecodes.name, f);
}
@ -614,14 +604,14 @@ interpret_flet(cl_object *vector) {
Executes the enclosed code in a lexical enviroment extended with
the functions "fun1" ... "funn".
*/
static cl_object *
interpret_labels(cl_object *vector) {
cl_index i, nfun = get_oparg(vector[-1]);
static char *
interpret_labels(cl_object bytecodes, char *vector) {
cl_index i, nfun = GET_OPARG(vector);
cl_object l;
/* 1) Build up a new environment with all functions */
for (i=0; i<nfun; i++) {
cl_object f = next_code(vector);
cl_object f = GET_DATA(vector, bytecodes);
bind_function(f->bytecodes.name, f);
}
@ -635,30 +625,32 @@ interpret_labels(cl_object *vector) {
}
/* OP_MSETQ n{arg}
{fixnumn}|{symboln}
{fixnumn}
...
{fixnum1}|{symbol1}
{fixnum1}
Sets N variables to the N values in VALUES(), filling with
NIL when there are values missing. Local variables are denoted
with an integer which points a position in the lexical environment,
while special variables are denoted just with the name.
while special variables are denoted with a negative index X, which
denotes the value -1-X in the table of constants.
*/
static cl_object *
interpret_msetq(cl_object *vector)
static char *
interpret_msetq(cl_object bytecodes, char *vector)
{
cl_object var, value;
int i, n = get_oparg(vector[-1]);
int i, n = GET_OPARG(vector);
for (i=0; i<n; i++) {
var = next_code(vector);
cl_fixnum var = GET_OPARG(vector);
value = (i < NValues) ? VALUES(i) : Cnil;
if (FIXNUMP(var))
setq_local(fix(var), value);
if (var >= 0)
setq_local(var, value);
else {
if (var->symbol.stype == stp_constant)
FEassignment_to_constant(var);
cl_object name = bytecodes->bytecodes.data[-1-var];
if (name->symbol.stype == stp_constant)
FEassignment_to_constant(name);
else
SYM_VAL(var) = value;
SYM_VAL(name) = value;
}
}
if (NValues > 1) NValues = 1;
@ -671,8 +663,8 @@ interpret_msetq(cl_object *vector)
Execute the code enclosed with the special variables in BINDINGS
set to the values in the list which was passed in VALUES(0).
*/
static cl_object *
interpret_progv(cl_object *vector) {
static char *
interpret_progv(cl_object bytecodes, char *vector) {
cl_object values = VALUES(0);
cl_object vars = cl_stack_pop();
@ -690,7 +682,7 @@ interpret_progv(cl_object *vector) {
}
vars = CDR(vars);
}
vector = interpret(vector);
vector = interpret(bytecodes, vector);
/* 3) Restore environment */
lex_env = old_lex_env;
@ -698,25 +690,16 @@ interpret_progv(cl_object *vector) {
return vector;
}
cl_object *
interpret(cl_object *vector) {
cl_type t;
cl_object s;
char *
interpret(cl_object bytecodes, char *vector) {
BEGIN:
s = next_code(vector);
t = type_of(s);
if (t != t_fixnum) {
VALUES(0) = s;
NValues = 1;
goto BEGIN;
}
switch (GET_OP(s)) {
switch (GET_OPCODE(vector)) {
/* OP_QUOTE
Sets VALUES(0) to an immediate value.
*/
case OP_QUOTE:
VALUES(0) = next_code(vector);
VALUES(0) = GET_DATA(vector, bytecodes);
NValues = 1;
break;
@ -725,7 +708,7 @@ interpret(cl_object *vector) {
VAR is the name of the variable for readability purposes.
*/
case OP_VAR: {
int lex_env_index = get_oparg(s);
int lex_env_index = GET_OPARG(vector);
VALUES(0) = search_local(lex_env_index);
NValues = 1;
break;
@ -736,7 +719,7 @@ interpret(cl_object *vector) {
VAR should be either a special variable or a constant.
*/
case OP_VARS: {
cl_object var_name = next_code(vector);
cl_object var_name = GET_DATA(vector, bytecodes);
VALUES(0) = search_global(var_name);
NValues = 1;
break;
@ -753,7 +736,7 @@ interpret(cl_object *vector) {
Pushes the value of the n-th local onto the stack.
*/
case OP_PUSHV: {
int lex_env_index = get_oparg(s);
int lex_env_index = GET_OPARG(vector);
cl_stack_push(search_local(lex_env_index));
break;
}
@ -763,7 +746,7 @@ interpret(cl_object *vector) {
VAR should be either a special variable or a constant.
*/
case OP_PUSHVS: {
cl_object var_name = next_code(vector);
cl_object var_name = GET_DATA(vector, bytecodes);
cl_stack_push(search_global(var_name));
break;
}
@ -772,30 +755,16 @@ interpret(cl_object *vector) {
Pushes "value" onto the stack.
*/
case OP_PUSHQ:
cl_stack_push(next_code(vector));
cl_stack_push(GET_DATA(vector, bytecodes));
break;
/* OP_CALLG n{arg}, function-name{symbol}
Calls the global function with N arguments which have
been deposited in the stack. The output values are
left in VALUES(...)
*/
case OP_CALLG: {
cl_fixnum n = get_oparg(s);
cl_object fun = next_code(vector);
if (fun->symbol.gfdef == OBJNULL || fun->symbol.mflag)
FEundefined_function(fun);
VALUES(0) = interpret_funcall(n, fun->symbol.gfdef);
break;
}
/* OP_CALL n{arg}
Calls the function in VALUES(0) with N arguments which
have been deposited in the stack. The output values
are left in VALUES(...)
*/
case OP_CALL: {
cl_fixnum n = get_oparg(s);
cl_fixnum n = GET_OPARG(vector);
cl_object fun = VALUES(0);
VALUES(0) = interpret_funcall(n, fun);
break;
@ -807,7 +776,7 @@ interpret(cl_object *vector) {
are left in VALUES(...)
*/
case OP_FCALL: {
cl_fixnum n = get_oparg(s);
cl_fixnum n = GET_OPARG(vector);
cl_object fun = cl_stack_top[-n-1];
VALUES(0) = interpret_funcall(n, fun);
cl_stack_pop();
@ -826,28 +795,13 @@ interpret(cl_object *vector) {
break;
}
/* OP_PCALLG n{arg}, function-name{symbol}
Calls the global function with N arguments which have
been deposited in the stack. The first output value is
left on the stack.
*/
case OP_PCALLG: {
cl_fixnum n = get_oparg(s);
cl_object fun = next_code(vector);
if (fun->symbol.gfdef == OBJNULL)
FEundefined_function(fun);
VALUES(0) = interpret_funcall(n, fun->symbol.gfdef);
cl_stack_push(VALUES(0));
break;
}
/* OP_PCALL n{arg}
Calls the function in VALUES(0) with N arguments which
have been deposited in the stack. The first output value
is pushed on the stack.
*/
case OP_PCALL: {
cl_fixnum n = get_oparg(s);
cl_fixnum n = GET_OPARG(vector);
cl_object fun = VALUES(0);
VALUES(0) = interpret_funcall(n, fun);
cl_stack_push(VALUES(0));
@ -860,7 +814,7 @@ interpret(cl_object *vector) {
is pushed on the stack.
*/
case OP_PFCALL: {
cl_fixnum n = get_oparg(s);
cl_fixnum n = GET_OPARG(vector);
cl_object fun = cl_stack_top[-n-1];
VALUES(0) = interpret_funcall(n, fun);
cl_stack_top[-1] = VALUES(0);
@ -879,10 +833,10 @@ interpret(cl_object *vector) {
case OP_HALT:
return vector-1;
case OP_FLET:
vector = interpret_flet(vector);
vector = interpret_flet(bytecodes, vector);
break;
case OP_LABELS:
vector = interpret_labels(vector);
vector = interpret_labels(bytecodes, vector);
break;
/* OP_LFUNCTION n{arg}, function-name{symbol}
@ -890,7 +844,7 @@ interpret(cl_object *vector) {
which have been deposited in the stack.
*/
case OP_LFUNCTION: {
int lex_env_index = get_oparg(s);
int lex_env_index = GET_OPARG(vector);
cl_object fun_record = search_local(lex_env_index);
cl_object fun_object = CDR(fun_record);
VALUES(0) = fun_object;
@ -904,7 +858,7 @@ interpret(cl_object *vector) {
environment. This last value takes precedence.
*/
case OP_FUNCTION:
VALUES(0) = ecl_fdefinition(next_code(vector));
VALUES(0) = ecl_fdefinition(GET_DATA(vector, bytecodes));
NValues = 1;
break;
@ -914,19 +868,20 @@ interpret(cl_object *vector) {
environment. This last value takes precedence.
*/
case OP_CLOSE: {
cl_object function_object = next_code(vector);
cl_object function_object = GET_DATA(vector, bytecodes);
VALUES(0) = close_around(function_object, lex_env);
NValues = 1;
break;
}
/* OP_GO n{arg}, tag-name{symbol}
/* OP_GO n{arg}
OP_QUOTE tag-name{symbol}
Jumps to the tag which is defined at the n-th position in
the lexical environment. TAG-NAME is kept for debugging
purposes.
*/
case OP_GO: {
cl_object tag_name = next_code(vector);
cl_object id = search_local(get_oparg(s));
cl_object id = search_local(GET_OPARG(vector));
cl_object tag_name = GET_DATA(vector, bytecodes);
VALUES(0) = Cnil;
NValues = 0;
cl_go(id, tag_name);
@ -937,7 +892,7 @@ interpret(cl_object *vector) {
occuppies the n-th position.
*/
case OP_RETURN: {
int lex_env_index = get_oparg(s);
int lex_env_index = GET_OPARG(vector);
cl_object block_record = search_local(lex_env_index);
cl_object block_name = CAR(block_record);
cl_object id = CDR(block_record);
@ -957,30 +912,44 @@ interpret(cl_object *vector) {
/* OP_JMP label{arg}
OP_JNIL label{arg}
OP_JT label{arg}
OP_JEQ label{arg}, value{object}
OP_JNEQ label{arg}, value{object}
OP_JEQ value{object}, label{arg}
OP_JNEQ value{object}, label{arg}
Direct or conditional jumps. The conditional jumps are made
comparing with the value of VALUES(0).
*/
case OP_JMP:
vector = vector - 1 + get_oparg(s);
case OP_JMP: {
cl_oparg jump = GET_OPARG(vector);
vector += jump - OPARG_SIZE;
break;
case OP_JNIL:
}
case OP_JNIL: {
cl_oparg jump = GET_OPARG(vector);
NValues = 1;
if (Null(VALUES(0))) vector = vector - 1 + get_oparg(s);
if (Null(VALUES(0)))
vector += jump - OPARG_SIZE;
break;
case OP_JT:
}
case OP_JT: {
cl_oparg jump = GET_OPARG(vector);
NValues = 1;
if (!Null(VALUES(0))) vector = vector - 1 + get_oparg(s);
if (!Null(VALUES(0)))
vector += jump - OPARG_SIZE;
break;
case OP_JEQL:
if (eql(VALUES(0), next_code(vector)))
vector = vector + get_oparg(s) - 2;
}
case OP_JEQL: {
cl_oparg value = GET_OPARG(vector);
cl_oparg jump = GET_OPARG(vector);
if (eql(VALUES(0), bytecodes->bytecodes.data[value]))
vector += jump - OPARG_SIZE;
break;
case OP_JNEQL:
if (!eql(VALUES(0), next_code(vector)))
vector = vector + get_oparg(s) - 2;
}
case OP_JNEQL: {
cl_oparg value = GET_OPARG(vector);
cl_oparg jump = GET_OPARG(vector);
if (!eql(VALUES(0), bytecodes->bytecodes.data[value]))
vector += jump - OPARG_SIZE;
break;
}
case OP_NOT:
VALUES(0) = (VALUES(0) == Cnil)? Ct : Cnil;
NValues = 1;
@ -989,7 +958,7 @@ interpret(cl_object *vector) {
Undo "n" local bindings.
*/
case OP_UNBIND: {
cl_index n = get_oparg(s);
cl_index n = GET_OPARG(vector);
while (n--)
lex_env = CDDR(lex_env);
break;
@ -998,7 +967,7 @@ interpret(cl_object *vector) {
Undo "n" bindings of special variables.
*/
case OP_UNBINDS: {
cl_index n = get_oparg(s);
cl_index n = GET_OPARG(vector);
bds_unwind_n(n);
break;
}
@ -1010,39 +979,39 @@ interpret(cl_object *vector) {
value of VALUES(0) or the first value of the stack.
*/
case OP_BIND: {
cl_object var_name = next_code(vector);
cl_object var_name = GET_DATA(vector, bytecodes);
cl_object value = VALUES(0);
bind_var(var_name, value);
break;
}
case OP_PBIND: {
cl_object var_name = next_code(vector);
cl_object var_name = GET_DATA(vector, bytecodes);
cl_object value = cl_stack_pop();
bind_var(var_name, value);
break;
}
case OP_VBIND: {
int n = get_oparg(s);
cl_object var_name = next_code(vector);
int n = GET_OPARG(vector);
cl_object var_name = GET_DATA(vector, bytecodes);
cl_object value = (n < NValues) ? VALUES(n) : Cnil;
bind_var(var_name, value);
break;
}
case OP_BINDS: {
cl_object var_name = next_code(vector);
cl_object var_name = GET_DATA(vector, bytecodes);
cl_object value = VALUES(0);
bind_special(var_name, value);
break;
}
case OP_PBINDS: {
cl_object var_name = next_code(vector);
cl_object var_name = GET_DATA(vector, bytecodes);
cl_object value = cl_stack_pop();
bind_special(var_name, value);
break;
}
case OP_VBINDS: {
int n = get_oparg(s);
cl_object var_name = next_code(vector);
int n = GET_OPARG(vector);
cl_object var_name = GET_DATA(vector, bytecodes);
cl_object value = (n < NValues) ? VALUES(n) : Cnil;
bind_special(var_name, value);
break;
@ -1056,13 +1025,13 @@ interpret(cl_object *vector) {
first value on the stack (OP_PSETQ[S]).
*/
case OP_SETQ: {
int lex_env_index = get_oparg(s);
int lex_env_index = GET_OPARG(vector);
setq_local(lex_env_index, VALUES(0));
NValues = 1;
break;
}
case OP_SETQS: {
cl_object var = next_code(vector);
cl_object var = GET_DATA(vector, bytecodes);
if (var->symbol.stype == stp_constant)
FEassignment_to_constant(var);
else
@ -1071,14 +1040,14 @@ interpret(cl_object *vector) {
break;
}
case OP_PSETQ: {
int lex_env_index = get_oparg(s);
int lex_env_index = GET_OPARG(vector);
setq_local(lex_env_index, cl_stack_pop());
Values[0] = Cnil;
NValues = 1;
break;
}
case OP_PSETQS: {
cl_object var = next_code(vector);
cl_object var = GET_DATA(vector, bytecodes);
if (var->symbol.stype == stp_constant)
FEassignment_to_constant(var);
else
@ -1088,7 +1057,7 @@ interpret(cl_object *vector) {
break;
}
/* OP_BLOCK label{arg}, block-name{symbol}
/* OP_BLOCK label{arg}
...
OP_EXIT
label:
@ -1097,14 +1066,19 @@ interpret(cl_object *vector) {
LABEL points to the first instruction after OP_EXIT.
*/
case OP_BLOCK: {
cl_object name;
cl_object id = new_frame_id();
cl_stack_push(packed_label(vector - 1));
char *exit;
/* FIXME! */
GET_LABEL(exit, vector);
cl_stack_push((cl_object)exit);
name = GET_DATA(vector, bytecodes);
if (frs_push(FRS_CATCH, id) == 0) {
bind_block(next_code(vector), id);
bind_block(name, id);
} else {
lex_env = frs_top->frs_lex;
frs_pop();
vector = cl_stack_pop();
vector = (char *)cl_stack_pop();
}
break;
}
@ -1116,14 +1090,18 @@ interpret(cl_object *vector) {
High level construct for the DO and BLOCK forms.
*/
case OP_DO: {
cl_object name = Cnil;
cl_object id = new_frame_id();
cl_stack_push(packed_label(vector - 1));
char *exit;
/* FIXME! */
GET_LABEL(exit, vector);
cl_stack_push((cl_object)exit);
if (frs_push(FRS_CATCH, id) == 0) {
bind_block(Cnil, id);
bind_block(name, id);
} else {
lex_env = frs_top->frs_lex;
frs_pop();
vector = cl_stack_pop();
vector = (char *)cl_stack_pop(); /* FIXME! */
}
break;
}
@ -1135,14 +1113,17 @@ interpret(cl_object *vector) {
Sets a catch point using the tag in VALUES(0). LABEL points to the
first instruction after the end (OP_EXIT) of the block
*/
case OP_CATCH:
cl_stack_push(packed_label(vector - 1));
case OP_CATCH: {
char *exit;
GET_LABEL(exit, vector);
cl_stack_push((cl_object)exit);
if (frs_push(FRS_CATCH, VALUES(0)) != 0) {
lex_env = frs_top->frs_lex;
frs_pop();
vector = cl_stack_pop();
vector = (char *)cl_stack_pop(); /* FIXME! */
}
break;
}
/* OP_TAGBODY n{arg}
label1
...
@ -1156,20 +1137,22 @@ interpret(cl_object *vector) {
High level construct for the TAGBODY form.
*/
case OP_TAGBODY: {
int n = GET_OPARG(vector);
/* Here we save the location of the jump table */
cl_stack_push(vector);
cl_stack_push((cl_object)vector); /* FIXME! */
if (frs_push(FRS_CATCH, bind_tagbody()) == 0) {
/* The first time, we "name" the tagbody and
* skip the jump table */
vector += get_oparg(s);
vector += n * OPARG_SIZE;
} else {
/* Wait here for gotos. Each goto sets
VALUES(0) to an integer which ranges from 0
to ntags-1, depending on the tag. These
numbers are indices into the jump table and
are computed at compile time. */
cl_object *table = (cl_object*)cl_stack_top[-1];
vector = simple_label(table + fix(VALUES(0)));
char *table = (char *)cl_stack_top[-1];
table = table + fix(VALUES(0)) * OPARG_SIZE;
vector = table + *(cl_oparg *)table;
lex_env = frs_top->frs_lex;
}
break;
@ -1196,16 +1179,16 @@ interpret(cl_object *vector) {
cl_stack_pop();
break;
case OP_DOLIST:
vector = interpret_dolist(vector);
vector = interpret_dolist(bytecodes, vector);
break;
case OP_DOTIMES:
vector = interpret_dotimes(vector);
vector = interpret_dotimes(bytecodes, vector);
break;
case OP_MSETQ:
vector = interpret_msetq(vector);
vector = interpret_msetq(bytecodes, vector);
break;
case OP_PROGV:
vector = interpret_progv(vector);
vector = interpret_progv(bytecodes, vector);
break;
/* OP_PUSHVALUES
Pushes the values output by the last form, plus the number
@ -1249,7 +1232,7 @@ interpret(cl_object *vector) {
Pop N values from the stack and store them in VALUES(...)
*/
case OP_VALUES: {
cl_fixnum n = get_oparg(s);
cl_fixnum n = GET_OPARG(vector);
NValues = n;
while (n)
VALUES(--n) = cl_stack_pop();
@ -1281,16 +1264,19 @@ interpret(cl_object *vector) {
is always executed, even if a THROW, RETURN or GO happen within the
first piece of code.
*/
case OP_PROTECT:
cl_stack_push(packed_label(vector - 1));
case OP_PROTECT: {
char *exit;
GET_LABEL(exit, vector);
cl_stack_push((cl_object)exit);
if (frs_push(FRS_PROTECT,Cnil) != 0) {
lex_env = frs_top->frs_lex;
frs_pop();
vector = cl_stack_pop();
vector = (char *)cl_stack_pop();
cl_stack_push(MAKE_FIXNUM(nlj_fr - frs_top));
goto PUSH_VALUES;
}
break;
}
case OP_PROTECT_NORMAL:
bds_unwind(frs_top->frs_bds_top);
lex_env = frs_top->frs_lex;

3
src/c/load.d
View file

@ -94,11 +94,10 @@ si_load_source(cl_object source, cl_object verbose, cl_object print)
}
CL_UNWIND_PROTECT_BEGIN {
for (;;) {
cl_object bytecodes = Cnil;
x = cl_read(3, strm, Cnil, OBJNULL);
if (x == OBJNULL)
break;
eval(x, &bytecodes, Cnil);
si_eval_with_env(x, Cnil);
if (print != Cnil) {
@write(1, x);
@terpri(0);

46
src/c/macros.d
View file

@ -127,8 +127,54 @@ macro_expand(cl_object form, cl_object env)
return new_form;
}
static cl_object
or_macro(cl_object whole, cl_object env)
{
cl_object output = Cnil;
whole = CDR(whole);
if (Null(whole)) /* (OR) => NIL */
@(return Cnil);
while (!Null(CDR(whole))) {
output = CONS(CONS(CAR(whole), Cnil), output);
whole = CDR(whole);
}
if (Null(output)) /* (OR form1) => form1 */
@(return CAR(whole));
/* (OR form1 ... formn forml) => (COND (form1) ... (formn) (t forml)) */
output = CONS(cl_list(2, Ct, CAR(whole)), output);
@(return CONS(@'cond', cl_nreverse(output)))
}
static cl_object
expand_and(cl_object whole)
{
if (Null(whole))
return Ct;
if (Null(CDR(whole)))
return CAR(whole);
return cl_list(3, @'if', CAR(whole), expand_and(CDR(whole)));
}
static cl_object
and_macro(cl_object whole, cl_object env)
{
@(return expand_and(CDR(whole)))
}
static cl_object
when_macro(cl_object whole, cl_object env)
{
cl_object args = CDR(whole);
if (endp(args))
FEprogram_error("Syntax error: ~S.", 1, whole);
return cl_list(3, @'if', CAR(args), CONS(@'progn', CDR(args)));
}
void
init_macros(void)
{
SYM_VAL(@'*macroexpand-hook*') = @'funcall';
cl_def_c_macro(@'or', or_macro);
cl_def_c_macro(@'and', and_macro);
cl_def_c_macro(@'when', when_macro);
}

4
src/c/read.d
View file

@ -861,7 +861,7 @@ sharp_dot_reader(cl_object in, cl_object c, cl_object d)
in = read_object(in);
if (read_suppress)
@(return Cnil)
in = eval(in, NULL, Cnil);
in = si_eval_with_env(in, Cnil);
@(return in)
}
@ -1855,7 +1855,7 @@ read_VV(cl_object block, void *entry)
*/
(*entry_point)(block);
len = block->cblock.data_size;
#ifdef GBC_BOEHM
#ifdef ECL_DYNAMIC_VV
VV = block->cblock.data = len? (cl_object *)cl_alloc(len * sizeof(cl_object)) : NULL;
#else
VV = block->cblock.data;

2
src/c/tclBasic.d
View file

@ -62,7 +62,7 @@ eval_from_string(char *s)
cl_object x;
STRING_INPUT_STREAM(s, strm);
x = @read(3, (cl_object)&strm, Cnil, OBJNULL);
return (x != OBJNULL) ? eval(x, NULL, Cnil) : Cnil;
return (x != OBJNULL) ? si_eval_with_env(x, Cnil) : Cnil;
}
static cl_object string_stream;

2
src/cmp/cmplam.lsp
View file

@ -644,8 +644,6 @@
(cmperr "Defmacro-lambda-list contains illegal use of ~s." key))
(defun c2dm (name whole env vl body)
(when (or *safe-compile* *compiler-check-args*)
(wt-nl "check_arg(2);"))
(let ((lcl (next-lcl)))
(when whole
(check-vref whole)

15
src/cmp/cmptop.lsp
View file

@ -117,14 +117,16 @@
(wt-nl "cl_object value0;")
(wt-nl "if (!FIXNUMP(flag)){")
(wt-nl "Cblock=flag;")
#-boehm-gc
(wt-nl "#ifndef ECL_DYNAMIC_VV")
(wt-nl "flag->cblock.data = VV;")
(wt-nl "#endif")
(wt-nl "flag->cblock.data_size = VM;")
(wt-nl "flag->cblock.data_text = compiler_data_text;")
(wt-nl "flag->cblock.data_text_size = compiler_data_text_size;")
(wt-nl "return;}")
#+boehm-gc
(wt-nl "#ifdef ECL_DYNAMIC_VV")
(wt-nl "VV = Cblock->cblock.data;")
(wt-nl "#endif")
;; useless in initialization.
(dolist (form *top-level-forms*)
(let ((*compile-to-linking-call* nil)
@ -143,12 +145,13 @@
(incf *next-vv*)
(wt-h "#define VM" vv-reservation " " *next-vv*)
(wt-h "#define VM " *next-vv*)
#+boehm-gc
(wt-h "#ifdef ECL_DYNAMIC_VV")
(wt-h "static cl_object *VV;")
#-boehm-gc
(wt-h "#else")
(if (zerop *next-vv*)
(wt-h "static cl_object VV[1];")
(wt-h "static cl_object VV[VM];"))
(wt-h "#endif")
(when *linking-calls*
(dotimes (i (length *linking-calls*))
(declare (fixnum i))
@ -575,7 +578,7 @@
(wt-nl "si_put_sysprop(" vv "," (add-symbol 'si::pretty-print-format) "," ppn ");")
(wt-nl)))
(wt-h "static cl_object L" cfun "();")
(wt-nl "cl_def_c_macro_va(" vv ",(cl_objectfn)L" cfun ");"))
(wt-nl "cl_def_c_macro(" vv ",L" cfun ");"))
(defun t3defmacro (fname cfun macro-lambda ppn sp
&aux (*lcl* 0) (*temp* 0) (*max-temp* 0)
@ -587,7 +590,7 @@
(*destination* 'RETURN)
(*reservation-cmacro* (next-cmacro)))
(wt-comment "macro definition for " fname)
(wt-nl1 "static cl_object L" cfun "(int narg, cl_object V1, cl_object V2)")
(wt-nl1 "static cl_object L" cfun "(cl_object V1, cl_object V2)")
(wt-nl1 "{")
(wt-function-prolog sp)
(c2dm fname (car macro-lambda) (second macro-lambda) (third macro-lambda)

14
src/doc/help.lsp
View file

@ -335,6 +335,11 @@ Returns T if CHAR is alphabetic; NIL otherwise.")
(docfun alphanumericp function (char) "
Returns T if CHAR is either numeric or alphabetic; NIL otherwise.")
(docfun and macro "(and {form}*)" "
Evaluates FORMs in order. If any FORM evaluates to NIL, returns
immediately with the value NIL. Otherwise, returns all values of the
last FORM.")
(docfun append function (&rest lists) "
Constructs and returns a new list by concatenating the args.")
@ -2314,6 +2319,11 @@ while PORT is an integer identifies the port number to which to connect.
This function returns a two-way stream which can be used in any of the
stream operations.")
(docfun or macro "(or {form}*)" "
Evaluates FORMs in order from left to right. If any FORM evaluates to non-
NIL, quits and returns that (single) value. If the last FORM is reached,
returns whatever values it returns.")
(docfun output-stream-p function (stream) "
Returns T if STREAM can handle output operations; NIL otherwise.")
@ -3286,6 +3296,10 @@ being the N-th value.")
(docfun vectorp function (x) "
Returns T if X is a vector; NIL otherwise.")
(docfun when macro "(when test {form}*)" "
If TEST evaluates to non-NIL, then evaluates FORMs and returns all values of
the last FORM. If not, simply returns NIL.")
(docfun write function (object &key (stream *standard-output*) (escape *print-escape*)
(radix *print-radix*) (base *print-base*)
(circle *print-circle*) (pretty *print-pretty*)

25
src/h/bytecodes.h
View file

@ -184,8 +184,23 @@ enum {
OP_OPCODE_SHIFT = 7
};
#define OPARG_SHIFT 16
#define MAX_OPARG (1 << (31 - OPARG_SHIFT) - 1)
#define SET_OPARG(o,n) ((cl_object)((cl_fixnum)(o) | ((n) << OPARG_SHIFT)))
#define GET_OPARG(o) ((cl_fixnum)(o) >> OPARG_SHIFT)
#define GET_OP(o) (((cl_fixnum)(o) & 0xFF) >> 2)
/*
If we we working with character pointers,
typedef char cl_opcode;
...
#define OPCODE_SIZE sizeof(cl_opcode)
#define OPARG_SIZE sizeof(cl_oparg)
but since we are not...
*/
#define MAX_OPARG 0x7FFF
typedef char cl_opcode;
typedef int16_t cl_oparg;
#define OPCODE_SIZE 1
#define OPARG_SIZE sizeof(cl_oparg)
#define READ_OPCODE(v) (*(cl_opcode *)(v))
#define READ_OPARG(v) (*(cl_oparg *)(v))
#define GET_OPCODE(v) (*((cl_opcode *)(v))++)
#define GET_OPARG(v) (*((cl_oparg *)(v))++)
#define GET_DATA(v,b) (b->bytecodes.data[*((cl_oparg *)(v))++])
#define GET_LABEL(pc,v) {pc = (v) + *(cl_oparg *)v; v += OPARG_SIZE;}

9
src/h/external.h
View file

@ -152,7 +152,7 @@ extern cl_object cl_make_cfun(cl_object (*self)(), cl_object name, cl_object blo
extern cl_object cl_make_cfun_va(cl_object (*self)(int narg,...), cl_object name, cl_object block);
extern cl_object cl_make_cclosure_va(cl_object (*self)(int narg,...), cl_object env, cl_object block);
extern void cl_def_c_function(cl_object sym, cl_object (*self)(), int narg);
extern void cl_def_c_macro_va(cl_object sym, cl_object (*self)(int narg,...));
extern void cl_def_c_macro(cl_object sym, cl_object (*self)(cl_object, cl_object));
extern void cl_def_c_function_va(cl_object sym, cl_object (*self)(int narg,...));
@ -237,7 +237,7 @@ extern cl_object si_valid_function_name_p(cl_object name);
extern cl_object si_process_declarations _ARGS((int narg, cl_object body, ...));
extern cl_object make_lambda(cl_object name, cl_object lambda);
extern cl_object eval(cl_object form, cl_object *bytecodes, cl_object env);
extern cl_object si_eval_with_env(cl_object form, cl_object env);
/* interpreter.c */
@ -257,7 +257,7 @@ extern void cl_stack_pop_values(int n);
extern cl_object lex_env;
extern cl_object lambda_apply(int narg, cl_object fun);
extern cl_object *interpret(cl_object *memory);
extern char *interpret(cl_object bytecodes, char *pc);
/* disassembler.c */
@ -308,13 +308,12 @@ extern cl_object cl_va_arg(cl_va_list args);
extern cl_object si_unlink_symbol(cl_object s);
extern cl_object cl_eval(cl_object form);
extern cl_object si_eval_with_env(cl_object form, cl_object env);
extern cl_object cl_constantp(int narg, cl_object arg, ...);
#define funcall cl_funcall
extern cl_object cl_apply_from_stack(cl_index narg, cl_object fun);
extern cl_object link_call(cl_object sym, cl_objectfn *pLK, int narg, cl_va_list args);
extern cl_object cl_safe_eval(cl_object form, cl_object *bytecodes, cl_object env, cl_object err_value);
extern cl_object cl_safe_eval(cl_object form, cl_object env, cl_object err_value);
/* ffi.c */

4
src/h/internal.h
View file

@ -76,6 +76,10 @@ extern const struct {
short type;
} all_functions[];
/* alloc.d/alloc_2.d */
extern cl_object ecl_alloc_bytecodes(cl_index data_size, cl_index code_size);
/* file.d */
/*

6
src/h/object.h
View file

@ -360,9 +360,11 @@ struct bytecodes {
cl_object name; /* function name */
cl_object lex; /* lexical environment */
cl_object specials; /* list of special variables */
cl_index size; /* number of bytecodes */
cl_object *data; /* the intermediate language */
cl_object definition; /* function definition in list form */
cl_index code_size; /* number of bytecodes */
cl_index data_size; /* number of constants */
char *code; /* the intermediate language */
cl_object *data; /* non-inmediate constants used in the code */
};
struct cfun { /* compiled function header */

38
src/lsp/evalmacros.lsp
View file

@ -120,38 +120,6 @@ as a VARIABLE doc and can be retrieved by (documentation 'NAME 'variable)."
;;; dolist), some not at all (e.g. defun).
;;; Thus their names need not be exported.
(defmacro and (&rest forms)
"Syntax: (and {form}*)
Evaluates FORMs in order. If any FORM evaluates to NIL, returns
immediately with the value NIL. Otherwise, returns all values of the
last FORM."
(if (endp forms)
T
(do* ((res '(NIL))
(insert res (cddar (rplaca insert `(IF ,(car fs) NIL))))
(fs forms (cdr fs)))
((endp (cdr fs))
(rplaca insert (car fs))
(car res))))
)
(defmacro or (&rest forms)
"Syntax: (or {form}*)
Evaluates FORMs in order from left to right. If any FORM evaluates to non-
NIL, quits and returns that (single) value. If the last FORM is reached,
returns whatever values it returns."
(if (endp forms)
nil
(let ((x (reverse forms)))
(do ((forms (cdr x) (cdr forms))
(form (car x)
(let ((temp (gensym)))
`(LET ((,temp ,(car forms)))
; (DECLARE (:READ-ONLY ,temp)) ; Beppe
(IF ,temp ,temp ,form)))))
((endp forms) form))))
)
(defmacro loop (&rest body &aux (tag (gensym)))
"Syntax: (loop {form}*)
Establishes a NIL block and executes FORMs repeatedly. The loop is normally
@ -208,12 +176,6 @@ TESTs evaluates to non-NIL."
`(IF ,(car l) (PROGN ,@(cdr l)) ,form))))))
)
(defmacro when (pred &rest body)
"Syntax: (when test {form}*)
If TEST evaluates to non-NIL, then evaluates FORMs and returns all values of
the last FORM. If not, simply returns NIL."
`(IF ,pred (PROGN ,@body)))
(defmacro unless (pred &rest body)
"Syntax: (unless test {form}*)
If TEST evaluates to NIL, then evaluates FORMs and returns all values of the