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

Simplify the bytecodes a bit and add comments describing their use.

Browse source
This commit is contained in:
jjgarcia 2002-10-13 16:57:24 +00:00
parent 3c7fe4535b
commit cd6d1e61ef
5 changed files with 806 additions and 223 deletions
Download patch file Download diff file Expand all files Collapse all files

21
src/c/compiler.d
View file

@ -403,8 +403,9 @@ c_tag_ref(cl_object the_tag, cl_object the_type)
return Ct;
n++;
} else if (Null(name)) {
/* We are counting only locals */
n++;
} else {
/* We are counting only locals and ignore specials */
}
}
return Cnil;
@ -525,9 +526,10 @@ compile_setq(int op, cl_object var)
if (!SYMBOLP(var))
FEillegal_variable_name(var);
ndx = c_var_ref(var);
if (ndx >= 0)
if (ndx >= 0) {
asm_op2(op, ndx); /* Lexical variable */
else if (var->symbol.stype == stp_constant)
return;
} else if (var->symbol.stype == stp_constant)
FEassignment_to_constant(var);
else if (op == OP_SETQ)
asm_op(OP_SETQS); /* Special variable */
@ -1325,16 +1327,17 @@ c_multiple_value_bind(cl_object args)
c_env.variables = old_env;
} else {
cl_object old_variables = c_env.variables;
asm_op2(OP_MBIND, n);
for (vars=reverse(vars); n; n--){
cl_object var = pop(&vars);
if (!SYMBOLP(var))
FEillegal_variable_name(var);
if (c_declared_special(var, specials)) {
asm1(MAKE_FIXNUM(1));
c_register_var(var, TRUE);
} else
asm_op2(OP_VBINDS, n);
} else {
c_register_var(var, FALSE);
asm_op2(OP_VBIND, n);
}
asm1(var);
}
compile_body(body);
@ -1428,11 +1431,10 @@ c_multiple_value_setq(cl_object args) {
FEillegal_variable_name(var);
ndx = c_var_ref(var);
if (ndx >= 0)
asm1(var); /* Lexical variable */
asm1(MAKE_FIXNUM(ndx)); /* Lexical variable */
else if (var->symbol.stype == stp_constant)
FEassignment_to_constant(var);
else {
asm1(MAKE_FIXNUM(1));
asm1(var);
}
}
@ -1805,10 +1807,11 @@ compile_form(cl_object stmt, bool push) {
index = c_var_ref(stmt);
if (index >= 0) {
asm_op2(push? OP_PUSHV : OP_VAR, index);
asm1(stmt);
} else {
asm_op(push? OP_PUSHVS : OP_VARS);
asm1(stmt);
}
asm1(stmt);
goto OUTPUT;
}
QUOTED:

495
src/c/disassembler.d
View file

@ -109,29 +109,55 @@ search_symbol(register cl_object s) {
/* -------------------- DISASSEMBLER CORE -------------------- */
/* OP_BLOCK label{arg}, block-name{symbol}
...
OP_EXIT
label:
Executes the enclosed code in a named block.
LABEL points to the first instruction after OP_EXIT.
*/
static cl_object *
disassemble_block(cl_object *vector) {
cl_object lex_old = lex_env;
cl_fixnum exit = packed_label(vector-1);
cl_object block_name = next_code(vector);
lex_env = listX(3, @':block', CONS(block_name, Cnil), lex_env);
printf("BLOCK\t");
@prin1(1, next_code(vector));
@prin1(1, block_name);
printf(",%d", exit);
vector = disassemble(vector);
printf("\t\t\t; block");
printf("\t\t; block");
lex_env = lex_old;
return vector;
}
/* OP_CATCH label{arg}
...
OP_EXIT
label:
Sets a catch point using the tag in VALUES(0). LABEL points
to the first instruction after the end (OP_EXIT) of the block
*/
static cl_object *
disassemble_catch(cl_object *vector) {
printf("CATCH\t%d", packed_label(vector - 1));
vector = disassemble(vector);
printf("\t\t\t; catch");
printf("\t\t; catch");
return vector;
}
/* OP_DO label
... ; code executed within a NIL block
OP_EXIT
label:
High level construct for the DO and BLOCK forms.
*/
static cl_object *
disassemble_do(cl_object *vector) {
cl_fixnum exit;
@ -141,12 +167,24 @@ disassemble_do(cl_object *vector) {
exit = packed_label(vector-1);
printf("DO\t%d", exit);
vector = disassemble(vector);
printf("\t\t\t; do");
printf("\t\t; do");
lex_env = lex_old;
return vector;
}
/* OP_DOLIST label
... ; code to bind the local variable
OP_EXIT
... ; code executed on each iteration
OP_EXIT
... ; code executed at the end
OP_EXIT
label:
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;
@ -156,16 +194,28 @@ disassemble_dolist(cl_object *vector) {
exit = packed_label(vector-1);
printf("DOLIST\t%d", exit);
vector = disassemble(vector);
printf("\t\t\t; dolist binding");
printf("\t\t; dolist binding");
vector = disassemble(vector);
printf("\t\t\t; dolist body");
printf("\t\t; dolist body");
vector = disassemble(vector);
printf("\t\t\t; dolist");
printf("\t\t; dolist");
lex_env = lex_old;
return vector;
}
/* OP_TIMES label
... ; code to bind the local variable
OP_EXIT
... ; code executed on each iteration
OP_EXIT
... ; code executed at the end
OP_EXIT
label:
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;
@ -175,16 +225,26 @@ disassemble_dotimes(cl_object *vector) {
exit = packed_label(vector-1);
printf("DOTIMES\t%d", exit);
vector = disassemble(vector);
printf("\t\t\t; dotimes times");
printf("\t\t; dotimes times");
vector = disassemble(vector);
printf("\t\t\t; dotimes body");
printf("\t\t; dotimes body");
vector = disassemble(vector);
printf("\t\t\t; dotimes");
printf("\t\t; dotimes");
lex_env = lex_old;
return vector;
}
/* OP_FLET nfun{arg}
fun1{object}
...
funn{object}
...
OP_EXIT
Executes the enclosed code in a lexical enviroment extended with
the functions "fun1" ... "funn".
*/
static cl_object *
disassemble_flet(cl_object *vector) {
cl_object lex_old = lex_env;
@ -199,12 +259,22 @@ disassemble_flet(cl_object *vector) {
@prin1(1, fun->bytecodes.data[0]);
}
vector = disassemble(vector);
printf("\t\t\t; flet");
printf("\t\t; flet");
lex_env = lex_old;
return vector;
}
/* OP_LABELS nfun{arg}
fun1{object}
...
funn{object}
...
OP_EXIT
Executes the enclosed code in a lexical enviroment extended with
the functions "fun1" ... "funn".
*/
static cl_object *
disassemble_labels(cl_object *vector) {
cl_object lex_old = lex_env;
@ -219,45 +289,52 @@ disassemble_labels(cl_object *vector) {
@prin1(1, fun->bytecodes.data[0]);
}
vector = disassemble(vector);
printf("\t\t\t; labels");
printf("\t\t; labels");
lex_env = lex_old;
return vector;
}
/* OP_MCALL
...
OP_EXIT
Saves the stack pointer, executes the enclosed code and
funcalls VALUE(0) using the content of the stack.
*/
static cl_object *
disassemble_mbind(cl_object *vector)
{
int i = get_oparg(vector[-1]);
bool newline = FALSE;
while (i--) {
cl_object var = next_code(vector);
if (newline) {
@terpri(0);
printf("\t");
} else
newline = TRUE;
if (var == MAKE_FIXNUM(1)) {
printf("MBINDS\t");
var = next_code(vector);
} else {
printf("MBIND\t");
}
@prin1(1, var);
printf(", VALUES(%d)", i);
}
disassemble_mcall(cl_object *vector) {
printf("MCALL");
vector = disassemble(vector);
printf("\t\t; mcall");
return vector;
}
/* OP_PROG1
...
OP_EXIT
Save the values in VALUES(..), execute the code enclosed, and
restore the values.
*/
static cl_object *
disassemble_mprog1(cl_object *vector) {
printf("MPROG1");
vector = disassemble(vector);
printf("\t\t\t; mprog1");
printf("\t\t; mprog1");
return vector;
}
/* OP_MSETQ n{arg}
{fixnumn}|{symboln}
...
{fixnum1}|{symbol1}
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.
*/
static cl_object *
disassemble_msetq(cl_object *vector)
{
@ -270,36 +347,46 @@ disassemble_msetq(cl_object *vector)
printf("\t");
} else
newline = TRUE;
if (var == MAKE_FIXNUM(1)) {
printf("MSETQS\t");
var = next_code(vector);
if (FIXNUMP(var)) {
printf("MSETQ\t%d", fix(var));
} else {
printf("MSETQ\t");
printf("MSETQS\t");
@prin1(1, var);
}
@prin1(1, var);
printf(", VALUES(%d)", i);
}
return vector;
}
/* OP_PROGV bindings{list}
...
OP_EXIT
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) {
printf("PROGV");
vector = disassemble(vector);
printf("\t\t\t; progv");
printf("\t\t; progv");
return vector;
}
/* OP_TAGBODY n-tags
tag1 addr1
tag2 addr2
... ...
tagn addrn
{form}*
OP_EXIT
*/
/* OP_TAGBODY n{arg}
tag1
label1
...
tagn
labeln
label1:
...
labeln:
...
OP_EXIT
High level construct for the TAGBODY form.
*/
static cl_object *
disassemble_tagbody(cl_object *vector) {
cl_index i, ntags = get_oparg(vector[-1]);
@ -313,12 +400,24 @@ disassemble_tagbody(cl_object *vector) {
printf(" @@ %d", simple_label(vector));
}
vector = disassemble(vector);
printf("\t\t\t; tagbody");
printf("\t\t; tagbody");
lex_env = lex_old;
return vector;
}
/* OP_UNWIND label
... ; code to be protected and whose value is output
OP_EXIT
label:
... ; code executed at exit
OP_EXIT
High level construct for UNWIND-PROTECT. The first piece of code
is executed and its output value is saved. Then the second piece
of code is executed and the output values restored. The second
piece of code is always executed, even if a THROW, RETURN or GO
happen within the first piece of code.
*/
static cl_object *
disassemble_unwind_protect(cl_object *vector) {
cl_fixnum exit = packed_label(vector-1);
@ -326,7 +425,7 @@ disassemble_unwind_protect(cl_object *vector) {
printf("PROTECT\t%d", exit);
vector = disassemble(vector);
vector = disassemble(vector);
printf("\t\t\t; protect");
printf("\t\t; protect");
return vector;
}
@ -352,106 +451,302 @@ disassemble(cl_object *vector) {
goto BEGIN;
}
switch (GET_OP(s)) {
case OP_PUSHQ: printf("PUSH\t'");
@prin1(1,next_code(vector));
break;
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";
QUOTE: s = next_code(vector);
goto ARG;
/* 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);
goto ARG;
/* OP_VAR n{arg}, var{symbol}
Sets NValues=1 and VALUES(0) to the value of the n-th local.
VAR is the name of the variable for readability purposes.
*/
case OP_VAR: string = "VAR\t";
n = get_oparg(s);
s = next_code(vector);
goto OPARG_ARG;
/* OP_VARS var{symbol}
Sets NValues=1 and VALUES(0) to the value of the symbol VAR.
VAR should be either a special variable or a constant.
*/
case OP_VARS: string = "VARS\t";
s = next_code(vector);
goto ARG;
/* OP_PUSH
Pushes the object in VALUES(0).
*/
case OP_PUSH: string = "PUSH\tVALUES(0)";
goto NOARG;
/* OP_PUSHV n{arg}, var{symbol}
Pushes the value of the n-th local onto the stack.
VAR is the name of the variable for readability purposes.
*/
case OP_PUSHV: string = "PUSHV\t";
n = get_oparg(s);
s = next_code(vector);
goto OPARG_ARG;
/* OP_PUSHVS var{symbol}
Pushes the value of the symbol VAR onto the stack.
VAR should be either a special variable or a constant.
*/
case OP_PUSHVS: string = "PUSHVS\t";
s = next_code(vector);
goto ARG;
/* OP_PUSHQ value{object}
Pushes "value" onto the stack.
*/
case OP_PUSHQ: string = "PUSH\t'";
s = next_code(vector);
goto ARG;
/* OP_PUSHVALUES
Pushes the values output by the last form.
*/
case OP_PUSHVALUES: string = "PUSH\tVALUES";
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_CALL: string = "CALL";
/* OP_CALL n{arg}, function-name{symbol}
Calls the local or global function with N arguments
which have been deposited in the stack. The output
value is kept in VALUES(...)
*/
case OP_CALL: string = "CALL\t";
n = get_oparg(s);
s = next_code(vector);
goto OPARG_ARG;
case OP_PCALL: string = "PCALL";
/* 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;
case OP_CALLG: string = "FCALL";
/* OP_FCALL 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_FCALL: string = "FCALL\t";
n = get_oparg(s);
goto OPARG;
case OP_PCALLG: string = "PFCALL";
n = get_oparg(s);
goto OPARG;
case OP_FCALL: string = "FCALL";
n = get_oparg(s);
goto OPARG;
case OP_PFCALL: string = "PFCALL";
/* OP_PCALL n{arg}, function-name{symbol}
Calls the local or global function with N arguments
which have been deposited in the stack. The first
output value is pushed onto the stack.
*/
case OP_PCALL: string = "PCALL\t";
n = get_oparg(s);
s = next_code(vector);
goto OPARG_ARG;
/* 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_PFCALL 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_PFCALL: string = "PFCALL\t";
n = get_oparg(s);
goto OPARG;
case OP_MCALL: vector = disassemble_mcall(vector);
break;
case OP_CATCH: vector = disassemble_catch(vector);
break;
/* OP_EXIT
Marks the end of a high level construct (BLOCK, CATCH...)
*/
case OP_EXIT: printf("EXIT");
return vector;
/* OP_HALT
Marks the end of a function.
*/
case OP_HALT: printf("HALT");
return vector-1;
case OP_FLET: vector = disassemble_flet(vector);
break;
case OP_LABELS: vector = disassemble_labels(vector);
break;
case OP_FUNCTION: string = "SYMFUNC";
/* OP_FUNCTION name{symbol}
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_FUNCTION: string = "SYMFUNC\t";
s = next_code(vector);
goto ARG;
case OP_CLOSE: string = "CLOSE";
/* OP_CLOSE name{symbol}
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);
goto ARG;
case OP_GO: string = "GO";
/* OP_GO n{arg}, 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);
goto ARG;
goto OPARG_ARG;
/* OP_RETURN block-name{symbol}
Returns from the block whose name is BLOCK-NAME.
*/
case OP_RETURN: string = "RETFROM";
s = next_code(vector);
goto ARG;
case OP_THROW: string = "THROW"; goto NOARG;
case OP_JMP: string = "JMP";
/* OP_THROW
Jumps to an enclosing CATCH form whose tag matches the one
of the THROW. The tag is taken from the stack, while the
output values are left in VALUES(...).
*/
case OP_THROW: string = "THROW";
goto NOARG;
/* OP_JMP label{arg}
OP_JNIL label{arg}
OP_JT label{arg}
OP_JEQ label{arg}, value{object}
OP_JNEQ label{arg}, value{object}
Direct or conditional jumps. The conditional jumps are made
comparing with the value of VALUES(0).
*/
case OP_JMP: string = "JMP\t";
n = packed_label(vector-1);
goto OPARG;
case OP_JNIL: string = "JNIL";
case OP_JNIL: string = "JNIL\t";
n = packed_label(vector-1);
goto OPARG;
case OP_JT: string = "JT";
case OP_JT: string = "JT\t";
n = packed_label(vector-1);
goto OPARG;
case OP_JEQ: string = "JEQ";
case OP_JEQ: string = "JEQ\t";
s = next_code(vector);
n = packed_label(vector-2);
goto OPARG_ARG;
case OP_JNEQ: string = "JNEQ";
case OP_JNEQ: string = "JNEQ\t";
s = next_code(vector);
n = packed_label(vector-2);
goto OPARG_ARG;
case OP_UNBIND: string = "UNBIND"; n = get_oparg(s); goto OPARG;
case OP_UNBINDS: string = "UNBINDS"; n = get_oparg(s); goto OPARG;
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 QUOTE;
case OP_SETQ: string = "SETQ";
SETQ: s = next_code(vector);
/* OP_UNBIND n{arg}
Undo "n" bindings of lexical variables.
*/
case OP_UNBIND: string = "UNBIND\t";
n = get_oparg(s);
goto OPARG;
/* OP_UNBINDS n{arg}
Undo "n" bindings of special variables.
*/
case OP_UNBINDS: string = "UNBINDS\t";
n = get_oparg(s);
goto OPARG;
/* OP_BIND name{symbol}
OP_PBIND name{symbol}
OP_BINDS name{symbol}
OP_PBINDS name{symbol}
Binds a lexical or special variable to the either the
value of VALUES(0), to the first value of the stack, or
to the n-th value of VALUES(...).
*/
case OP_BIND: string = "BIND\t";
s = next_code(vector);
goto ARG;
case OP_SETQS: string = "SETQS"; goto QUOTE;
case OP_PBIND: string = "PBIND\t";
s = next_code(vector);
goto ARG;
case OP_VBIND: string = "VBIND\t";
s = next_code(vector);
goto ARG;
case OP_BINDS: string = "BINDS\t";
s = next_code(vector);
goto ARG;
case OP_PBINDS: string = "PBINDS\t";
s = next_code(vector);
goto ARG;
case OP_VBINDS: string = "VBINDS\t";
s = next_code(vector);
goto ARG;
/* OP_SETQ n{arg}
OP_PSETQ n{arg}
OP_SETQS var-name{symbol}
OP_PSETQS var-name{symbol}
Sets either the n-th local or a special variable VAR-NAME,
to either the value in VALUES(0) (OP_SETQ[S]) or to the
first value on the stack (OP_PSETQ[S]).
*/
case OP_SETQ: string = "SETQ\t";
n = get_oparg(s);
goto OPARG;
case OP_PSETQ: string = "PSETQ\t";
n = get_oparg(s);
goto OPARG;
case OP_SETQS: string = "SETQS";
s = next_code(vector);
goto ARG;
case OP_PSETQS: string = "PSETQS";
s = next_code(vector);
goto ARG;
case OP_MSETQ: vector = disassemble_msetq(vector);
break;
case OP_MBIND: vector = disassemble_mbind(vector);
break;
case OP_MPROG1: vector = disassemble_mprog1(vector);
break;
case OP_PROGV: vector = disassemble_progv(vector);
break;
case OP_VALUES: string = "VALUES";
/* 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);
goto OPARG;
case OP_NTHVAL: string = "NTHVAL"; goto NOARG;
/* OP_NTHVAL
Set VALUES(0) to the N-th value of the VALUES(...) list.
The index N-th is extracted from the top of the stack.
*/
case OP_NTHVAL: string = "NTHVAL\t";
goto NOARG;
case OP_DOLIST: vector = disassemble_dolist(vector);
break;
case OP_DOTIMES: vector = disassemble_dotimes(vector);
@ -467,12 +762,12 @@ disassemble(cl_object *vector) {
return vector;
NOARG: printf(string);
break;
ARG: printf("%s\t", string);
ARG: printf(string);
@prin1(1, s);
break;
OPARG: printf("%s\t%d", string, n);
OPARG: printf("%s%d", string, n);
break;
OPARG_ARG: printf("%s\t%d,", string, n);
OPARG_ARG: printf("%s%d,", string, n);
@prin1(1, s);
break;
}

473
src/c/interpreter.d
View file

@ -141,21 +141,19 @@ bind_special(register cl_object var, register cl_object val)
static cl_object
search_local(register cl_object name, register int s) {
cl_object x;
for (x = lex_env; s-- && !Null(x); x = CDDR(x));
for (x = lex_env; s-- > 0 && !Null(x); x = CDDR(x));
if (Null(x) || CAR(x) != name)
FEerror("Internal error: local not found.", 0);
FEerror("Internal error: local not found.", 0);
return CADR(x);
}
static void
setq_local(register cl_object s, register cl_object v) {
setq_local(register int s, register cl_object v) {
cl_object x;
for (x = lex_env; CONSP(x); x = CDDR(x))
if (CAR(x) == s) {
CADR(x) = v;
return;
}
FEerror("Internal error: local ~S not found.", 1, s);
for (x = lex_env; s-- > 0 && !Null(x); x = CDDR(x));
if (Null(x))
FEerror("Internal error: local ~S not found.", 1, s);
CADR(x) = v;
}
static cl_object
@ -491,6 +489,14 @@ interpret_funcall(int narg, cl_object fun) {
/* -------------------- THE INTERPRETER -------------------- */
/* OP_BLOCK label{arg}, block-name{symbol}
...
OP_EXIT
label:
Executes the enclosed code in a named block.
LABEL points to the first instruction after OP_EXIT.
*/
static cl_object *
interpret_block(cl_object *vector) {
cl_object * volatile exit, name;
@ -511,6 +517,8 @@ interpret_block(cl_object *vector) {
return exit;
}
static cl_object *
interpret_catch(cl_object *vector) {
cl_object * volatile exit;
@ -521,6 +529,20 @@ interpret_catch(cl_object *vector) {
return exit;
}
/* OP_TAGBODY n{arg}
tag1
label1
...
tagn
labeln
label1:
...
labeln:
...
OP_EXIT
High level construct for the TAGBODY form.
*/
static cl_object *
interpret_tagbody(cl_object *vector) {
cl_index i, ntags = get_oparg(vector[-1]);
@ -551,6 +573,18 @@ interpret_tagbody(cl_object *vector) {
return vector;
}
/* OP_UNWIND label
... ; code to be protected and whose value is output
OP_EXIT
label:
... ; code executed at exit
OP_EXIT
High level construct for UNWIND-PROTECT. The first piece of code
is executed and its output value is saved. Then the second piece
of code is executed and the output values restored. The second
piece of code is always executed, even if a THROW, RETURN or GO
happen within the first piece of code.
*/
static cl_object *
interpret_unwind_protect(cl_object *vector) {
volatile int nr;
@ -574,6 +608,13 @@ interpret_unwind_protect(cl_object *vector) {
return exit;
}
/* OP_DO label
... ; code executed within a NIL block
OP_EXIT
label:
High level construct for the DO and BLOCK forms.
*/
static cl_object *
interpret_do(cl_object *vector) {
cl_object *volatile exit;
@ -596,6 +637,18 @@ interpret_do(cl_object *vector) {
return exit;
}
/* OP_DOLIST label
... ; code to bind the local variable
OP_EXIT
... ; code executed on each iteration
OP_EXIT
... ; code executed at the end
OP_EXIT
label:
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 *output, *volatile exit;
@ -635,6 +688,18 @@ interpret_dolist(cl_object *vector) {
return exit;
}
/* OP_TIMES label
... ; code to bind the local variable
OP_EXIT
... ; code executed on each iteration
OP_EXIT
... ; code executed at the end
OP_EXIT
label:
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 *output, *volatile exit;
@ -680,6 +745,16 @@ close_around(cl_object fun, cl_object lex) {
return v;
}
/* OP_FLET nfun{arg}
fun1{object}
...
funn{object}
...
OP_EXIT
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]);
@ -697,6 +772,16 @@ interpret_flet(cl_object *vector) {
return vector;
}
/* OP_FLET nfun{arg}
fun1{object}
...
funn{object}
...
OP_EXIT
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]);
@ -717,21 +802,13 @@ interpret_labels(cl_object *vector) {
return vector;
}
static cl_object *
interpret_mbind(cl_object *vector)
{
int i = get_oparg(vector[-1]);
while (i--) {
cl_object var = next_code(vector);
cl_object value = (i < NValues) ? VALUES(i) : Cnil;
if (var == MAKE_FIXNUM(1))
bind_special(next_code(vector), value);
else
bind_var(var, value);
}
return vector;
}
/* OP_MCALL
...
OP_EXIT
Saves the stack pointer, executes the enclosed code and
funcalls VALUE(0) using the content of the stack.
*/
static cl_object *
interpret_mcall(cl_object *vector) {
cl_index sp = cl_stack_index();
@ -740,6 +817,13 @@ interpret_mcall(cl_object *vector) {
return vector;
}
/* OP_PROG1
...
OP_EXIT
Save the values in VALUES(..), execute the code enclosed, and
restore the values.
*/
static cl_object *
interpret_mprog1(cl_object *vector) {
cl_index i,n = NValues;
@ -754,6 +838,16 @@ interpret_mprog1(cl_object *vector) {
return vector;
}
/* OP_MSETQ n{arg}
{fixnumn}|{symboln}
...
{fixnum1}|{symbol1}
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.
*/
static cl_object *
interpret_msetq(cl_object *vector)
{
@ -762,10 +856,9 @@ interpret_msetq(cl_object *vector)
while (i--) {
var = next_code(vector);
value = (i < NValues) ? VALUES(i) : Cnil;
if (var != MAKE_FIXNUM(1))
setq_local(var, value);
if (FIXNUMP(var))
setq_local(fix(var), value);
else {
var = next_code(vector);
if (var->symbol.stype == stp_constant)
FEassignment_to_constant(var);
else
@ -776,6 +869,12 @@ interpret_msetq(cl_object *vector)
return vector;
}
/* OP_PROGV bindings{list}
...
OP_EXIT
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) {
cl_object values = VALUES(0);
@ -818,59 +917,110 @@ interpret(cl_object *vector) {
goto BEGIN;
}
switch (GET_OP(s)) {
case OP_PUSHQ:
cl_stack_push(next_code(vector));
break;
case OP_PUSH:
cl_stack_push(VALUES(0));
break;
case OP_PUSHV:
cl_stack_push(search_local(next_code(vector), get_oparg(s)));
break;
case OP_PUSHVS:
cl_stack_push(search_global(next_code(vector)));
break;
case OP_VAR:
VALUES(0) = search_local(next_code(vector), get_oparg(s));
NValues = 1;
break;
case OP_VARS:
VALUES(0) = search_global(next_code(vector));
NValues = 1;
break;
case OP_QUOTE:
VALUES(0) = next_code(vector);
NValues = 1;
break;
/* OP_NOP
Sets VALUES(0) = NIL and NValues = 1
*/
case OP_NOP:
VALUES(0) = Cnil;
NValues = 0;
break;
case OP_BLOCK:
vector = interpret_block(vector);
/* OP_QUOTE
Sets VALUES(0) to an immediate value.
*/
case OP_QUOTE:
VALUES(0) = next_code(vector);
NValues = 1;
break;
/* OP_VAR n{arg}, var{symbol}
Sets NValues=1 and VALUES(0) to the value of the n-th local.
VAR is the name of the variable for readability purposes.
*/
case OP_VAR: {
int lex_env_index = get_oparg(s);
cl_object var_name = next_code(vector);
VALUES(0) = search_local(var_name, lex_env_index);
NValues = 1;
break;
}
/* OP_VARS var{symbol}
Sets NValues=1 and VALUES(0) to the value of the symbol VAR.
VAR should be either a special variable or a constant.
*/
case OP_VARS: {
cl_object var_name = next_code(vector);
VALUES(0) = search_global(var_name);
NValues = 1;
break;
}
/* OP_PUSH
Pushes the object in VALUES(0).
*/
case OP_PUSH:
cl_stack_push(VALUES(0));
break;
/* OP_PUSHV n{arg}, var{symbol}
Pushes the value of the n-th local onto the stack.
VAR is the name of the variable for readability purposes.
*/
case OP_PUSHV: {
int lex_env_index = get_oparg(s);
cl_object var_name = next_code(vector);
cl_stack_push(search_local(var_name, lex_env_index));
break;
}
/* OP_PUSHVS var{symbol}
Pushes the value of the symbol VAR onto the stack.
VAR should be either a special variable or a constant.
*/
case OP_PUSHVS: {
cl_object var_name = next_code(vector);
cl_stack_push(search_global(var_name));
break;
}
/* OP_PUSHQ value{object}
Pushes "value" onto the stack.
*/
case OP_PUSHQ:
cl_stack_push(next_code(vector));
break;
/* OP_PUSHVALUES
Pushes the values output by the last form.
*/
case OP_PUSHVALUES: {
int i;
for (i=0; i<NValues; i++)
cl_stack_push(VALUES(i));
break;
}
case OP_MCALL:
vector = interpret_mcall(vector);
case OP_BLOCK:
vector = interpret_block(vector);
break;
/* OP_CALL n{arg}, function-name{symbol}
Calls the local or global function with N arguments
which have been deposited in the stack.
*/
case OP_CALL: {
cl_fixnum n = get_oparg(s);
cl_object name = next_code(vector);
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);
cl_stack_push(VALUES(0));
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);
@ -879,12 +1029,37 @@ interpret(cl_object *vector) {
VALUES(0) = interpret_funcall(n, fun->symbol.gfdef);
break;
}
/* OP_FCALL 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_FCALL: {
cl_fixnum n = get_oparg(s);
cl_object fun = VALUES(0);
VALUES(0) = interpret_funcall(n, fun);
break;
}
/* OP_PCALL n{arg}, function-name{symbol}
Calls the local or global function with N arguments
which have been deposited in the stack. The first
output value is pushed onto the stack.
*/
case OP_PCALL: {
cl_fixnum n = get_oparg(s);
cl_object name = next_code(vector);
VALUES(0) = interpret_call(n, name);
cl_stack_push(VALUES(0));
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);
@ -894,6 +1069,12 @@ interpret(cl_object *vector) {
cl_stack_push(VALUES(0));
break;
}
/* OP_PFCALL 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_PFCALL: {
cl_fixnum n = get_oparg(s);
cl_object fun = VALUES(0);
@ -901,11 +1082,23 @@ interpret(cl_object *vector) {
cl_stack_push(VALUES(0));
break;
}
case OP_MCALL:
vector = interpret_mcall(vector);
break;
case OP_CATCH:
vector = interpret_catch(vector);
break;
/* OP_EXIT
Marks the end of a high level construct (BLOCK, CATCH...)
*/
case OP_EXIT:
return vector;
/* OP_HALT
Marks the end of a function.
*/
case OP_HALT:
return vector-1;
case OP_FLET:
@ -914,33 +1107,71 @@ interpret(cl_object *vector) {
case OP_LABELS:
vector = interpret_labels(vector);
break;
case OP_FUNCTION:
VALUES(0) = search_symbol_function(next_code(vector));
/* OP_FUNCTION name{symbol}
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_FUNCTION: {
cl_object function_name = next_code(vector);
VALUES(0) = search_symbol_function(function_name);
NValues = 1;
break;
case OP_CLOSE:
VALUES(0) = close_around(next_code(vector), lex_env);
}
/* OP_CLOSE name{symbol}
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: {
cl_object function_object = next_code(vector);
VALUES(0) = close_around(function_object, lex_env);
NValues = 1;
break;
}
/* OP_GO n{arg}, 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 = next_code(vector);
cl_object tag_name = next_code(vector);
cl_object id = search_local(@':tag',get_oparg(s));
VALUES(0) = Cnil;
NValues = 0;
cl_go(id, tag);
cl_go(id, tag_name);
break;
}
/* OP_RETURN block-name{symbol}
Returns from the block whose name is BLOCK-NAME.
*/
case OP_RETURN: {
cl_object tag = next_code(vector);
cl_object id = search_tag(tag, @':block');
cl_object block_name = next_code(vector);
cl_object id = search_tag(block_name, @':block');
if (Null(id))
FEcontrol_error("RETURN-FROM: Unknown block ~S.", 1, tag);
cl_return_from(id, tag);
FEcontrol_error("RETURN-FROM: Unknown block ~S.", 1, block_name);
cl_return_from(id, block_name);
break;
}
case OP_THROW:
cl_throw(cl_stack_pop());
/* OP_THROW
Jumps to an enclosing CATCH form whose tag matches the one
of the THROW. The tag is taken from the stack, while the
output values are left in VALUES(...).
*/
case OP_THROW: {
cl_object tag_name = cl_stack_pop();
cl_throw(tag_name);
break;
}
/* OP_JMP label{arg}
OP_JNIL label{arg}
OP_JT label{arg}
OP_JEQ label{arg}, value{object}
OP_JNEQ label{arg}, value{object}
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);
break;
@ -960,24 +1191,81 @@ interpret(cl_object *vector) {
if (VALUES(0) != next_code(vector))
vector = vector + get_oparg(s) - 2;
break;
/* OP_UNBIND n{arg}
Undo "n" local bindings.
*/
case OP_UNBIND: {
cl_index n = get_oparg(s);
while (n--)
lex_env = CDDR(lex_env);
break;
}
case OP_UNBINDS:
bds_unwind(bds_top - get_oparg(s));
/* OP_UNBINDS n{arg}
Undo "n" bindings of special variables.
*/
case OP_UNBINDS: {
cl_index n = get_oparg(s);
bds_unwind_n(n);
break;
case OP_BIND:
bind_var(next_code(vector), VALUES(0));
}
/* OP_BIND name{symbol}
OP_PBIND name{symbol}
OP_BINDS name{symbol}
OP_PBINDS name{symbol}
Binds a lexical or special variable to the either the
value of VALUES(0) or the first value of the stack.
*/
case OP_BIND: {
cl_object var_name = next_code(vector);
cl_object value = VALUES(0);
bind_var(var_name, value);
break;
case OP_BINDS:
bind_special(next_code(vector), VALUES(0));
}
case OP_PBIND: {
cl_object var_name = next_code(vector);
cl_object value = cl_stack_pop();
bind_var(var_name, value);
break;
case OP_SETQ:
setq_local(next_code(vector), VALUES(0));
}
case OP_VBIND: {
int n = get_oparg(s);
cl_object var_name = next_code(vector);
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 value = VALUES(0);
bind_special(var_name, value);
break;
}
case OP_PBINDS: {
cl_object var_name = next_code(vector);
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);
cl_object value = (--n < NValues) ? VALUES(n) : Cnil;
bind_special(var_name, value);
break;
}
/* OP_SETQ n{arg}
OP_PSETQ n{arg}
OP_SETQS var-name{symbol}
OP_PSETQS var-name{symbol}
Sets either the n-th local or a special variable VAR-NAME,
to either the value in VALUES(0) (OP_SETQ[S]) or to the
first value on the stack (OP_PSETQ[S]).
*/
case OP_SETQ: {
int lex_env_index = get_oparg(s);
setq_local(lex_env_index, VALUES(0));
break;
}
case OP_SETQS: {
cl_object var = next_code(vector);
if (var->symbol.stype == stp_constant)
@ -986,17 +1274,13 @@ interpret(cl_object *vector) {
SYM_VAL(var) = VALUES(0);
break;
}
case OP_PBIND:
bind_var(next_code(vector), cl_stack_pop());
break;
case OP_PBINDS:
bind_special(next_code(vector), cl_stack_pop());
break;
case OP_PSETQ:
setq_local(next_code(vector), cl_stack_pop());
case OP_PSETQ: {
int lex_env_index = get_oparg(s);
setq_local(lex_env_index, cl_stack_pop());
Values[0] = Cnil;
NValues = 1;
break;
}
case OP_PSETQS: {
cl_object var = next_code(vector);
if (var->symbol.stype == stp_constant)
@ -1010,15 +1294,16 @@ interpret(cl_object *vector) {
case OP_MSETQ:
vector = interpret_msetq(vector);
break;
case OP_MBIND:
vector = interpret_mbind(vector);
break;
case OP_MPROG1:
vector = interpret_mprog1(vector);
break;
case OP_PROGV:
vector = interpret_progv(vector);
break;
/* OP_VALUES n{arg}
Pop N values from the stack and store them in VALUES(...)
*/
case OP_VALUES: {
cl_fixnum n = get_oparg(s);
NValues = n;
@ -1026,6 +1311,10 @@ interpret(cl_object *vector) {
VALUES(--n) = cl_stack_pop();
break;
}
/* OP_NTHVAL
Set VALUES(0) to the N-th value of the VALUES(...) list.
The index N-th is extracted from the top of the stack.
*/
case OP_NTHVAL: {
cl_fixnum n = fix(cl_stack_pop());
if (n < 0 || n >= NValues)

17
src/h/bytecodes.h
View file

@ -17,21 +17,21 @@
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_VAR n{arg}
Returns the value of the n-th local.
OP_VARS var{symbol}
Returns the value of the symbol VAR.
OP_PUSHQ value{obj}
Pushes "value"
Pushes "value" onto the stack.
OP_PUSHV var{symbol}
Pushes the value of the variable "var"
OP_PUSHV n{arg}, var{symbol}
Pushes the value of the n-th local. The name of the variable is
kept for readability purposes.
OP_PUSHVALUES
Pushes the values output by the last form
Pushes the values output by the last form.
OP_MCALL
...
@ -149,9 +149,10 @@ enum {
OP_PBINDS,
OP_PSETQ,
OP_PSETQS,
OP_VBIND,
OP_VBINDS,
OP_UNBIND,
OP_UNBINDS,
OP_MBIND,
OP_MSETQ,
OP_PROGV,
OP_VALUES,

23
src/h/stacks.h
View file

@ -211,23 +211,18 @@ extern cl_object Values[VSSIZE];
* LEXICAL ENVIRONMENT STACK
*****************************/
/*
|---------------|
lex_env ------> | lex-var | : lex_env[0]
|---------------|
| lex-fd | : lex_env[1]
|---------------|
| lex-tag | : lex_env[2]
|---------------|
lex-var: (symbol value) ; for local binding
or (symbol) ; for special binding
lex-fd: (fun-name 'FUNCTION' function)
or (macro-name 'MACRO' expansion-function)
lex_env ------> ( tag0 value0 tag1 value1 ... )
lex-tag: (tag 'TAG' frame-id)
or (block-name 'BLOCK' frame-id)
tag: variable-name (symbol)
value: variable-value (any lisp object)
tag: :function
value: (function-name . function-object)
tag: :block
value: (block-name . frame-id)
where 'FUN' is the LISP symbol with pname FUN, etc.
*/
#ifdef THREADS