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

The interpreter, the printer and the compiler now share a common stack.

Browse source 
This stack is also used to build the Invocation History records, which keep
track of which functions are called and which are their local environments.
With these changes, the debugger now works to the extend that it inspecting
these Invocation History Records with :backtrace, :up, :down, :variables,
now output the rights values.
This commit is contained in:
jjgarcia 2001-09-05 18:09:20 +00:00
parent 528810f1f0
commit 9c09789e75
22 changed files with 865 additions and 843 deletions
Download patch file Download diff file Expand all files Collapse all files

2
src/c/all_functions.d
View file

@ -712,6 +712,8 @@ const struct function_info all_functions[] = {
{"IHS-TOP", siLihs_top, si},
{"IHS-FUN", siLihs_fun, si},
{"IHS-ENV", siLihs_env, si},
{"IHS-NEXT", siLihs_next, si},
{"IHS-PREV", siLihs_prev, si},
{"FRS-TOP", siLfrs_top, si},
{"FRS-BDS", siLfrs_bds, si},
{"FRS-CLASS", siLfrs_class, si},

436
src/c/compiler.d
View file

@ -33,25 +33,41 @@ cl_object @'&aux';
cl_object @':allow-other-keys';
cl_object bytecodes;
int lexical_level;
typedef struct {
cl_object variables;
cl_object macros;
cl_fixnum lexical_level;
#ifdef CL_COMP_OWN_STACK
cl_object bytecodes;
#endif
} cl_compiler_env;
static cl_compiler_env c_env;
/********************* PRIVATE ********************/
static cl_index asm_begin(void);
static cl_object asm_end(cl_index);
static void asm_clear(cl_index);
static void asm_grow(void);
static void asm1(register cl_object op);
static void asm_op(register int n);
static void asm_list(register cl_object l);
static void asmn(int narg, ...);
static void asm_at(register cl_index where, register cl_object what);
static cl_index asm_jmp(register int op);
static void asm_complete(register int op, register cl_index original);
#ifdef CL_COMP_OWN_STACK
static cl_index current_pc();
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);
#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
#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 cl_index asm_jmp(register int op);
static void asm_complete(register int op, register cl_index original);
static void c_and(cl_object args);
static void c_block(cl_object args);
@ -123,6 +139,17 @@ pop_maybe_nil(cl_object *l) {
/* ------------------------------ ASSEMBLER ------------------------------ */
#ifdef CL_COMP_OWN_STACK
static cl_object
alloc_bytecodes()
{
cl_object vector = alloc_simple_vector(128, aet_object);
array_allocself(vector);
vector->vector.hasfillp = TRUE;
vector->vector.fillp = 0;
return vector;
}
static cl_index
asm_begin(void) {
/* Save beginning of bytecodes for this session */
@ -133,51 +160,82 @@ static void
asm_clear(cl_index beginning) {
cl_index i;
/* Remove data from this session */
bytecodes->vector.fillp = beginning;
c_env.bytecodes->vector.fillp = beginning;
}
static void
asm_grow(void) {
cl_object *old_data = c_env.bytecodes->vector.self.t;
cl_index old_size = c_env.bytecodes->vector.fillp;
c_env.bytecodes->vector.dim += 128;
array_allocself(c_env.bytecodes);
memcpy(c_env.bytecodes->vector.self.t, old_data, old_size*sizeof(cl_object));
}
static void
asm1(register cl_object 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.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;
}
static void
set_pc(cl_index pc) {
c_env.bytecodes->vector.fillp = pc;
}
static cl_object
asm_end(cl_index beginning) {
asm_ref(register cl_index n) {
return c_env.bytecodes->vector.self.t[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, i;
/* Save bytecodes from this session in a new vector */
length = current_pc() - beginning;
bytes = length * sizeof(cl_object);
new_bytecodes = alloc_object(t_bytecodes);
if (!Null(bytecodes))
new_bytecodes = bytecodes;
else {
new_bytecodes = alloc_object(t_bytecodes);
new_bytecodes->bytecodes.size = 0;
}
new_bytecodes->bytecodes.lex = Cnil;
new_bytecodes->bytecodes.data = alloc(bytes);
new_bytecodes->bytecodes.size = length;
if (new_bytecodes->bytecodes.size < length) {
new_bytecodes->bytecodes.data = alloc(bytes);
new_bytecodes->bytecodes.size = length;
}
#ifdef CL_COMP_OWN_STACK
memcpy(new_bytecodes->bytecodes.data,
&bytecodes->vector.self.t[beginning],
&c_env.bytecodes->vector.self.t[beginning],
bytes);
#else
memcpy(new_bytecodes->bytecodes.data,
&cl_stack[beginning],
bytes);
#endif
asm_clear(beginning);
return new_bytecodes;
}
static void
asm_grow(void) {
cl_object *old_data = bytecodes->vector.self.t;
cl_index old_size = bytecodes->vector.fillp;
bytecodes->vector.dim += 128;
array_allocself(bytecodes);
memcpy(bytecodes->vector.self.t, old_data, old_size*sizeof(cl_object));
}
static void
asm1(register cl_object op) {
int where = bytecodes->vector.fillp;
if (where >= bytecodes->vector.dim)
asm_grow();
bytecodes->vector.self.t[where] = op;
bytecodes->vector.fillp++;
}
static void
asm_op(register int n) {
asm1(MAKE_FIXNUM(n));
}
static void
asm_op2(register int code, register cl_fixnum n) {
@ -189,34 +247,6 @@ asm_op2(register int code, register cl_fixnum n) {
asm1(new_op);
}
static inline cl_object
make_op(int code) {
return MAKE_FIXNUM(code);
}
static cl_object
make_op2(int code, cl_fixnum n) {
cl_object volatile op = MAKE_FIXNUM(code);
cl_object new_op = SET_OPARG(op, n);
if (n < -MAX_OPARG || MAX_OPARG < n)
FEprogram_error("Argument to bytecode is too large", 0);
return new_op;
}
static void
asm_insert(cl_fixnum where, cl_object op) {
cl_fixnum end = bytecodes->vector.fillp;
if (where > end)
FEprogram_error("asm1_insert: position out of range", 0);
if (end >= bytecodes->vector.dim)
asm_grow();
memmove(&bytecodes->vector.self.t[where+1],
&bytecodes->vector.self.t[where],
(end - where) * sizeof(cl_object));
bytecodes->vector.fillp++;
bytecodes->vector.self.t[where] = op;
}
static void
asm_list(register cl_object l) {
if (ATOM(l))
@ -227,30 +257,6 @@ asm_list(register cl_object l) {
}
}
static void
asmn(int narg, ...) {
va_list args;
va_start(args, narg);
while (narg-- > 0)
asm1(va_arg(args, cl_object));
}
static void
asm_at(register cl_index where, register cl_object what) {
if (where > bytecodes->vector.fillp)
FEprogram_error("Internal error at asm_at()",0);
bytecodes->vector.self.t[where] = what;
}
static cl_index
asm_block(void) {
cl_index output;
output = current_pc();
asm1(MAKE_FIXNUM(0));
return output;
}
static cl_index
asm_jmp(register int op) {
cl_index output = current_pc();
@ -271,21 +277,6 @@ asm_complete(register int op, register cl_index original) {
asm_at(original, new_code);
}
static cl_index
current_pc(void) {
return bytecodes->vector.fillp;
}
static void
set_pc(cl_index pc) {
bytecodes->vector.fillp = pc;
}
static cl_object
asm_ref(register cl_index n) {
return bytecodes->vector.self.t[n];
}
/* ------------------------------ COMPILER ------------------------------ */
typedef struct {
@ -352,10 +343,62 @@ FEill_formed_input()
FEprogram_error("Unproper list handled to the compiler.", 0);
}
static void
c_new_env()
{
c_env.variables = Cnil;
c_env.macros = Cnil;
c_env.lexical_level = 0;
}
static cl_object
c_macro_expand1(cl_object stmt)
{
return macro_expand1(stmt, CONS(c_env.variables, c_env.macros));
}
void
c_register_symbol_macro(cl_object name, cl_object exp_fun)
{
c_env.variables = CONS(list(3, name, @'si::symbol-macro', exp_fun),
c_env.variables);
}
void
c_register_macro(cl_object name, cl_object exp_fun)
{
c_env.macros = CONS(list(3, name, @'macro', exp_fun), c_env.macros);
}
static void
c_register_var(register cl_object var, bool special)
{
CAR(lex_env) = CONS(CONS(var, special? @'special' : Cnil), CAR(lex_env));
c_env.variables = CONS(list(2, var, special? @'special' : Cnil),
c_env.variables);
}
static cl_fixnum
c_var_ref(cl_object var)
{
cl_fixnum n = 0;
cl_object l;
for (l = c_env.variables; CONSP(l); l = CDR(l)) {
cl_object record = CAR(l);
cl_object name = CAR(record);
cl_object special = CADR(record);
if (name != var) {
/* Symbol not yet found. Only count locals. */
n++;
} else if (special == @'si::symbol-macro') {
/* We should never get here. The variable should have
been macro expanded. */
FEerror("Internal error: symbol macro ~S used as variable",
1, var);
} else {
return Null(special)? n : -1;
}
}
return -1;
}
static bool
@ -397,13 +440,13 @@ c_bind(cl_object var, cl_object specials)
static void
compile_setq(int op, cl_object var)
{
cl_object ndx;
cl_fixnum ndx;
if (!SYMBOLP(var))
FEillegal_variable_name(var);
ndx = lex_var_sch(var);
if (!Null(ndx) && CDR(ndx) != @'special')
asm_op(op); /* Lexical variable */
ndx = c_var_ref(var);
if (ndx >= 0)
asm_op2(op, ndx); /* Lexical variable */
else if (var->symbol.stype == stp_constant)
FEassignment_to_constant(var);
else if (op == OP_SETQ)
@ -688,8 +731,7 @@ c_do_doa(int op, cl_object args) {
cl_object bindings, test, specials, body, l;
cl_object stepping = Cnil, vars = Cnil;
cl_index labelb, labelt, labelz;
cl_object lex_old = lex_env;
lex_copy();
cl_object old_variables = c_env.variables;
bindings = pop(&args);
test = pop(&args);
@ -767,7 +809,7 @@ c_do_doa(int op, cl_object args) {
/* Compile return point of block */
asm_complete(OP_DO, labelz);
lex_env = lex_old;
c_env.variables = old_variables;
}
@ -809,8 +851,7 @@ c_dolist_dotimes(int op, cl_object args) {
cl_object list = pop(&head);
cl_object specials, body;
cl_index labelz, labelo;
cl_object lex_old = lex_env;
lex_copy();
cl_object old_variables = c_env.variables;
@si::process-declarations(1, args);
body = VALUES(1);
@ -848,7 +889,7 @@ c_dolist_dotimes(int op, cl_object args) {
/* Exit point for block */
asm_complete(op, labelz);
lex_env = lex_old;
c_env.variables = old_variables;
}
@ -889,8 +930,6 @@ static void
c_labels_flet(int op, cl_object args) {
cl_object def_list = pop(&args);
int nfun = length(def_list);
cl_object lex_old = lex_env;
lex_copy();
/* Remove declarations */
@si::process-declarations(1, args);
@ -907,8 +946,6 @@ c_labels_flet(int op, cl_object args) {
} while (!endp(def_list));
compile_body(args);
asm_op(OP_EXIT);
lex_env = lex_old;
}
@ -1037,8 +1074,7 @@ c_labels(cl_object args) {
static void
c_let_leta(int op, cl_object args) {
cl_object bindings, specials, body, l, vars;
cl_object lex_old = lex_env;
lex_copy();
cl_object old_variables = c_env.variables;
bindings = car(args);
@si::process-declarations(1, CDR(args));
@ -1080,7 +1116,7 @@ c_let_leta(int op, cl_object args) {
compile_body(body);
asm_op(OP_EXIT);
lex_env = lex_old;
c_env.variables = old_variables;
}
static void
@ -1114,8 +1150,7 @@ c_macrolet(cl_object args)
{
cl_object def_list, def, name;
int nfun = 0;
cl_object lex_old = lex_env;
lex_copy();
cl_object old_macros = c_env.macros;
/* Pop the list of definitions */
for (def_list = pop(&args); !endp(def_list); ) {
@ -1126,10 +1161,10 @@ c_macrolet(cl_object args)
macro = funcall(4, @'si::expand-defmacro', name, arglist,
definition);
function = make_lambda(name, CDR(macro));
lex_macro_bind(name, function);
c_register_macro(name, function);
}
compile_body(args);
lex_env = lex_old;
c_env.macros = old_macros;
}
@ -1138,8 +1173,7 @@ c_multiple_value_bind(cl_object args)
{
cl_object vars, value, body, specials;
cl_index save_pc, n;
cl_object lex_old = lex_env;
lex_copy();
cl_object old_variables = c_env.variables;
vars = pop(&args);
value = pop(&args);
@ -1168,7 +1202,7 @@ c_multiple_value_bind(cl_object args)
compile_body(body);
asm_op(OP_EXIT);
}
lex_env = lex_old;
c_env.variables = old_variables;
}
@ -1217,7 +1251,7 @@ c_multiple_value_setq(cl_object args) {
cl_object aux, v = pop(&orig_vars);
if (!SYMBOLP(v))
FEillegal_variable_name(v);
v = macro_expand1(v, lex_env);
v = c_macro_expand1(v);
if (!SYMBOLP(v)) {
aux = v;
v = @gensym(0);
@ -1250,11 +1284,12 @@ c_multiple_value_setq(cl_object args) {
asm_op2(OP_MSETQ, nvars);
vars = reverse(vars);
while (nvars--) {
cl_object ndx, var = pop(&vars);
cl_object var = pop(&vars);
cl_fixnum ndx;
if (!SYMBOLP(var))
FEillegal_variable_name(var);
ndx = lex_var_sch(var);
if (!Null(ndx) && CDR(ndx) != @'special')
ndx = c_var_ref(var);
if (ndx >= 0)
asm1(var); /* Lexical variable */
else if (var->symbol.stype == stp_constant)
FEassignment_to_constant(var);
@ -1291,7 +1326,7 @@ c_nth_value(cl_object args) {
static void
c_or(cl_object args) {
if (Null(args)) {
asm1(Cnil);
compile_form(Cnil, FALSE);
return;
} else if (ATOM(args)) {
FEill_formed_input();
@ -1376,7 +1411,7 @@ c_psetq(cl_object old_args) {
cl_object value = pop(&old_args);
if (!SYMBOLP(var))
FEillegal_variable_name(var);
var = macro_expand1(var, lex_env);
var = c_macro_expand1(var);
if (!SYMBOLP(var))
use_psetf = TRUE;
args = CONS(var, CONS(value, args));
@ -1439,7 +1474,7 @@ c_setq(cl_object args) {
cl_object value = pop(&args);
if (!SYMBOLP(var))
FEillegal_variable_name(var);
var = macro_expand1(var, lex_env);
var = c_macro_expand1(var);
if (SYMBOLP(var)) {
compile_form(value, FALSE);
compile_setq(OP_SETQ, var);
@ -1454,13 +1489,9 @@ static void
c_symbol_macrolet(cl_object args)
{
cl_object def_list, def, name, specials, body;
cl_object lex_old = lex_env;
cl_object old_variables = c_env.variables;
int nfun = 0;
/* Set a new lexical environment where we will bind
our macrology */
lex_copy();
def_list = pop(&args);
@si::process-declarations(1,args);
body = VALUES(1);
@ -1478,10 +1509,10 @@ c_symbol_macrolet(cl_object args)
declared special and appear in a symbol-macrolet.", 1, name);
definition = list(2, arglist, list(2, @'quote', expansion));
function = make_lambda(name, definition);
lex_symbol_macro_bind(name, function);
c_register_symbol_macro(name, function);
}
compile_body(body);
lex_env = lex_old;
c_env.variables = old_variables;
}
static void
@ -1490,7 +1521,7 @@ c_tagbody(cl_object args)
cl_fixnum tag_base;
cl_object label, body;
enum type item_type;
int nt;
int nt, i;
/* count the tags */
for (nt = 0, body = args; !endp(body); body = CDR(body)) {
@ -1508,7 +1539,8 @@ c_tagbody(cl_object args)
}
asm_op2(OP_TAGBODY, nt);
tag_base = current_pc();
set_pc(tag_base + 2 * nt);
for (i = 2*nt; i; i--)
asm1(Cnil);
for (body = args; !endp(body); body = CDR(body)) {
label = CAR(body);
@ -1559,7 +1591,7 @@ c_unless(cl_object form) {
asm_complete(OP_JT, label_true);
/* When test failed, output NIL */
asm1(Cnil);
compile_form(Cnil, FALSE);
asm_complete(OP_JMP, label_false);
}
@ -1623,19 +1655,25 @@ compile_form(cl_object stmt, bool push) {
*/
if (ATOM(stmt)) {
if (SYMBOLP(stmt)) {
cl_object stmt1 = macro_expand1(stmt, lex_env);
cl_object stmt1 = c_macro_expand1(stmt);
cl_fixnum index;
if (stmt1 != stmt) {
stmt = stmt1;
goto BEGIN;
}
if (push) asm_op(OP_PUSHV);
index = c_var_ref(stmt);
if (index >= 0) {
asm_op2(push? OP_PUSHV : OP_VAR, index);
} else {
asm_op(push? OP_PUSHVS : OP_VARS);
}
asm1(stmt);
goto OUTPUT;
}
QUOTED:
if (push)
asm_op(OP_PUSHQ);
else if (FIXNUMP(stmt) || SYMBOLP(stmt))
else if (FIXNUMP(stmt))
asm_op(OP_QUOTE);
asm1(stmt);
goto OUTPUT;
@ -1660,7 +1698,7 @@ compile_form(cl_object stmt, bool push) {
}
for (l = database; l->symbol != OBJNULL; l++)
if (l->symbol == function) {
lexical_level += l->lexical_increment;
c_env.lexical_level += l->lexical_increment;
(*(l->compiler))(CDR(stmt));
if (push) asm_op(OP_PUSH);
goto OUTPUT;
@ -1669,7 +1707,7 @@ compile_form(cl_object stmt, bool push) {
* Next try to macroexpand
*/
{
cl_object new_stmt = macro_expand1(stmt, lex_env);
cl_object new_stmt = c_macro_expand1(stmt);
if (new_stmt != stmt){
stmt = new_stmt;
goto BEGIN;
@ -1689,15 +1727,17 @@ for special form ~S.", 1, function);
static void
compile_body(cl_object body) {
if (lexical_level == 0 && !endp(body)) {
if (c_env.lexical_level == 0 && !endp(body)) {
while (!endp(CDR(body))) {
cl_index handle = asm_begin();
cl_object bytecodes;
compile_form(CAR(body), FALSE);
asm_op(OP_EXIT);
asm_op(OP_HALT);
VALUES(0) = Cnil;
NValues = 0;
interpret(&bytecodes->vector.self.t[handle]);
bytecodes = asm_end(handle, Cnil);
interpret(bytecodes->bytecodes.data);
asm_clear(handle);
body = CDR(body);
}
@ -2011,11 +2051,9 @@ make_lambda(cl_object name, cl_object lambda) {
cl_index specials_pc, opts_pc, keys_pc, label;
int nopts, nkeys;
cl_index handle;
cl_object lex_old = lex_env;
int old_lexical_level = lexical_level;
cl_compiler_env old_c_env = c_env;
lex_copy();
lexical_level++;
c_env.lexical_level++;
reqs = @si::process-lambda-list(1,lambda);
opts = VALUES(1);
@ -2052,7 +2090,8 @@ make_lambda(cl_object name, cl_object lambda) {
keys_pc = current_pc()+1; /* Keyword arguments */
nkeys = fix(CAR(keys));
asm_list(keys);
asmn(2, doc, decl);
asm1(doc);
asm1(decl);
label = asm_jmp(OP_JMP);
@ -2085,84 +2124,67 @@ make_lambda(cl_object name, cl_object lambda) {
compile_body(body);
asm_op(OP_HALT);
lexical_level = old_lexical_level;
lex_env = lex_old;
c_env = old_c_env;
return asm_end(handle);
}
static cl_object
alloc_bytecodes()
{
cl_object vector = alloc_simple_vector(128, aet_object);
array_allocself(vector);
vector->vector.hasfillp = TRUE;
vector->vector.fillp = 0;
return vector;
return asm_end(handle, Cnil);
}
@(defun si::make_lambda (name rest)
cl_object lambda, old_bytecodes = bytecodes;
cl_object lex_old = lex_env;
cl_object lambda;
cl_compiler_env old_c_env = c_env;
@
lex_new();
c_new_env();
if (frs_push(FRS_PROTECT, Cnil)) {
lex_env = lex_old;
bytecodes = old_bytecodes;
c_env = old_c_env;
frs_pop();
unwind(nlj_fr, nlj_tag);
}
bytecodes = alloc_bytecodes();
lambda = make_lambda(name,rest);
frs_pop();
bytecodes = old_bytecodes;
lex_env = lex_old;
c_env = old_c_env;
@(return lambda)
@)
cl_object
eval(cl_object form, cl_object *new_bytecodes, cl_object env)
{
cl_object old_bytecodes = bytecodes;
int old_lexical_level = lexical_level;
cl_object lex_old = lex_env;
cl_compiler_env old_c_env = c_env;
cl_object bytecodes, lex_old = lex_env;
cl_index handle;
bool unwinding;
if (new_bytecodes == NULL)
bytecodes = alloc_bytecodes();
else if (*new_bytecodes != Cnil) {
bytecodes = *new_bytecodes;
} else {
bytecodes = *new_bytecodes = alloc_bytecodes();
}
c_new_env();
if (Null(env)) {
lex_new();
lexical_level = 0;
c_env.lexical_level = 0;
} else {
lexical_level = 1;
c_env.lexical_level = 1;
lex_env = env;
lex_copy();
}
handle = asm_begin();
if (frs_push(FRS_PROTECT, Cnil)) {
asm_clear(handle);
lex_env = lex_old;
bytecodes = old_bytecodes;
lexical_level = old_lexical_level;
c_env = old_c_env;
frs_pop();
unwind(nlj_fr, nlj_tag);
}
handle = asm_begin();
compile_form(form, FALSE);
asm_op(OP_EXIT);
asm_op(OP_HALT);
VALUES(0) = Cnil;
NValues = 0;
interpret(&bytecodes->vector.self.t[handle]);
asm_clear(handle);
if (new_bytecodes == NULL)
bytecodes = asm_end(handle, Cnil);
else {
bytecodes = asm_end(handle, *new_bytecodes);
*new_bytecodes = bytecodes;
}
interpret(bytecodes->bytecodes.data);
frs_pop();
lex_env = lex_old;
bytecodes = old_bytecodes;
lexical_level = old_lexical_level;
c_env = old_c_env;
return VALUES(0);
}
@ -2171,8 +2193,12 @@ init_compiler(void)
{
compiler_record *l;
register_root(&bytecodes);
register_root(&c_env.variables);
register_root(&c_env.macros);
#ifdef CL_COMP_OWN_STACK
register_root(&c_env.bytecodes);
c_env.bytecodes = alloc_bytecodes();
#endif
for (l = database; l->name[0] != 0; l++)
l->symbol = _intern(l->name, lisp_package);
}

43
src/c/disassembler.d
View file

@ -368,24 +368,21 @@ disassemble(cl_object *vector) {
}
switch (GET_OP(s)) {
case OP_PUSHQ: printf("PUSH\t'");
@prin1(1, next_code(vector));
@prin1(1,next_code(vector));
break;
case OP_PUSH: string = "PUSH\tVALUES(0)";
goto NOARG;
case OP_PUSHV: string = "PUSHV";
s = search_symbol(next_code(vector));
goto ARG;
case OP_PUSH: string = "PUSH\tVALUES(0)"; goto NOARG;
case OP_PUSHV: string = "PUSHV"; goto SETQ;
case OP_PUSHVS: string = "PUSHVS"; goto QUOTE;
case OP_VAR: string = "VAR"; goto SETQ;
case OP_VARS: string = "VARS"; goto QUOTE;
case OP_QUOTE: string = "QUOTE";
s = next_code(vector);
QUOTE: s = next_code(vector);
goto ARG;
case OP_NOP: string = "NOP";
goto NOARG;
case OP_NOP: string = "NOP"; goto NOARG;
case OP_BLOCK: vector = disassemble_block(vector);
break;
case OP_PUSHVALUES: string = "PUSH\tVALUES";
goto NOARG;
case OP_MCALL: string = "MCALL";
goto NOARG;
case OP_PUSHVALUES: string = "PUSH\tVALUES"; goto NOARG;
case OP_MCALL: string = "MCALL"; goto NOARG;
case OP_CALL: string = "CALL";
n = get_oparg(s);
s = next_code(vector);
@ -422,8 +419,7 @@ disassemble(cl_object *vector) {
case OP_RETURN: string = "RETFROM";
s = next_code(vector);
goto ARG;
case OP_THROW: string = "THROW";
goto NOARG;
case OP_THROW: string = "THROW"; goto NOARG;
case OP_JMP: string = "JMP";
n = packed_label(vector-1);
goto OPARG;
@ -441,18 +437,16 @@ disassemble(cl_object *vector) {
s = next_code(vector);
n = packed_label(vector-2);
goto OPARG_ARG;
case OP_BIND: string = "BIND"; goto SETQ;
case OP_BINDS: string = "BINDS"; goto SETQS;
case OP_PBIND: string = "PBIND"; goto SETQ;
case OP_PBINDS: string = "PBINDS"; goto SETQS;
case OP_BIND: string = "BIND"; goto QUOTE;
case OP_BINDS: string = "BINDS"; goto QUOTE;
case OP_PBIND: string = "PBIND"; goto QUOTE;
case OP_PBINDS: string = "PBINDS"; goto QUOTE;
case OP_PSETQ: string = "PSETQ"; goto SETQ;
case OP_PSETQS: string = "PSETQS"; goto SETQS;
case OP_PSETQS: string = "PSETQS"; goto QUOTE;
case OP_SETQ: string = "SETQ";
SETQ: s = next_code(vector);
goto ARG;
case OP_SETQS: string = "SETQS";
SETQS: s = next_code(vector);
goto ARG;
case OP_SETQS: string = "SETQS"; goto QUOTE;
case OP_MSETQ: vector = disassemble_msetq(vector);
break;
case OP_MBIND: vector = disassemble_mbind(vector);
@ -466,8 +460,7 @@ disassemble(cl_object *vector) {
case OP_VALUES: string = "VALUES";
n = get_oparg(s);
goto OPARG;
case OP_NTHVAL: string = "NTHVAL";
goto NOARG;
case OP_NTHVAL: string = "NTHVAL"; goto NOARG;
case OP_DOLIST: vector = disassemble_dolist(vector);
break;
case OP_DOTIMES: vector = disassemble_dotimes(vector);

136
src/c/format.d
View file

@ -73,7 +73,7 @@ static cl_object fmt_stream;
static int ctl_origin;
static int ctl_index;
static int ctl_end;
static cl_object *fmt_base;
static cl_index fmt_base;
static int fmt_index;
static int fmt_end;
static int *fmt_jmp_buf;
@ -98,7 +98,7 @@ static int fmt_line_length;
volatile int old_ctl_origin; \
volatile int old_ctl_index; \
volatile int old_ctl_end; \
cl_object * volatile old_fmt_base; \
volatile cl_index old_fmt_base; \
volatile int old_fmt_index; \
volatile int old_fmt_end; \
int * volatile old_fmt_jmp_buf; \
@ -196,7 +196,14 @@ fmt_advance(void)
{
if (fmt_index >= fmt_end)
fmt_error("arguments exhausted");
return(fmt_base[fmt_index++]);
return(cl_stack[fmt_index++]);
}
static cl_object
fmt_push_list(cl_object l)
{
for (; !endp(l); l = CDR(l))
cl_stack_push(CAR(l));
}
static int
@ -677,7 +684,7 @@ fmt_plural(bool colon, bool atsign)
{
fmt_max_param(0);
if (colon) {
if (fmt_index == 0)
if (fmt_index == fmt_base)
fmt_error("can't back up");
--fmt_index;
}
@ -821,7 +828,7 @@ fmt_fix_float(bool colon, bool atsign)
WRITEC_STREAM(overflowchar, fmt_stream);
return;
}
if (j < w && b[j-1] == '.') {
if (j < w && d < 0 && b[j-1] == '.') {
b[j++] = '0';
b[j] = '\0';
}
@ -1007,10 +1014,6 @@ fmt_exponential_float(bool colon, bool atsign)
w -= i + 2;
if (j > w && overflowchar >= 0)
goto OVER;
if (j < w && b[j-1] == '.') {
b[j++] = '0';
b[j] = '\0';
}
if (j < w && b[0] == '.') {
*--b = '0';
j++;
@ -1333,7 +1336,8 @@ fmt_asterisk(bool colon, bool atsign)
fmt_not_colon_atsign(colon, atsign);
if (atsign) {
fmt_set_param(0, &n, INT, 0);
if (n < 0 || n >= fmt_end)
n += fmt_base;
if (n < fmt_base || n >= fmt_end)
fmt_error("can't goto");
fmt_index = n;
} else if (colon) {
@ -1374,10 +1378,10 @@ fmt_indirection(bool colon, bool atsign)
} else {
l = fmt_advance();
fmt_save;
fmt_base = alloca(length(l) * sizeof(cl_object));
fmt_index = 0;
for (fmt_end = 0; !endp(l); fmt_end++, l = CDR(l))
fmt_base[fmt_end] = CAR(l);
fmt_base = cl_stack_index();
fmt_push_list(l);
fmt_index = fmt_base;
fmt_end = cl_stack_index();
fmt_jmp_buf = (int *)fmt_jmp_buf0;
fmt_string = s;
if ((up_colon = ecls_setjmp(fmt_jmp_buf))) {
@ -1385,6 +1389,7 @@ fmt_indirection(bool colon, bool atsign)
fmt_error("illegal ~:^");
} else
format(fmt_stream, 0, s->string.fillp);
cl_stack_set_index(fmt_base);
fmt_restore;
}
}
@ -1572,10 +1577,10 @@ fmt_iteration(bool colon, bool atsign)
if (!colon && !atsign) {
l = fmt_advance();
fmt_save;
fmt_base = (cl_object *)alloca(length(l) * sizeof(cl_object));
fmt_index = 0;
for (fmt_end = 0; !endp(l); fmt_end++, l = CDR(l))
fmt_base[fmt_end] = CAR(l);
fmt_base = cl_stack_index();
fmt_push_list(l);
fmt_index = fmt_base;
fmt_end = cl_stack_index();
fmt_jmp_buf = (int *)fmt_jmp_buf0;
if (colon_close)
goto L1;
@ -1590,6 +1595,7 @@ fmt_iteration(bool colon, bool atsign)
}
format(fmt_stream, o + i, j - i);
}
cl_stack_set_index(fmt_base);
fmt_restore;
} else if (colon && !atsign) {
int fl = 0;
@ -1598,7 +1604,7 @@ fmt_iteration(bool colon, bool atsign)
fmt_save;
for (l = l0; !endp(l); l = CDR(l))
fl += length(CAR(l));
fmt_base = (cl_object *)alloca(fl * sizeof(cl_object));
fmt_base = cl_stack_index();
fmt_jmp_buf = (int *)fmt_jmp_buf0;
if (colon_close)
goto L2;
@ -1608,9 +1614,9 @@ fmt_iteration(bool colon, bool atsign)
break;
l = CAR(l0);
l0 = CDR(l0);
fmt_index = 0;
for (fmt_end = 0; !endp(l); fmt_end++, l = CDR(l))
fmt_base[fmt_end] = CAR(l);
fmt_push_list(l);
fmt_index = fmt_base;
fmt_end = cl_stack_index();
if ((up_colon = ecls_setjmp(fmt_jmp_buf))) {
if (--up_colon)
break;
@ -1618,6 +1624,7 @@ fmt_iteration(bool colon, bool atsign)
continue;
}
format(fmt_stream, o + i, j - i);
cl_stack_set_index(fmt_base);
}
fmt_restore;
} else if (!colon && atsign) {
@ -1646,10 +1653,10 @@ fmt_iteration(bool colon, bool atsign)
break;
l = fmt_advance();
fmt_save;
fmt_base = (cl_object *)alloca(length(l) * sizeof(cl_object));
fmt_index = 0;
for (fmt_end = 0; !endp(l); fmt_end++, l = CDR(l))
fmt_base[fmt_end] = CAR(l);
fmt_base = cl_stack_index();
fmt_push_list(l);
fmt_index = fmt_base;
fmt_end = cl_stack_index();
fmt_jmp_buf = (int *)fmt_jmp_buf0;
if ((up_colon = ecls_setjmp(fmt_jmp_buf))) {
fmt_restore;
@ -1659,6 +1666,7 @@ fmt_iteration(bool colon, bool atsign)
continue;
}
format(fmt_stream, o + i, j - i);
cl_stack_set_index(fmt_base);
fmt_restore;
}
}
@ -1668,12 +1676,13 @@ static void
fmt_justification(volatile bool colon, bool atsign)
{
int mincol, colinc, minpad, padchar;
cl_object fields[16];
volatile cl_index fields_start;
cl_index fields_end;
fmt_old;
jmp_buf fmt_jmp_buf0;
volatile int i, j, k, l, m, n, j0, l0;
volatile int i, j, k, l, m, j0, l0;
int up_colon;
volatile int special = 0;
volatile cl_object special = Cnil;
volatile int spare_spaces, line_length;
fmt_max_param(4);
@ -1682,19 +1691,16 @@ fmt_justification(volatile bool colon, bool atsign)
fmt_set_param(2, &minpad, INT, 0);
fmt_set_param(3, &padchar, CHAR, ' ');
n = 0;
fields_start = cl_stack_index();
for (;;) {
if (n >= 16)
fmt_error("too many fields");
cl_object this_field = make_string_output_stream(64);
i = ctl_index;
j0 = j = fmt_skip();
while (ctl_string[--j] != '~')
;
fields[n] = make_string_output_stream(64);
fmt_save;
fmt_jmp_buf = (int *)fmt_jmp_buf0;
if ((up_colon = ecls_setjmp(fmt_jmp_buf))) {
--n;
if (--up_colon)
fmt_error("illegal ~:^");
fmt_restore1;
@ -1704,7 +1710,8 @@ fmt_justification(volatile bool colon, bool atsign)
fmt_error("~> expected");
break;
}
format(fields[n++], ctl_origin + i, j - i);
format(this_field, ctl_origin + i, j - i);
cl_stack_push(this_field->stream.object0);
fmt_restore1;
if (ctl_string[--j0] == '>') {
if (ctl_string[--j0] != '~')
@ -1713,9 +1720,9 @@ fmt_justification(volatile bool colon, bool atsign)
} else if (ctl_string[j0] != ';')
fmt_error("~; expected");
else if (ctl_string[--j0] == ':') {
if (n != 1)
if (cl_stack_index() - fields_start != 1 || !Null(special))
fmt_error("illegal ~:;");
special = 1;
special = cl_stack_pop();
for (j = j0; ctl_string[j] != '~'; --j)
;
fmt_save;
@ -1726,9 +1733,19 @@ fmt_justification(volatile bool colon, bool atsign)
} else if (ctl_string[j0] != '~')
fmt_error("~; expected");
}
for (i = special, l = 0; i < n; i++)
l += fields[i]->stream.object0->string.fillp;
m = n - 1 - special;
/*
* Compute the length of items to be output. If the clause ~:; was
* found, the first item is not included.
*/
fields_end = cl_stack_index();
for (i = fields_start, l = 0; i < fields_end; i++)
l += cl_stack[i]->string.fillp;
/*
* Count the number of segments that need padding, "M". If the colon
* modifier, the first item needs padding. If the @ modifier is
* present, the last modifier also needs padding.
*/
m = fields_end - fields_start - 1;
if (m <= 0 && !colon && !atsign) {
m = 0;
colon = TRUE;
@ -1737,24 +1754,35 @@ fmt_justification(volatile bool colon, bool atsign)
m++;
if (atsign)
m++;
/*
* Count the minimal length in which the text fits. This length must
* the smallest integer of the form l = mincol + k * colinc. If the
* length exceeds the line length, the text before the ~:; is output
* first.
*/
l0 = l;
l += minpad * m;
for (k = 0; mincol + k * colinc < l; k++)
;
l = mincol + k * colinc;
if (special != 0 &&
FILE_COLUMN(fmt_stream) + l + spare_spaces >= line_length)
princ(fields[0]->stream.object0, fmt_stream);
if (special != Cnil &&
FILE_COLUMN(fmt_stream) + l + spare_spaces > line_length)
princ(special, fmt_stream);
/*
* Output the text with the padding segments. The total number of
* padchars is kept in "l", and it is shared equally among all segments.
*/
l -= l0;
for (i = special; i < n; i++) {
if (i > 0 || colon)
for (i = fields_start; i < fields_end; i++) {
if (i > fields_start || colon)
for (j = l / m, l -= j, --m; j > 0; --j)
WRITEC_STREAM(padchar, fmt_stream);
princ(fields[i]->stream.object0, fmt_stream);
princ(cl_stack[i], fmt_stream);
}
if (atsign)
for (j = l; j > 0; --j)
WRITEC_STREAM(padchar, fmt_stream);
cl_stack_set_index(fields_start);
}
static void
@ -1836,16 +1864,11 @@ RETRY: if (type_of(strm) == t_stream) {
fmt_restore;
unwind(nlj_fr, nlj_tag);
}
#if 0
fmt_base = (cl_object *)args;
fmt_index = 0;
fmt_end = narg - 2;
#else
fmt_base = (cl_object *)alloca((narg - 2) * sizeof(cl_object));
fmt_index = 0;
for (fmt_end = 0; fmt_end < (narg - 2); fmt_end++)
fmt_base[fmt_end] = cl_nextarg(args);
#endif
fmt_base = cl_stack_index();
for (narg -= 2; narg; narg--)
cl_stack_push(cl_nextarg(args));
fmt_index = fmt_base;
fmt_end = cl_stack_index();
fmt_jmp_buf = (int *)fmt_jmp_buf0;
if (symbol_value(@'si::*indent-formatted-output*') != Cnil)
fmt_indents = FILE_COLUMN(strm);
@ -1859,6 +1882,7 @@ RETRY: if (type_of(strm) == t_stream) {
format(strm, 0, string->string.fillp);
FLUSH_STREAM(strm);
}
cl_stack_set_index(fmt_base);
frs_pop();
fmt_restore;
@(return (x == OBJNULL? Cnil : x))

23
src/c/gbc.d
View file

@ -438,11 +438,11 @@ mark_stack_conservative(cl_ptr bottom, cl_ptr top)
static void
mark_phase(void)
{
register int i;
register struct package *pp;
register bds_ptr bdp;
register frame_ptr frp;
register ihs_ptr ihsp;
int i;
struct package *pp;
bds_ptr bdp;
frame_ptr frp;
cl_object *sp;
mark_object(Cnil);
mark_object(Ct);
@ -457,14 +457,15 @@ mark_phase(void)
clwp = pdp->pd_lpd;
#endif THREADS
mark_contblock(CIRCLEbase, CIRCLEsize*sizeof(cl_object));
mark_contblock(cl_stack, cl_stack_size * sizeof(*cl_stack));
for (sp=cl_stack; sp < cl_stack_top; sp++)
mark_object(*sp);
for (i=0; i<NValues; i++)
mark_object(VALUES(i));
mark_contblock(frs_org, frs_size * sizeof(*frs_org));
mark_contblock(bds_org, frs_size * sizeof(*bds_org));
mark_contblock(ihs_org, frs_size * sizeof(*ihs_org));
for (bdp = bds_org; bdp <= bds_top; bdp++) {
mark_object(bdp->bds_sym);
@ -473,14 +474,8 @@ mark_phase(void)
for (frp = frs_org; frp <= frs_top; frp++) {
mark_object(frp->frs_val);
mark_object(frp->frs_lex);
}
for (ihsp = ihs_org; ihsp <= ihs_top; ihsp++) {
mark_object(ihsp->ihs_function);
mark_object(ihsp->ihs_base);
}
mark_object(lex_env);
#ifdef THREADS

1
src/c/init.d
View file

@ -109,5 +109,6 @@ init_lisp(void)
#ifdef RUNTIME
SYM_VAL(@'*features*') = CONS(make_keyword("RUNTIME"), SYM_VAL(@'*features*'));
#endif
ihs_push(_intern("TOP-LEVEL", system_package), Cnil);
init_lisp_libs();
}

469
src/c/interpreter.d
View file

@ -18,32 +18,114 @@
#define next_code(v) *(v++)
#undef frs_pop
#define frs_pop() { stack->vector.fillp = frs_top->frs_sp; frs_top--; }
#define frs_pop() { cl_stack_top = cl_stack + frs_top->frs_sp; frs_top--; }
/* -------------------- INTERPRETER STACK -------------------- */
cl_index cl_stack_size = 0;
cl_object *cl_stack = NULL;
cl_object *cl_stack_top = NULL;
cl_object *cl_stack_limit = NULL;
static void
lambda_bind_var(cl_object var, cl_object val, cl_object specials)
cl_stack_set_size(cl_index new_size)
{
if (!member_eq(var, specials))
CAR(lex_env) = CONS(CONS(var, CONS(val, Cnil)), CAR(lex_env));
else {
CAR(lex_env) = CONS(CONS(var, Cnil), CAR(lex_env));
bds_bind(var, val);
}
cl_index top = cl_stack_top - cl_stack;
cl_object *new_stack;
printf("*+*+*+\n");
if (top > new_size)
FEerror("Internal error: cannot shrink stack that much.",0);
start_critical_section();
new_stack = alloc(new_size * sizeof(cl_object));
memcpy(new_stack, cl_stack, cl_stack_size * sizeof(cl_object));
cl_stack_size = new_size;
cl_stack = new_stack;
cl_stack_top = cl_stack + top;
cl_stack_limit = cl_stack + (new_size - 2);
end_critical_section();
}
void
cl_stack_grow(void)
{
cl_stack_set_size(cl_stack_size + LISP_PAGESIZE);
}
void
cl_stack_push(cl_object x) {
if (cl_stack_top >= cl_stack_limit)
cl_stack_grow();
*(cl_stack_top++) = x;
}
cl_object
cl_stack_pop() {
if (cl_stack_top == cl_stack)
FEerror("Internal error: stack underflow.",0);
return *(--cl_stack_top);
}
cl_index
cl_stack_index() {
return cl_stack_top - cl_stack;
}
void
cl_stack_set_index(cl_index index) {
cl_object *new_top = cl_stack + index;
if (new_top > cl_stack_top)
FEerror("Internal error: tried to advance stack.",0);
cl_stack_top = new_top;
}
void
cl_stack_insert(cl_index where, cl_index n) {
if (cl_stack_top + n > cl_stack_limit) {
cl_index delta = (n + (LISP_PAGESIZE-1))/LISP_PAGESIZE;
cl_stack_set_size(cl_stack_size + delta * LISP_PAGESIZE);
}
cl_stack_top += n;
memmove(&cl_stack[where+n], &cl_stack[where],
(cl_stack_top - cl_stack) * sizeof(*cl_stack));
}
void
cl_stack_pop_n(cl_index index) {
cl_object *new_top = cl_stack_top - index;
if (new_top < cl_stack)
FEerror("Internal error: stack underflow.",0);
cl_stack_top = new_top;
}
/* -------------------- LAMBDA FUNCTIONS -------------------- */
static void
bind_var(register cl_object var, register cl_object val)
{
CAR(lex_env) = CONS(CONS(var, CONS(val, Cnil)), CAR(lex_env));
CAR(lex_env) = CONS(var, CONS(val, CAR(lex_env)));
}
static void
bind_special(register cl_object var, register cl_object val)
{
CAR(lex_env) = CONS(CONS(var, Cnil), CAR(lex_env));
bds_bind(var, val);
}
static void
lambda_bind_var(cl_object var, cl_object val, cl_object specials)
{
if (!member_eq(var, specials))
bind_var(var, val);
else
bind_special(var, val);
}
static cl_object *
lambda_bind(int narg, cl_object lambda_list, cl_object *args)
{
@ -148,7 +230,7 @@ lambda_bind(int narg, cl_object lambda_list, cl_object *args)
cl_object
lambda_apply(int narg, cl_object fun, cl_object *args)
{ cl_object lex_old = lex_env;
{
cl_object output, name, *body;
bds_ptr old_bds_top;
volatile bool block, closure;
@ -156,8 +238,8 @@ lambda_apply(int narg, cl_object fun, cl_object *args)
if (type_of(fun) != t_bytecodes)
FEinvalid_function(fun);
/* Set the lexical environment of the function */
ihs_check;
/* 1) Save the lexical environment and set up a new one */
cl_stack_push(lex_env);
if (Null(fun->bytecodes.lex))
lex_env = CONS(Cnil, Cnil);
else
@ -190,67 +272,12 @@ lambda_apply(int narg, cl_object fun, cl_object *args)
END: if (block) frs_pop();
bds_unwind(old_bds_top);
lex_env = lex_old;
ihs_pop();
lex_env = cl_stack_pop();
returnn(VALUES(0));
}
/* ----------------- BYTECODE STACK --------------- */
cl_object stack = OBJNULL;
static void
stack_grow(void) {
cl_object *old_data = stack->vector.self.t;
cl_index old_size = stack->vector.fillp;
stack->vector.dim += 128;
array_allocself(stack);
memcpy(stack->vector.self.t, old_data, old_size*sizeof(cl_object));
}
static void
push1(register cl_object op) {
cl_index where;
where = stack->vector.fillp;
if (where >= stack->vector.dim)
stack_grow();
stack->vector.self.t[where] = op;
stack->vector.fillp++;
}
static cl_object
pop1() {
return stack->vector.self.t[--stack->vector.fillp];
}
static cl_index
get_sp_index() {
return stack->vector.fillp;
}
static void
dec_sp_index(register cl_index delta) {
stack->vector.fillp -= delta;
}
static void
set_sp_index(register cl_index sp) {
if (stack->vector.fillp < sp)
FEerror("Tried to advance stack", 0);
stack->vector.fillp = sp;
}
static cl_object *
get_sp() {
return stack->vector.self.t + stack->vector.fillp;
}
static cl_object *
get_sp_at(cl_index where) {
return stack->vector.self.t + where;
}
#ifdef NO_ARGS_ARRAY
cl_object
va_lambda_apply(int narg, cl_object fun, va_list args)
@ -258,9 +285,9 @@ va_lambda_apply(int narg, cl_object fun, va_list args)
cl_object out;
int i;
for (i=narg; i; i--)
push1(cl_nextarg(args));
out = lambda_apply(narg, fun, get_sp()-narg);
dec_sp_index(narg);
cl_stack_push(cl_nextarg(args));
out = lambda_apply(narg, fun, cl_stack_top-narg);
cl_stack_pop_n(narg);
return out;
}
@ -271,9 +298,9 @@ va_gcall(int narg, cl_object fun, va_list args)
cl_object out;
int i;
for (i=narg; i; i--)
push1(cl_nextarg(args));
out = gcall(narg, fun, get_sp()-narg);
dec_sp_index(narg);
cl_stack_push(cl_nextarg(args));
out = gcall(narg, fun, cl_stack_top-narg);
cl_stack_pop_n(narg);
return out;
}
#endif
@ -308,78 +335,102 @@ search_symbol_function(register cl_object fun) {
}
static cl_object
search_symbol_value(register cl_object s) {
search_local(register cl_object s) {
cl_object x;
/* x = lex_var_sch(form); */
for (x = CAR(lex_env); CONSP(x); x = CDR(x))
if (CAAR(x) == s) {
x = CDAR(x);
if (ENDP(x)) break;
return CAR(x);
for (x = CAR(lex_env); CONSP(x); x = CDDR(x))
if (CAR(x) == s) {
return CADR(x);
}
x = SYM_VAL(s);
FEerror("Internal error: local ~S not found.", 1, s);
}
static cl_object
setq_local(register cl_object s, register cl_object v) {
cl_object x;
for (x = CAR(lex_env); CONSP(x); x = CDDR(x))
if (CAR(x) == s) {
CADR(x) = v;
return;
}
FEerror("Internal error: local ~S not found.", 1, s);
}
static cl_object
search_global(register cl_object s) {
cl_object x = SYM_VAL(s);
if (x == OBJNULL)
FEunbound_variable(s);
return x;
}
static cl_object
interpret_call(int narg, cl_object fun, cl_object *args) {
interpret_call(int narg, cl_object fun) {
cl_object *args;
cl_object x;
args = cl_stack_top - narg;
AGAIN:
switch (type_of(fun)) {
case t_cfun:
ihs_push_funcall(fun->cfun.name);
ihs_push(fun->cfun.name, Cnil);
x = APPLY(narg, fun->cfun.entry, args);
ihs_pop();
return x;
break;
case t_cclosure:
/* FIXME! Shouldn't we register this call somehow? */
return APPLY_closure(narg, fun->cclosure.entry, fun->cclosure.env, args);
x = APPLY_closure(narg, fun->cclosure.entry, fun->cclosure.env, args);
break;
#ifdef CLOS
case t_gfun:
ihs_push_funcall(fun->gfun.name);
ihs_push(fun->gfun.name, Cnil);
x = gcall(narg, fun, args);
ihs_pop();
return x;
break;
#endif
case t_bytecodes:
return lambda_apply(narg, fun, args);
x = lambda_apply(narg, fun, args);
break;
case t_symbol:
fun = search_symbol_function(fun);
goto AGAIN;
default:
FEinvalid_function(fun);
}
FEinvalid_function(fun);
cl_stack_pop_n(narg);
return x;
}
/* Similar to interpret_call(), but looks for symbol functions in the
global environment. */
static cl_object
interpret_funcall(int narg, cl_object fun, cl_object *args) {
interpret_funcall(int narg, cl_object fun) {
cl_object *args;
cl_object x;
args = cl_stack_top - narg;
AGAIN:
switch (type_of(fun)) {
case t_cfun:
ihs_push_funcall(fun->cfun.name);
ihs_push(fun->cfun.name, Cnil);
x = APPLY(narg, fun->cfun.entry, args);
ihs_pop();
return x;
break;
case t_cclosure:
/* FIXME! Shouldn't we register this call somehow? */
return APPLY_closure(narg, fun->cclosure.entry, fun->cclosure.env, args);
x = APPLY_closure(narg, fun->cclosure.entry, fun->cclosure.env, args);
break;
#ifdef CLOS
case t_gfun:
ihs_push_funcall(fun->gfun.name);
ihs_push(fun->gfun.name, Cnil);
x = gcall(narg, fun, args);
ihs_pop();
return x;
break;
#endif
case t_bytecodes:
return lambda_apply(narg, fun, args);
x = lambda_apply(narg, fun, args);
break;
case t_symbol: {
cl_object function = SYM_FUN(fun);
if (function == OBJNULL)
@ -388,8 +439,10 @@ interpret_funcall(int narg, cl_object fun, cl_object *args) {
goto AGAIN;
}
default:
FEinvalid_function(fun);
}
FEinvalid_function(fun);
cl_stack_pop_n(narg);
return x;
}
/* -------------------- THE INTERPRETER -------------------- */
@ -398,15 +451,19 @@ static cl_object *
interpret_block(cl_object *vector) {
cl_object * volatile exit, name;
cl_object id = new_frame_id();
cl_object lex_old = lex_env;
lex_copy();
/* 1) Save current environment */
cl_stack_push(CDR(lex_env));
/* 2) Set up a block with given name */
exit = packed_label(vector - 1);
lex_block_bind(next_code(vector), id);
if (frs_push(FRS_CATCH,id) == 0)
vector = interpret(vector);
frs_pop();
lex_env = lex_old;
/* 3) Restore environment */
CDR(lex_env) = cl_stack_pop();
return exit;
}
@ -423,15 +480,18 @@ interpret_catch(cl_object *vector) {
static cl_object *
interpret_tagbody(cl_object *vector) {
cl_index i, ntags = get_oparg(vector[-1]);
cl_object lex_old = lex_env;
cl_object id = new_frame_id();
cl_object *aux, *tag_list = vector;
lex_copy();
/* 1) Save current environment */
cl_stack_push(CDR(lex_env));
/* 2) Bind tags */
aux = vector;
for (i=0; i<ntags; i++, aux+=2)
lex_tag_bind(*aux, id);
/* 3) Wait here for gotos */
if (frs_push(FRS_CATCH, id) != 0) {
for (aux = vector, i=0; i<ntags; i++, aux+=2)
if (eql(aux[0], nlj_tag)) {
@ -445,7 +505,9 @@ interpret_tagbody(cl_object *vector) {
}
vector = interpret(aux);
frs_pop();
lex_env = lex_old;
/* 4) Restore environment */
CDR(lex_env) = cl_stack_pop();
VALUES(0) = Cnil;
NValues = 0;
return vector;
@ -478,18 +540,23 @@ static cl_object *
interpret_do(cl_object *vector) {
cl_object *volatile exit;
cl_object id = new_frame_id();
cl_object lex_old = lex_env;
bds_ptr old_bds_top = bds_top;
lex_copy();
lex_block_bind(Cnil, id);
/* 1) Save all environment */
bds_ptr old_bds_top = bds_top;
cl_stack_push(CAR(lex_env));
cl_stack_push(CDR(lex_env));
/* 2) Set up new block name */
lex_block_bind(Cnil, id);
exit = packed_label(vector-1);
if (frs_push(FRS_CATCH,id) == 0)
interpret(vector);
frs_pop();
lex_env = lex_old;
/* 3) Restore all environment */
bds_unwind(old_bds_top);
CDR(lex_env) = cl_stack_pop();
CAR(lex_env) = cl_stack_pop();
return exit;
}
@ -498,17 +565,23 @@ interpret_dolist(cl_object *vector) {
cl_object *output, *volatile exit;
cl_object list, var;
cl_object id = new_frame_id();
cl_object lex_old = lex_env;
bds_ptr old_bds_top = bds_top;
lex_copy();
lex_block_bind(Cnil, id);
list = VALUES(0);
exit = packed_label(vector - 1);
/* 1) Save all environment */
bds_ptr old_bds_top = bds_top;
cl_stack_push(CAR(lex_env));
cl_stack_push(CDR(lex_env));
/* 2) Set up a nil block */
lex_block_bind(Cnil, id);
if (frs_push(FRS_CATCH,id) == 0) {
/* Build list & bind variable*/
list = VALUES(0);
exit = packed_label(vector - 1);
/* 3) Build list & bind variable*/
vector = interpret(vector);
output = packed_label(vector-1);
/* 4) Repeat until list is exahusted */
while (!endp(list)) {
NValues = 1;
VALUES(0) = CAR(list);
@ -520,7 +593,10 @@ interpret_dolist(cl_object *vector) {
interpret(output);
}
frs_pop();
lex_env = lex_old;
/* 5) Restore environment */
CDR(lex_env) = cl_stack_pop();
CAR(lex_env) = cl_stack_pop();
bds_unwind(old_bds_top);
return exit;
}
@ -531,17 +607,22 @@ interpret_dotimes(cl_object *vector) {
cl_fixnum length, i;
cl_object var;
cl_object id = new_frame_id();
cl_object lex_old = lex_env;
bds_ptr old_bds_top = bds_top;
lex_copy();
lex_block_bind(Cnil, id);
length = fix(VALUES(0));
exit = packed_label(vector - 1);
/* 1) Save all environment */
bds_ptr old_bds_top = bds_top;
cl_stack_push(CAR(lex_env));
cl_stack_push(CDR(lex_env));
/* 2) Set up a nil block */
lex_block_bind(Cnil, id);
if (frs_push(FRS_CATCH,id) == 0) {
/* Bind variable */
/* 3) Retrieve number and bind variables */
length = fix(VALUES(0));
exit = packed_label(vector - 1);
vector = interpret(vector);
output = packed_label(vector-1);
/* 4) Loop while needed */
for (i = 0; i < length;) {
interpret(vector);
NValues = 1;
@ -550,7 +631,10 @@ interpret_dotimes(cl_object *vector) {
interpret(output);
}
frs_pop();
lex_env = lex_old;
/* 5) Restore environment */
CDR(lex_env) = cl_stack_pop();
CAR(lex_env) = cl_stack_pop();
bds_unwind(old_bds_top);
return exit;
}
@ -569,39 +653,52 @@ close_around(cl_object fun, cl_object lex) {
static cl_object *
interpret_flet(cl_object *vector) {
cl_object lex_old = lex_env;
cl_index nfun = get_oparg(vector[-1]);
lex_copy();
/* 1) Copy the environment so that functions get it */
cl_object lex = CONS(CAR(lex_env), CDR(lex_env));
/* 2) Save current environment */
cl_stack_push(CDR(lex_env));
/* 3) Add new closures to environment */
while (nfun--) {
cl_object fun = next_code(vector);
cl_object f = close_around(fun,lex_old);
cl_object f = close_around(fun,lex);
lex_fun_bind(f->bytecodes.data[0], f);
}
vector = interpret(vector);
lex_env = lex_old;
/* 4) Restore environment */
CDR(lex_env) = cl_stack_pop();
return vector;
}
static cl_object *
interpret_labels(cl_object *vector) {
cl_object lex_old = lex_env;
cl_index i, nfun = get_oparg(vector[-1]);
cl_object l;
cl_object l, lex;
lex_copy();
/* 1) Save current environment */
cl_stack_push(CDR(lex_env));
/* 2) Build up a new environment with all functions */
for (i=0; i<nfun; i++) {
cl_object f = next_code(vector);
lex_fun_bind(f->bytecodes.data[0], f);
}
/* Update the closures so that all functions can call each other */
lex = CONS(CAR(lex_env), CDR(lex_env));
/* 3) Update the closures so that all functions can call each other */
for (i=0, l=CDR(lex_env); i<nfun; i++) {
cl_object f = CADDAR(l);
CADDAR(l) = close_around(f, lex_env);
CADDAR(l) = close_around(f, lex);
l = CDR(l);
}
vector = interpret(vector);
lex_env = lex_old;
/* 4) Restore environment */
CDR(lex_env) = cl_stack_pop();
return vector;
}
@ -622,10 +719,9 @@ interpret_mbind(cl_object *vector)
static cl_object *
interpret_mcall(cl_object *vector) {
cl_index sp = get_sp_index();
cl_index sp = cl_stack_index();
vector = interpret(vector);
VALUES(0) = interpret_call(get_sp_index()-sp, VALUES(0), get_sp_at(sp));
set_sp_index(sp);
VALUES(0) = interpret_call(cl_stack_index()-sp, VALUES(0));
return vector;
}
@ -633,11 +729,11 @@ static cl_object *
interpret_mprog1(cl_object *vector) {
cl_index i,n = NValues;
for (i=0; i<n; i++) {
push1(VALUES(i));
cl_stack_push(VALUES(i));
}
vector = interpret(vector);
for (i=n; i;) {
VALUES(--i) = pop1();
VALUES(--i) = cl_stack_pop();
}
NValues = n;
return vector;
@ -652,7 +748,7 @@ interpret_msetq(cl_object *vector)
var = next_code(vector);
value = (i < NValues) ? VALUES(i) : Cnil;
if (var != MAKE_FIXNUM(1))
CADR(lex_var_sch(var)) = value;
setq_local(var, value);
else {
var = next_code(vector);
if (var->symbol.stype == stp_constant)
@ -668,11 +764,13 @@ interpret_msetq(cl_object *vector)
static cl_object *
interpret_progv(cl_object *vector) {
cl_object values = VALUES(0);
cl_object vars = pop1();
cl_object lex_old = lex_env;
bds_ptr old_bds_top = bds_top;
cl_object vars = cl_stack_pop();
lex_copy();
/* 1) Save current environment */
bds_ptr old_bds_top = bds_top;
cl_stack_push(CAR(lex_env));
/* 2) Add new bindings */
while (!endp(vars)) {
if (values == Cnil)
bds_bind(CAR(vars), OBJNULL);
@ -683,19 +781,24 @@ interpret_progv(cl_object *vector) {
vars = CDR(vars);
}
vector = interpret(vector);
lex_env = lex_old;
/* 3) Restore environment */
CAR(lex_env) = cl_stack_pop();
bds_unwind(old_bds_top);
return vector;
}
static cl_object *
interpret_pushenv(cl_object *vector) {
cl_object lex_old = lex_env;
/* 1) Save environment */
bds_ptr old_bds_top = bds_top;
cl_stack_push(CAR(lex_env));
lex_copy();
/* 2) Execute */
vector = interpret(vector);
lex_env = lex_old;
/* 3) Restore environment */
CAR(lex_env) = cl_stack_pop();
bds_unwind(old_bds_top);
return vector;
}
@ -709,11 +812,6 @@ interpret(cl_object *vector) {
BEGIN:
s = next_code(vector);
t = type_of(s);
if (t == t_symbol) {
VALUES(0) = search_symbol_value(s);
NValues = 1;
goto BEGIN;
}
if (t != t_fixnum) {
VALUES(0) = s;
NValues = 1;
@ -721,13 +819,24 @@ interpret(cl_object *vector) {
}
switch (GET_OP(s)) {
case OP_PUSHQ:
push1(next_code(vector));
cl_stack_push(next_code(vector));
break;
case OP_PUSH:
push1(VALUES(0));
cl_stack_push(VALUES(0));
break;
case OP_PUSHV:
push1(search_symbol_value(next_code(vector)));
cl_stack_push(search_local(next_code(vector)));
break;
case OP_PUSHVS:
cl_stack_push(search_global(next_code(vector)));
break;
case OP_VAR:
VALUES(0) = search_local(next_code(vector));
NValues = 1;
break;
case OP_VARS:
VALUES(0) = search_global(next_code(vector));
NValues = 1;
break;
case OP_QUOTE:
VALUES(0) = next_code(vector);
@ -743,7 +852,7 @@ interpret(cl_object *vector) {
case OP_PUSHVALUES: {
int i;
for (i=0; i<NValues; i++)
push1(VALUES(i));
cl_stack_push(VALUES(i));
break;
}
case OP_MCALL:
@ -752,31 +861,27 @@ interpret(cl_object *vector) {
case OP_CALL: {
cl_fixnum n = get_oparg(s);
cl_object name = next_code(vector);
VALUES(0) = interpret_call(n, name, get_sp()-n);
dec_sp_index(n);
VALUES(0) = interpret_call(n, name);
break;
}
case OP_PCALL: {
cl_fixnum n = get_oparg(s);
cl_object name = next_code(vector);
VALUES(0) = interpret_call(n, name, get_sp()-n);
dec_sp_index(n);
push1(VALUES(0));
VALUES(0) = interpret_call(n, name);
cl_stack_push(VALUES(0));
break;
}
case OP_FCALL: {
cl_fixnum n = get_oparg(s);
cl_object fun = VALUES(0);
VALUES(0) = interpret_funcall(n, fun, get_sp()-n);
dec_sp_index(n);
VALUES(0) = interpret_funcall(n, fun);
break;
}
case OP_PFCALL: {
cl_fixnum n = get_oparg(s);
cl_object fun = VALUES(0);
VALUES(0) = interpret_funcall(n, fun, get_sp()-n);
dec_sp_index(n);
push1(VALUES(0));
VALUES(0) = interpret_funcall(n, fun);
cl_stack_push(VALUES(0));
break;
}
case OP_CATCH:
@ -819,7 +924,7 @@ interpret(cl_object *vector) {
break;
}
case OP_THROW:
throw(pop1());
throw(cl_stack_pop());
break;
case OP_JMP:
vector = vector - 1 + get_oparg(s);
@ -847,7 +952,7 @@ interpret(cl_object *vector) {
bind_special(next_code(vector), VALUES(0));
break;
case OP_SETQ:
CADR(lex_var_sch(next_code(vector))) = VALUES(0);
setq_local(next_code(vector), VALUES(0));
break;
case OP_SETQS: {
cl_object var = next_code(vector);
@ -858,13 +963,13 @@ interpret(cl_object *vector) {
break;
}
case OP_PBIND:
bind_var(next_code(vector), pop1());
bind_var(next_code(vector), cl_stack_pop());
break;
case OP_PBINDS:
bind_special(next_code(vector), pop1());
bind_special(next_code(vector), cl_stack_pop());
break;
case OP_PSETQ:
CADR(lex_var_sch(next_code(vector))) = pop1();
setq_local(next_code(vector), cl_stack_pop());
Values[0] = Cnil;
NValues = 1;
break;
@ -873,7 +978,7 @@ interpret(cl_object *vector) {
if (var->symbol.stype == stp_constant)
FEassignment_to_constant(var);
else
SYM_VAL(var) = pop1();
SYM_VAL(var) = cl_stack_pop();
Values[0] = Cnil;
NValues = 1;
break;
@ -897,11 +1002,11 @@ interpret(cl_object *vector) {
cl_fixnum n = get_oparg(s);
NValues = n;
while (n)
VALUES(--n) = pop1();
VALUES(--n) = cl_stack_pop();
break;
}
case OP_NTHVAL: {
cl_index n = fix(pop1());
cl_index n = fix(cl_stack_pop());
if (n < 0 || n >= NValues)
VALUES(0) = Cnil;
else
@ -933,15 +1038,13 @@ interpret(cl_object *vector) {
@(defun si::interpreter_stack ()
@
@(return stack)
@(return Cnil)
@)
void
init_interpreter(void)
{
register_root(&stack);
stack = alloc_simple_vector(128, aet_object);
array_allocself(stack);
stack->vector.hasfillp = TRUE;
stack->vector.fillp = 0;
cl_stack = NULL;
cl_stack_size = 0;
cl_stack_set_size(8*LISP_PAGESIZE);
}

12
src/c/lex.d
View file

@ -36,18 +36,6 @@ lex_fun_bind(cl_object name, cl_object fun)
CDR(lex_env) = CONS(list(3, name, @'function', fun), CDR(lex_env));
}
void
lex_symbol_macro_bind(cl_object name, cl_object exp_fun)
{
CAR(lex_env) = CONS(list(3, name, @'si::symbol-macro', exp_fun), CAR(lex_env));
}
void
lex_macro_bind(cl_object name, cl_object exp_fun)
{
CDR(lex_env) = CONS(list(3, name, @'macro', exp_fun), CDR(lex_env));
}
void
lex_tag_bind(cl_object tag, cl_object id)
{

5
src/c/lwp.d
View file

@ -114,10 +114,7 @@ make_pd()
npd->lwp_cs_limit = npd->lwp_cs_org + STACK_SIZE;
#endif
/* invocation history stack */
npd->lwp_ihssize = IHSSIZE + 2*IHSGETA;
npd->lwp_ihsorg = malloc(npd->lwp_ihssize * sizeof(*npd->lwp_ihsorg));
npd->lwp_ihstop = npd->lwp_ihsorg-1;
npd->lwp_ihslimit = &npd->lwp_ihsorg[npd->lwp_ihssize - 2*IHSGETA];
npd->lwp_ihstop = 0
/* frame stack */
npd->lwp_frs_size = FRSSIZE + 2*FRSGETA;
npd->lwp_frs_org = malloc(npd->lwp_frs_size * sizeof(*npd->lwp_frs_org));

1
src/c/main.d
View file

@ -102,7 +102,6 @@ main(int argc, char **argv)
NULL); /* geometry */
}
#endif
ihs_push(_intern("TOP-LEVEL", system_package), Cnil);
funcall(1, @'si::top-level');
return(0);
}

98
src/c/print.d
View file

@ -111,10 +111,7 @@ cl_object @'si::sharp-exclamation';
#define isp clwp->lwp_isp
#define iisp clwp->lwp_iisp
#define CIRCLEsize clwp->lwp_CIRCLEsize
#define CIRCLEbase clwp->lwp_CIRCLEbase
#define CIRCLEtop clwp->lwp_CIRCLEtop
#define CIRCLElimit clwp->lwp_CIRCLElimit
#else
static short queue[Q_SIZE];
@ -126,10 +123,7 @@ static int qc;
static int isp;
static int iisp;
cl_index CIRCLEsize;
cl_object *CIRCLEbase;
cl_object *CIRCLEtop;
cl_object *CIRCLElimit;
cl_fixnum CIRCLEbase;
cl_object PRINTstream;
#endif THREADS
@ -139,7 +133,7 @@ cl_object PRINTstream;
static void flush_queue (bool force);
static void write_decimal1 (int i);
static void travel_push_object (cl_object x);
static cl_object *searchPRINTcircle(cl_object x);
static cl_index searchPRINTcircle(cl_object x);
static bool doPRINTcircle(cl_object x);
@ -550,6 +544,7 @@ call_structure_print_function(cl_object x, int level)
bool a = PRINTarray;
cl_object ps = PRINTstream;
cl_object pc = PRINTcase;
cl_fixnum cb = CIRCLEbase;
short ois[IS_SIZE];
@ -612,6 +607,7 @@ call_structure_print_function(cl_object x, int level)
qt = oqt;
qh = oqh;
CIRCLEbase = cb;
PRINTcase = pc;
PRINTstream = ps;
PRINTarray = a;
@ -650,6 +646,7 @@ call_print_object(cl_object x, int level)
bool a = PRINTarray;
cl_object ps = PRINTstream;
cl_object pc = PRINTcase;
cl_index cb = CIRCLEbase;
short ois[IS_SIZE];
@ -711,6 +708,7 @@ call_print_object(cl_object x, int level)
qt = oqt;
qh = oqh;
CIRCLEbase = cb;
PRINTcase = pc;
PRINTstream = ps;
PRINTarray = a;
@ -1174,11 +1172,11 @@ write_object(cl_object x, int level)
break;
}
if (PRINTcircle) {
cl_object *vp = searchPRINTcircle(x);
if (vp != NULL) {
if (vp[1] != Cnil) {
cl_index vp = searchPRINTcircle(x);
if (vp != 0) {
if (cl_stack[vp] != Cnil) {
write_str(" . #");
write_decimal((vp-CIRCLEbase)/2);
write_decimal((vp-CIRCLEbase)/2+1);
write_ch('#');
goto RIGHT_PAREN;
} else {
@ -1460,58 +1458,62 @@ write_object(cl_object x, int level)
}
/* To print circular structures, we traverse the structure by adding
a pair <element, flag> to the array CIRCLEbase for each element visited.
a pair <element, flag> to the interpreter stack for each element visited.
flag is initially NIL and becomes T if the element is visited again.
After the visit we squeeze out all the non circular elements.
The flags is used during printing to distinguish between the first visit
to the element.
*/
/* Allocates space for travel_push: if not enough, get back with
longjmp and increase it */
static void
setupPRINTcircle(cl_object x)
{
cl_object *vp, *vq;
cl_object *vp, *vq, *CIRCLEtop;
CIRCLEsize = 4000;
CIRCLEbase = alloc_atomic(CIRCLEsize * sizeof(cl_object));
CIRCLEtop = CIRCLEbase;
CIRCLElimit = &CIRCLEbase[CIRCLEsize];
if (CIRCLEbase >= 0)
FEerror("Internal error: tried to overwrite CIRCLEbase.",0);
if (!PRINTcircle) {
CIRCLEbase = -1;
return;
}
CIRCLEbase = cl_stack_index();
travel_push_object(x);
CIRCLEtop = cl_stack_top;
/* compact shared elements towards CIRCLEbase */
for (vp = vq = CIRCLEbase; vp < CIRCLEtop; vp += 2)
for (vp = vq = &cl_stack[CIRCLEbase]; vp < CIRCLEtop; vp += 2)
if (vp[1] != Cnil) {
vq[0] = vp[0]; vq[1] = Cnil; vq += 2;
}
CIRCLEtop = vq;
cl_stack_set_index(vq - cl_stack);
}
static cl_object *
static cl_index
searchPRINTcircle(cl_object x)
{
cl_object *vp;
cl_object *vp, *CIRCLEtop;
for (vp = CIRCLEbase; vp < CIRCLEtop; vp += 2)
if (CIRCLEbase < 0)
return 0;
CIRCLEtop = cl_stack_top;
for (vp = &cl_stack[CIRCLEbase]; vp < CIRCLEtop; vp += 2)
if (vp[0] == x)
return vp;
return NULL;
return vp-cl_stack+1;
return 0;
}
static bool
doPRINTcircle(cl_object x)
{
cl_object *vp = searchPRINTcircle(x);
if (vp != NULL) {
cl_index vp = searchPRINTcircle(x);
if (vp != 0) {
write_ch('#');
write_decimal((vp-CIRCLEbase)/2);
if (vp[1] != Cnil) {
write_decimal((vp-CIRCLEbase)/2+1);
if (cl_stack[vp] != Cnil) {
write_ch('#');
return TRUE; /* All is done */
} else {
write_ch('=');
vp[1] = Ct;
cl_stack[vp] = Ct;
}
}
return FALSE; /* Print the structure */
@ -1522,7 +1524,7 @@ travel_push_object(cl_object x)
{
enum type t;
cl_index i;
cl_object *vp;
cl_object *vp, *CIRCLEtop;
cs_check(x);
@ -1537,25 +1539,14 @@ BEGIN:
#endif CLOS
!(t == t_symbol && Null(x->symbol.hpack)))
return;
for (vp = CIRCLEbase; vp < CIRCLEtop; vp += 2)
if (x == *vp) {
/* if (vp[1] == Cnil) */ vp[1] = Ct;
CIRCLEtop = cl_stack_top;
for (vp = &cl_stack[CIRCLEbase]; vp < CIRCLEtop; vp += 2)
if (x == vp[0]) {
vp[1] = Ct;
return;
}
if (CIRCLEtop >= CIRCLElimit) {
/* allocate more space */
cl_object *ptr;
int newsize = CIRCLEsize + 4000;
ptr = alloc_atomic(newsize * sizeof(cl_object));
memcpy(ptr, CIRCLEbase, CIRCLEsize * sizeof(cl_object));
CIRCLEsize = newsize;
CIRCLEtop = (CIRCLEtop - CIRCLEbase) + ptr;
CIRCLEbase = ptr;
CIRCLElimit = &CIRCLEbase[CIRCLEsize];
}
CIRCLEtop[0] = x;
CIRCLEtop[1] = Cnil;
CIRCLEtop += 2;
cl_stack_push(x);
cl_stack_push(Cnil);
switch (t) {
case t_array:
@ -1646,6 +1637,7 @@ RETRY: if (type_of(PRINTstream) == t_stream) {
PRINTlength = fix(y);
PRINTarray = symbol_value(@'*print-array*') != Cnil;
/* setupPRINTcircle(x); */
CIRCLEbase = -1;
if (PRINTpretty) {
qh = qt = qc = 0;
isp = iisp = 0;
@ -1660,6 +1652,10 @@ RETRY: if (type_of(PRINTstream) == t_stream) {
void cleanupPRINT(void)
{
if (CIRCLEbase >= 0) {
cl_stack_set_index(CIRCLEbase);
CIRCLEbase = -1;
}
if (PRINTpretty)
flush_queue(TRUE);
}

67
src/c/read.d
View file

@ -924,30 +924,19 @@ static
*----------------------------------------------------------------------
*/
#define INCREMENT 64
#define ESTACK(st) volatile int _esize = 0; cl_object *(st), *(st ## 0);
#define ETOP(st) (st ## 0)
#define EPUSH(st, val, count) \
{ int i; if (count == _esize) { \
st = (cl_object *)alloca(INCREMENT*sizeof(cl_object)); \
for ( i = 0; i < _esize; i++) \
st[i] = st ## 0[i]; \
(st ## 0) = st; st += _esize;\
_esize += INCREMENT; \
}; *(st)++ = (val);}
static
@(defun si::sharp_left_parenthesis_reader (in c d)
int dim, dimcount, i, a;
bool fixed_size;
cl_index dim, dimcount, i, a;
cl_index sp = cl_stack_index();
cl_object x, last;
ESTACK(vsp);
@
if (Null(d) || READsuppress)
dim = -1;
else if (FIXNUMP(d))
dim = fix(d);
fixed_size = FALSE;
else {
fixed_size = TRUE;
dim = fixnnint(d);
}
if (backq_level > 0) {
unreadc_stream('(', in);
x = read_object(in);
@ -956,7 +945,7 @@ static
FEerror(",at or ,. has appeared in an illegal position.", 0);
if (a == QUOTE) {
for (dimcount = 0; !endp(x); x = CDR(x), dimcount++)
EPUSH(vsp, CAR(x), dimcount);
cl_stack_push(CAR(x));
goto L;
}
@(return list(4, siScomma, @'apply',
@ -967,38 +956,42 @@ static
x = read_object(in);
if (x == OBJNULL)
break;
EPUSH(vsp, x, dimcount);
cl_stack_push(x);
}
L:
if (dim >= 0) {
if (fixed_size) {
if (dimcount > dim)
FEerror("Too many elements in #(...).", 0);
if (dimcount == 0)
FEerror("Cannot fill the vector #().", 0);
else last = vsp[-1];
else last = cl_stack_top[-1];
} else
dim = dimcount;
dim = dimcount;
x = alloc_simple_vector(dim, aet_object);
x->vector.self.t = alloc_align(dim * sizeof(cl_object), sizeof(cl_object));
for (i = 0; i < dim; i++)
x->vector.self.t[i] = (i < dimcount) ? ETOP(vsp)[i] : last;
x->vector.self.t[i] = (i < dimcount) ? cl_stack[sp+i] : last;
cl_stack_pop_n(dimcount);
@(return x)
@)
static
@(defun si::sharp_asterisk_reader (in c d)
int dim, dimcount, i;
bool fixed_size;
cl_index dim, dimcount, i;
cl_index sp = cl_stack_index();
cl_object x, last, elt;
ESTACK(vsp);
@
if (READsuppress) {
read_constituent(in);
@(return Cnil)
}
if (Null(d))
dim = -1;
else if (FIXNUMP(d))
dim = fix(d);
fixed_size = FALSE;
else {
dim = fixnnint(d);
fixed_size = TRUE;
}
for (dimcount = 0 ;; dimcount++) {
if (stream_at_end(in))
break;
@ -1007,27 +1000,27 @@ static
unread_char(x, in);
break;
}
EPUSH(vsp, x, dimcount);
cl_stack_push(x);
}
if (dim >= 0) {
if (fixed_size) {
if (dimcount > dim)
FEerror("Too many elements in #*....", 0);
if (dimcount == 0)
FEerror("Cannot fill the bit-vector #*.", 0);
else last = vsp[-1];
else last = cl_stack_top[-1];
} else {
dim = dimcount; /* Beppe ? */
last = MAKE_FIXNUM(0);
dim = dimcount;
}
x = alloc_simple_bitvector(dim);
x->vector.self.bit = alloc_atomic((dim + CHAR_BIT - 1)/CHAR_BIT);
for (i = 0; i < dim; i++) {
elt = (i < dimcount) ? ETOP(vsp)[i] : last;
elt = (i < dimcount) ? cl_stack[sp+i] : last;
if (char_code(elt) == '0')
x->vector.self.bit[i/CHAR_BIT] &= ~(0200 >> i%CHAR_BIT);
else
x->vector.self.bit[i/CHAR_BIT] |= 0200 >> i%CHAR_BIT;
}
}
cl_stack_pop_n(dimcount);
@(return x)
@)

143
src/c/stacks.d
View file

@ -26,10 +26,7 @@ bds_ptr bds_org;
bds_ptr bds_limit;
bds_ptr bds_top;
size_t ihs_size;
ihs_ptr ihs_org;
ihs_ptr ihs_limit;
ihs_ptr ihs_top;
cl_index ihs_top;
size_t frs_size;
frame_ptr frs_org;
@ -98,17 +95,7 @@ get_bds_ptr(cl_object x)
/******************** INVOCATION STACK **********************/
void
ihs_overflow(void)
{
--ihs_top;
if (ihs_limit > ihs_org + ihs_size)
error("invocation history stack overflow.");
ihs_limit += IHSGETA;
FEerror("Invocation history stack overflow.", 0);
}
cl_object
static cl_object
ihs_function_name(cl_object x)
{
cl_object y;
@ -132,52 +119,102 @@ ihs_function_name(cl_object x)
}
}
void
ihs_push(cl_object function, cl_object env)
{
cl_stack_push(function);
cl_stack_push(env);
cl_stack_push(MAKE_FIXNUM(ihs_top));
ihs_top = cl_stack_index();
}
void
ihs_pop()
{
cl_stack_set_index(ihs_top);
ihs_top = fix(cl_stack_top[-1]);
cl_stack_pop_n(3);
}
static cl_object *
get_ihs_ptr(cl_index n)
{
cl_object *sp = &cl_stack[n];
if (sp > cl_stack && sp <= cl_stack_top)
return sp;
FEerror("~S is an illegal ihs index.", 1, MAKE_FIXNUM(n));
}
static cl_index
ihs_prev(cl_index n)
{
cl_object *sp = get_ihs_ptr(n);
n = fixnnint(sp[-1]);
return n;
}
cl_object
ihs_top_function_name(void)
{
cl_object x;
ihs_ptr h = ihs_top;
cl_index h = ihs_top;
while (h >= ihs_org) {
x = ihs_function_name(h->ihs_function);
if (x != Cnil)
return(x);
h--;
while (h > 0) {
cl_object *sp = get_ihs_ptr(h);
cl_object next_h = sp[-1];
cl_object lex_env = sp[-2];
cl_object name = ihs_function_name(sp[-3]);
if (name != Cnil)
return name;
h = fixnnint(next_h);
}
return(Cnil);
}
/*
Lisp interface to IHS
*/
static ihs_ptr
get_ihs_ptr(cl_object x)
{
ihs_ptr p;
if (FIXNUMP(x)) {
p = ihs_org + fix(x);
if (ihs_org <= p && p <= ihs_top)
return(p);
}
FEerror("~S is an illegal ihs index.", 1, x);
}
@(defun si::ihs_top ()
@(defun si::ihs_top (name)
cl_index h = ihs_top;
cl_object *sp;
@
@(return MAKE_FIXNUM(ihs_top - ihs_org))
name = ihs_function_name(name);
while (h > 0) {
cl_object *sp = get_ihs_ptr(h);
cl_object fun = sp[-3];
if (ihs_function_name(fun) == name)
break;
h = fixnnint(sp[-1]);
}
if (h == 0)
h = ihs_top;
@(return MAKE_FIXNUM(h))
@)
@(defun si::ihs-prev (x)
@
@(return MAKE_FIXNUM(ihs_prev(fixnnint(x))))
@)
@(defun si::ihs-next (x)
cl_index h1 = ihs_top, h2 = ihs_top;
cl_index n = fixnnint(x);
@
while (h2 > n) {
h1 = h2;
h2 = ihs_prev(h1);
}
if (h2 == n)
@(return MAKE_FIXNUM(h1))
FEerror("Internal error: ihs record ~S not found.", 1, x);
@)
@(defun si::ihs_fun (arg)
@
@(return get_ihs_ptr(arg)->ihs_function)
@(return get_ihs_ptr(fixnnint(arg))[-3])
@)
@(defun si::ihs_env (arg)
cl_object lex;
@
lex = get_ihs_ptr(arg)->ihs_base;
lex = get_ihs_ptr(fixnnint(arg))[-2];
@(return CONS(car(lex),cdr(lex)))
@)
@ -210,7 +247,7 @@ _frs_push(register enum fr_class class, register cl_object val)
frs_top->frs_class = class;
frs_top->frs_val = val;
frs_top->frs_ihs = ihs_top;
frs_top->frs_sp = stack->vector.fillp;
frs_top->frs_sp = cl_stack_index();
return frs_top;
}
@ -225,7 +262,7 @@ unwind(frame_ptr fr, cl_object tag)
lex_env = frs_top->frs_lex;
ihs_top = frs_top->frs_ihs;
bds_unwind(frs_top->frs_bds_top);
stack->vector.fillp = frs_top->frs_sp;
cl_stack_set_index(frs_top->frs_sp);
ecls_longjmp(frs_top->frs_jmpbuf, 1);
/* never reached */
}
@ -295,14 +332,14 @@ get_frame_ptr(cl_object x)
@(defun si::frs_ihs (arg)
@
@(return MAKE_FIXNUM(get_frame_ptr(arg)->frs_ihs - ihs_org))
@(return MAKE_FIXNUM(get_frame_ptr(arg)->frs_ihs))
@)
@(defun si::sch_frs_base (fr ihs)
frame_ptr x;
ihs_ptr y;
cl_index y;
@
y = get_ihs_ptr(ihs);
y = fixnnint(ihs);
for (x = get_frame_ptr(fr); x <= frs_top && x->frs_ihs < y; x++);
@(return ((x > frs_top) ? Cnil : MAKE_FIXNUM(x - frs_org)))
@)
@ -319,10 +356,6 @@ get_frame_ptr(cl_object x)
frs_limit = frs_org + (frs_size - 2*FRSGETA);
else
error("can't reset frs_limit.");
if (ihs_top < ihs_org + (ihs_size - 2*IHSGETA))
ihs_limit = ihs_org + (ihs_size - 2*IHSGETA);
else
error("can't reset ihs_limit.");
#ifdef DOWN_STACK
if (&narg > cs_org - cssize + 16)
cs_limit = cs_org - cssize;
@ -351,10 +384,8 @@ alloc_stacks(int *new_cs_org)
bds_org = alloc(bds_size * sizeof(*bds_org));
bds_top = bds_org-1;
bds_limit = &bds_org[bds_size - 2*BDSGETA];
ihs_size = IHSSIZE + 2*IHSGETA;
ihs_org = alloc(ihs_size * sizeof(*ihs_org));
ihs_top = ihs_org-1;
ihs_limit = &ihs_org[ihs_size - 2*IHSGETA];
ihs_top = 0;
cs_org = new_cs_org;
#if defined(HAVE_SYS_RESOURCE_H) && defined(RLIMIT_STACK)

2
src/cmp/cmputil.lsp
View file

@ -161,7 +161,7 @@
(let*
#-:CCL
((sys::*ihs-base* sys::*ihs-top*)
(sys::*ihs-top* (1- (sys::ihs-top)))
(sys::*ihs-top* (sys::ihs-top 'cmp-toplevel-eval))
(*break-enable* *compiler-break-enable*)
(sys::*break-hidden-packages*
(cons (find-package 'compiler)

2
src/cmp/sysfun.lsp
View file

@ -261,7 +261,7 @@
#-clcs
(CERROR (T T *) T nil nil)
(si::IHS-TOP)
(si::IHS-TOP (T) T)
(si::IHS-FUN)
(si::IHS-ENV)
(si::FRS-TOP)

17
src/h/bytecodes.h
View file

@ -10,6 +10,20 @@
OP_PUSH
Pushes the object in VALUES(0)
OP_PUSHV n{arg}, var{symbol}
Pushes the value of the n-th local onto the stack. VAR is given
for readability purposes only.
OP_PUSHVS var{symbol}
Pushes the value of the symbol VAR onto the stack.
OP_VAR n{arg}, var{symbol}
Returns the value of the n-th local. VAR is given for readability
of diassembled code only.
OP_VARS var{symbol}
Returns the value of the symbol VAR.
OP_PUSHQ value{obj}
Pushes "value"
@ -103,7 +117,10 @@ enum {
OP_PUSH,
OP_PUSHQ,
OP_PUSHV,
OP_PUSHVS,
OP_PUSHVALUES,
OP_VAR,
OP_VARS,
OP_MCALL,
OP_CALL,
OP_FCALL,

2
src/h/config.h.in
View file

@ -44,8 +44,6 @@
#define MAXPAGE 16384 /* Maximum Memory Size */
#define BDSSIZE 2048 /* Size of Binding Stack */
#define BDSGETA 16 /* Safety zone of BDS */
#define IHSSIZE 1024 /* Size of Invocation History Stack */
#define IHSGETA 32 /* Safety zone of IHS */
#define FRSSIZE 1024 /* Size of Frame Stack */
#define FRSGETA 16 /* Safety zone of FRS */
#ifdef THREADS

18
src/h/external.h
View file

@ -193,14 +193,13 @@ extern void check_other_key(cl_object l, int n, ...);
/* compiler.c */
cl_object make_lambda(cl_object name, cl_object lambda);
cl_object eval(cl_object form, cl_object *bytecodes, cl_object env);
extern cl_object make_lambda(cl_object name, cl_object lambda);
extern cl_object eval(cl_object form, cl_object *bytecodes, cl_object env);
/* interpreter.c */
cl_object stack;
cl_object lambda_apply(int narg, cl_object fun, cl_object *args);
cl_object *interpret(cl_object *memory);
extern cl_object lambda_apply(int narg, cl_object fun, cl_object *args);
extern cl_object *interpret(cl_object *memory);
/* conditional.c */
@ -383,7 +382,6 @@ extern void init_let(void);
/* lex.c */
extern void lex_fun_bind(cl_object name, cl_object fun);
extern void lex_macro_bind(cl_object name, cl_object exp_fun);
extern void lex_tag_bind(cl_object tag, cl_object id);
extern void lex_block_bind(cl_object name, cl_object id);
extern cl_object lex_sch(cl_object lex_list, cl_object name, cl_object type);
@ -665,10 +663,7 @@ extern void (*write_ch_fun)();
extern void (*output_ch_fun)();
extern cl_object PRINTpackage;
extern bool PRINTstructure;
extern cl_index CIRCLEsize;
extern cl_object *CIRCLEbase;
extern cl_object *CIRCLEtop;
extern cl_object *CIRCLElimit;
extern cl_fixnum CIRCLEbase;
extern cl_object PRINTstream;
extern void interactive_writec_stream(int c, cl_object stream);
extern void flush_interactive_stream(cl_object stream);
@ -764,9 +759,6 @@ extern void init_sequence(void);
extern void bds_overflow(void) __attribute__((noreturn));
extern void bds_unwind(bds_ptr new_bds_top);
extern void ihs_overflow(void) __attribute__((noreturn));
extern cl_object ihs_function_name(cl_object x);
extern cl_object ihs_top_function_name(void);
extern int frs_overflow(void) __attribute__((noreturn));
extern void unwind(frame_ptr fr, cl_object tag) __attribute__((noreturn));
extern frame_ptr frs_sch(cl_object frame_id);

4
src/h/lisp_external.h
View file

@ -820,9 +820,11 @@ extern cl_object clLnreverse _ARGS((int narg, cl_object x));
/* stacks.c */
extern cl_object Kcatch, Kcatchall, Kprotect;
extern cl_object siLihs_top _ARGS((int narg));
extern cl_object siLihs_top _ARGS((int narg, cl_object arg));
extern cl_object siLihs_fun _ARGS((int narg, cl_object arg));
extern cl_object siLihs_env _ARGS((int narg, cl_object arg));
extern cl_object siLihs_next _ARGS((int narg, cl_object arg));
extern cl_object siLihs_prev _ARGS((int narg, cl_object arg));
extern cl_object siLfrs_top _ARGS((int narg));
extern cl_object siLfrs_bds _ARGS((int narg, cl_object arg));
extern cl_object siLfrs_class _ARGS((int narg, cl_object arg));

5
src/h/lwp.h
View file

@ -92,10 +92,7 @@ typedef struct lpd {
int lwp_intern_flag;
/* print.d */
jmp_buf lwp_CIRCLEjmp;
cl_object *lwp_CIRCLEbase;
cl_object *lwp_CIRCLEtop;
cl_object *lwp_CIRCLElimit;
cl_fixnum lwp_CIRCLEbase;
cl_object lwp_PRINTstream;
bool lwp_PRINTescape;
bool lwp_PRINTpretty;

73
src/h/stacks.h
View file

@ -17,7 +17,19 @@
* INTERPRETER STACK
********************/
extern cl_object stack;
extern cl_index cl_stack_size;
extern cl_object *cl_stack;
extern cl_object *cl_stack_top;
extern cl_object *cl_stack_limit;
extern void cl_stack_push(cl_object o);
extern cl_object cl_stack_pop();
extern cl_index cl_stack_index();
extern void cl_stack_set_index(cl_index sp);
extern void cl_stack_pop_n(cl_index n);
extern void cl_stack_insert(cl_index where, cl_index n);
extern void cl_stack_push_varargs(cl_index n, va_list args);
extern void cl_stack_push_n(cl_index n, cl_object *args);
/**************
* BIND STACK
@ -60,59 +72,11 @@ extern bds_ptr bds_top; /* bind stack top */
* INVOCATION HISTORY STACK
****************************/
typedef struct invocation_history {
cl_object ihs_function;
cl_object ihs_base;
} *ihs_ptr;
cl_index ihs_top;
#ifdef THREADS
#define ihs_size clwp->lwp_ihs_size
#define ihs_org clwp->lwp_ihs_org
#define ihs_limit clwp->lwp_ihs_limit
#define ihs_top clwp->lwp_ihs_top
#else
extern size_t ihs_size;
extern ihs_ptr ihs_org;
extern ihs_ptr ihs_limit;
extern ihs_ptr ihs_top;
#endif
#define ihs_stack ihs_org
#define ihs_check \
if (ihs_top >= ihs_limit) \
ihs_overflow()
#define ihs_push(function, args) { \
(++ihs_top)->ihs_function = (function); \
ihs_top->ihs_base = args; \
}
#define ihs_push_funcall(function) { \
ihs_check; \
(++ihs_top)->ihs_function = (function); \
ihs_top->ihs_base = Cnil; \
}
#define ihs_pop() (ihs_top--)
#define make_nil_block(r) { \
cl_object x; \
lex_copy(); \
x = new_frame_id(); \
lex_block_bind(Cnil, x); \
r = frs_push(FRS_CATCH, x); \
}
#define BLOCK(name,output) { \
cl_object *lex_old = lex_env; lex_dcl; \
cl_object _x; \
lex_copy(); \
_x = new_frame_id(); \
lex_block_bind(name,_x); \
if (frs_push(FRS_CATCH,_x) != 0) output = Values[0]; else
#define END_BLOCK \
frs_pop(); \
lex_env = lex_old; }
extern void ihs_push(cl_object fun, cl_object env);
extern cl_object ihs_top_function_name();
extern void ihs_pop();
/***************
* FRAME STACK
@ -143,7 +107,7 @@ typedef struct frame {
bds_ptr frs_bds_top;
enum fr_class frs_class;
cl_object frs_val;
ihs_ptr frs_ihs;
cl_index frs_ihs;
cl_index frs_sp;
} *frame_ptr;
@ -267,7 +231,6 @@ extern cl_object lex_env;
#define lex_copy() lex_env = CONS(car(lex_env),cdr(lex_env))
#define lex_new() lex_env = CONS(Cnil,Cnil)
#define lex_var_sch(name) assq((name),CAR(lex_env))
#define lex_fun_sch(name) lex_sch(CDR(lex_env),(name),clSfunction)
#define lex_tag_sch(name) lex_sch(CDR(lex_env),(name),clStag)
#define lex_block_sch(name) lex_sch(CDR(lex_env),(name),clSblock)

149
src/lsp/top.lsp
View file

@ -42,7 +42,7 @@
(defvar *break-level* 0) ; nesting level of error loops
(defvar *break-env* nil)
(defvar *ihs-base* 0)
(defvar *ihs-top* 0)
(defvar *ihs-top* (ihs-top 'si::top-level))
(defvar *ihs-current* 0)
(defvar *frs-base* 0)
(defvar *frs-top* 0)
@ -425,7 +425,6 @@ Usage: ecls [-dir dir] [-load file] [-eval expr]
(setq *lisp-initialized* t))
(in-package "CL-USER")
(setq sys::*gc-verbose* t)
(catch *quit-tag*
(let ((*tpl-level* -1))
@ -442,7 +441,7 @@ Usage: ecls [-dir dir] [-load file] [-eval expr]
((:prompt-hook *tpl-prompt-hook*) nil)
(quiet nil))
(let* ((*ihs-base* *ihs-top*)
(*ihs-top* (ihs-top))
(*ihs-top* (ihs-top 'tpl))
(*ihs-current* *ihs-top*)
(*frs-base* (or (sch-frs-base *frs-top* *ihs-base*) (1+ (frs-top))))
(*frs-top* (frs-top))
@ -581,7 +580,7 @@ Usage: ecls [-dir dir] [-load file] [-eval expr]
(tpl-print-current))
(defun tpl-previous (&optional (n 1))
(do ((i (1- *ihs-current*) (1- i)))
(do ((i (si::ihs-prev *ihs-current*) (si::ihs-prev i)))
((or (< i *ihs-base*) (<= n 0)))
(when (ihs-visible i)
(setq *ihs-current* i)
@ -590,7 +589,7 @@ Usage: ecls [-dir dir] [-load file] [-eval expr]
(tpl-print-current))
(defun tpl-next (&optional (n 1))
(do ((i (1+ *ihs-current*) (1+ i)))
(do ((i (si::ihs-next *ihs-current*) (si::ihs-next i)))
((or (> i *ihs-top*) (<= n 0)))
(when (ihs-visible i)
(setq *ihs-current* i)
@ -616,70 +615,24 @@ Usage: ecls [-dir dir] [-load file] [-eval expr]
(*print-pretty* t)
(fun (ihs-fun *ihs-current*))
name args)
(if (and (compiled-function-p fun)
(symbolp (setq name (compiled-function-name fun)))
(setq args (get name 'arglist)))
(progn
#|
(format t
"Local variables:~%")
(do ((args args (cdr args))
(i (ihs-vs *ihs-current*) (1+ i)))
((null args))
(declare (fixnum i))
(format t "~:[~s: ~s~;~s~]~%" no-values (car args) (vs i)))
|#
)
(apply #'format t
"Local variables:~#[~; none~:;~:[ ~1{~s~}~:@{, ~s~}~;~
~:@{~% ~s: ~s~}~]~]~%"
(not no-values) (car *break-env*)))
(apply #'format t
"~#[~:;Local functions: ~@{~s~^, ~}.~%~]"
(format t
"~:[~;Local functions: ~:*~{~s~^, ~}.~%~]"
(mapcan #'(lambda (x) (and (eq (second x) 'FUNCTION) (list (car x))))
(cdr *break-env*)))
(apply #'format t
"~#[~:;Block names: ~@{~s~^, ~}.~%~]"
(format t
"~:[~;Block names: ~:*~{~s~^, ~}.~%~]"
(mapcan #'(lambda (x) (and (eq (second x) 'BLOCK) (list (car x))))
(cdr *break-env*)))
(apply #'format t
"~#[~:;Tags: ~@{~s~^, ~}.~%~]"
(format t
"~:[~;Tags: ~:*~{~s~^, ~}.~%~]"
(mapcan #'(lambda (x) (when (eq (second x) 'TAG) (list (car x))))
(cdr *break-env*)))
(format t
"Local variables:~:[ ~:[none~;~:*~{~s~1*~:@{, ~s~1*~}~}~]~;~
~:[ none~;~:*~{~% ~s: ~s~}~]~]~%"
(not no-values) (car *break-env*)))
(values)))
#|
(defun tpl-vs-command (&optional x)
(let ((min (ihs-vs *ihs-base*))
(max (1- (ihs-vs (1+ *ihs-top*))))
y)
(cond ((integerp x)
(if (and (>= x min) (<= x max))
(vs x)
(format t "Illegal value stack index.~%")))
((null x)
(setq x min)
(setq y max)
(do ((ii *ihs-base* (1+ ii))
(*print-level* 2)
(*print-length* 4)
(*print-pretty* t))
((or (>= ii *ihs-top*) (>= (ihs-vs ii) x))
(do ((vi x (1+ vi)))
((> vi y))
(do ()
((> (ihs-vs ii) vi))
(when (ihs-visible ii)
(print-ihs ii))
(incf ii))
(format t " VS[~d]: ~s~%" vi (vs vi)))))
(values))
(t
(format t "Argument must be a number.~%")
(values)))))
(defun tpl-local-command (&optional (n 0))
(tpl-vs-command (+ (ihs-vs *ihs-current*) n)))
|#
(defun tpl-bds-command (&optional var)
(if var
(do ((bi (1+ (frs-bds (max 0 (1- *frs-base*)))) (1+ bi))
@ -708,23 +661,20 @@ Usage: ecls [-dir dir] [-load file] [-eval expr]
(let ((*print-pretty* nil)) ; because CLOS allows (setf foo)
; as function names
(princ "Backtrace:")
(do ((i *ihs-base* (1+ i))
(do ((i *ihs-top* (si::ihs-prev i))
(b nil t))
((> i *ihs-top*))
((< i *ihs-base*))
(when (ihs-visible i)
(let ((*print-case* (if (= i *ihs-current*) :UPCASE :DOWNCASE)))
(format t "~:[~; >~] ~S" b (ihs-fname i)))))
(terpri))
(let ((from (if (integerp n)
(max (1+ (- *ihs-current* n)) *ihs-base*)
*ihs-base*))
(to (if (integerp n) *ihs-current* *ihs-top*)))
(do ((i from (1+ i))
(j (or (sch-frs-base *frs-base* from) (1+ *frs-top*)))
(*print-level* 2)
(*print-length* 4)
(*print-pretty* t))
((> i to) (values))
(do ((i *ihs-top* (si::ihs-prev i))
(k (if (integerp n) n Cnil) (and k (1- k))))
((= k 0) (values))
(let ((j (or (sch-frs-base *frs-base* i) (1+ *frs-top*)))
(*print-level* 2)
(*print-length* 4)
(*print-pretty* t))
(when (ihs-visible i)
(print-ihs i))
(do () ((or (> j *frs-top*) (> (frs-ihs j) i)))
@ -732,55 +682,10 @@ Usage: ecls [-dir dir] [-load file] [-eval expr]
(incf j)))))
(values))
#|
(defun print-ihs (i)
(format t "~:[ ~;@ ~]IHS[~d]: ~s ---> VS[~d]~%"
(= i *ihs-current*) i
(let ((fun (ihs-fun i)))
(cond ((or (symbolp fun) (compiled-function-p fun)) fun)
((consp fun)
(case (car fun)
(lambda fun)
(lambda-block (cdr fun))
(lambda-closure (cons 'lambda (cddddr fun)))
(lambda-block-closure (cddddr fun))
#+clos
(setf fun)
(t '(:zombi))))
#+clos
((sys:gfunp fun) fun)
(t :zombi)))
(ihs-vs i)))
|#
(defun print-frs (i)
(format *debug-io* " FRS[~d]: ---> IHS[~d],BDS[~d]~%"
i (frs-ihs i) (frs-bds i)))
#|
(defun print-frs (i)
(format *debug-io* "~& FRS[~d]: ~s ---> IHS[~d],VS[~d],BDS[~d]"
i (frs-kind i) (frs-ihs i) (frs-vs i) (frs-bds i)))
(defun frs-kind (i &aux x)
(case (frs-class i)
(:catch
(if (spicep (frs-tag i))
(or (and (setq x (member (frs-tag i) (vs (+ (frs-vs i) 2))
:key #'third :test #'eq))
(if (eq (cadar x) 'block)
`(block ,(caar x) ***)
`(tagbody
,@(reverse
(mapcar #'car (remove (frs-tag i) x :test-not #'eq
:key #'third)))
***)))
`(block/tagbody ,(frs-tag i)))
`(catch ',(frs-tag i) ***)))
(:protect '(unwind-protect ***))
(t `(system-internal-catcher ,(frs-tag i)))))
|#
(defun break-where (&aux (fname (ihs-fname *ihs-current*)))
(if (or (eq fname 'TOP-LEVEL) (eq fname 'BREAK-WHERE))
(format t "Top level.~%")
@ -842,16 +747,16 @@ Usage: ecls [-dir dir] [-load file] [-eval expr]
(t :zombi))))
(defun set-current-ihs ()
(do ((i *ihs-current* (1- i)))
(do ((i *ihs-current* (si::ihs-prev i)))
((or (and (ihs-visible i) (setq *ihs-current* i))
(<= i *ihs-base*))))
(set-break-env))
(defun set-break-env ()
(setq *break-env* (ihs-env *ihs-current*)))
(setq *break-env* (if (= *ihs-current* *ihs-top*) nil (ihs-env *ihs-current*))))
(defun tpl-backward-search (string)
(do ((ihs (1- *ihs-current*) (1- ihs)))
(do ((ihs (si::ihs-prev *ihs-current*) (si::ihs-prev ihs)))
((< ihs *ihs-base*)
(format *debug-io* "Search for ~a failed.~%" string))
(when (and (ihs-visible ihs)
@ -864,7 +769,7 @@ Usage: ecls [-dir dir] [-load file] [-eval expr]
(values))
(defun tpl-forward-search (string)
(do ((ihs (1+ *ihs-current*) (1+ ihs)))
(do ((ihs (si::ihs-next *ihs-current*) (si::ihs-next ihs)))
((> ihs *ihs-top*)
(format *debug-io* "Search for ~a failed.~%" string))
(when (and (ihs-visible ihs)