#define VARIABLE_USED 0x0001
#define VARIABLE_ARGUMENT 0x0002
static void ComPredicate(LispCom*, LispBuiltin*, LispBytePredicate);
static void ComReturnFrom(LispCom*, LispBuiltin*, int);
static int ComConstantp(LispCom*, LispObj*);
static void ComAddVariable(LispCom*, LispObj*, LispObj*);
static int ComGetVariable(LispCom*, LispObj*);
static void ComVariableSetFlag(LispCom*, LispAtom*, int);
#define COM_VARIABLE_USED(atom) \
ComVariableSetFlag(com, atom, VARIABLE_USED)
#define COM_VARIABLE_ARGUMENT(atom) \
ComVariableSetFlag(com, atom, VARIABLE_ARGUMENT)
static int FindIndex(void*, void**, int);
static int compare(const void*, const void*);
static int BuildTablePointer(void*, void***, int*);
static void ComLabel(LispCom*, LispObj*);
static void ComPush(LispCom*, LispObj*, LispObj*, int, int, int);
static int ComCall(LispCom*, LispArgList*, LispObj*, LispObj*, int, int, int);
static void ComFuncall(LispCom*, LispObj*, LispObj*, int);
static void ComProgn(LispCom*, LispObj*);
static void ComEval(LispCom*, LispObj*);
static void ComRecursiveCall(LispCom*, LispArgList*, LispObj*, LispObj*);
static void ComInlineCall(LispCom*, LispArgList*, LispObj*, LispObj*, LispObj*);
static void ComMacroBackquote(LispCom*, LispObj*);
static void ComMacroCall(LispCom*, LispArgList*, LispObj*, LispObj*, LispObj*);
static LispObj *ComMacroExpandBackquote(LispCom*, LispObj*);
static LispObj *ComMacroExpand(LispCom*, LispObj*);
static LispObj *ComMacroExpandFuncall(LispCom*, LispObj*, LispObj*);
static LispObj *ComMacroExpandEval(LispCom*, LispObj*);
void
Com_And(LispCom *com, LispBuiltin *builtin)
{
LispObj *args;
args = ARGUMENT(0);
if (CONSP(args)) {
ComEval(com, CAR(args));
args = CDR(args);
if (CONSP(args)) {
CodeTree *tree = NULL, *group;
group = NEW_TREE(CodeTreeJumpIf);
group->code = XBC_JUMPNIL;
for (; CONSP(args); args = CDR(args)) {
ComEval(com, CAR(args));
tree = NEW_TREE(CodeTreeJumpIf);
tree->code = XBC_JUMPNIL;
group->group = tree;
group = tree;
}
group->code = XBC_NOOP;
if (group)
group->group = tree;
}
}
else
com_Bytecode(com, XBC_T);
}
void
Com_Block(LispCom *com, LispBuiltin *builtin)
{
LispObj *name, *body;
body = ARGUMENT(1);
name = ARGUMENT(0);
if (name != NIL && name != T && !SYMBOLP(name))
LispDestroy("%s: %s cannot name a block",
STRFUN(builtin), STROBJ(name));
if (CONSP(body)) {
CompileIniBlock(com, LispBlockTag, name);
ComProgn(com, body);
CompileFiniBlock(com);
}
else
com_Bytecode(com, XBC_NIL);
}
void
Com_C_r(LispCom *com, LispBuiltin *builtin)
{
LispObj *list;
char *desc;
list = ARGUMENT(0);
desc = STRFUN(builtin);
if (*desc == 'F')
desc = "CAR";
else if (*desc == 'R')
desc = "CDR";
while (desc[1] != 'R')
desc++;
ComEval(com, list);
while (*desc != 'C') {
com_Bytecode(com, *desc == 'A' ? XBC_CAR : XBC_CDR);
--desc;
}
}
void
Com_Cond(LispCom *com, LispBuiltin *builtin)
{
int count;
LispObj *code, *body;
CodeTree *group, *tree;
body = ARGUMENT(0);
count = 0;
group = NULL;
if (CONSP(body)) {
for (; CONSP(body); body = CDR(body)) {
code = CAR(body);
CHECK_CONS(code);
++count;
ComEval(com, CAR(code));
tree = NEW_TREE(CodeTreeCond);
if (group)
group->group = tree;
tree->code = XBC_JUMPNIL;
group = tree;
ComProgn(com, CDR(code));
tree = NEW_TREE(CodeTreeCond);
tree->code = XBC_JUMPT;
if (group)
group->group = tree;
group = tree;
}
}
if (!count)
com_Bytecode(com, XBC_NIL);
else
group->code = XBC_NOOP;
}
void
Com_Cons(LispCom *com, LispBuiltin *builtin)
{
LispObj *car, *cdr;
cdr = ARGUMENT(1);
car = ARGUMENT(0);
if (ComConstantp(com, car) && ComConstantp(com, cdr))
com_BytecodeCons(com, XBC_CCONS, car, cdr);
else {
++com->stack.cpstack;
if (com->stack.pstack < com->stack.cpstack)
com->stack.pstack = com->stack.cpstack;
ComEval(com, car);
com_Bytecode(com, XBC_CSTAR);
ComEval(com, cdr);
com_Bytecode(com, XBC_CFINI);
--com->stack.cpstack;
}
}
void
Com_Consp(LispCom *com, LispBuiltin *builtin)
{
ComPredicate(com, builtin, XBP_CONSP);
}
void
Com_Dolist(LispCom *com, LispBuiltin *builtin)
{
int unbound, item;
LispObj *symbol, *list, *result;
LispObj *init, *body;
CodeTree *group, *tree;
body = ARGUMENT(1);
init = ARGUMENT(0);
CHECK_CONS(init);
symbol = CAR(init);
CHECK_SYMBOL(symbol);
CHECK_CONSTANT(symbol);
init = CDR(init);
if (CONSP(init)) {
list = CAR(init);
init = CDR(init);
}
else
list = NIL;
if (CONSP(init)) {
result = CAR(init);
if (CONSP(CDR(init)))
LispDestroy("%s: too many arguments %s",
STRFUN(builtin), STROBJ(CDR(init)));
}
else
result = NIL;
unbound = lisp__data.env.length - lisp__data.env.lex;
item = unbound + 1;
FORM_ENTER();
CompileIniBlock(com, LispBlockTag, NIL);
ComPush(com, UNBOUND, list, 1, 0, 0);
ComPush(com, symbol, NIL, 0, 0, 0);
CompileStackEnter(com, 2, 0);
com_Bind(com, 2);
com->block->bind += 2;
lisp__data.env.head += 2;
COM_VARIABLE_USED(symbol->data.atom);
FORM_ENTER();
CompileIniBlock(com, LispBlockBody, NIL);
ComLabel(com, DOT);
com_BytecodeShort(com, XBC_LOAD, unbound);
com_BytecodeChar(com, XBC_PRED, XBP_CONSP);
group = NEW_TREE(CodeTreeJumpIf);
group->code = XBC_JUMPNIL;
com_BytecodeShort(com, XBC_LOAD, unbound);
com_Bytecode(com, XBC_CAR);
com_BytecodeShort(com, XBC_SET, item);
ComProgn(com, body);
com_BytecodeShort(com, XBC_LOAD, unbound);
com_Bytecode(com, XBC_CDR);
com_BytecodeShort(com, XBC_SET, unbound);
tree = NEW_TREE(CodeTreeGo);
tree->data.object = DOT;
tree = NEW_TREE(CodeTreeJumpIf);
tree->code = XBC_NOOP;
group->group = tree;
CompileFiniBlock(com);
FORM_LEAVE();
com_BytecodeShort(com, XBC_SET, item);
ComEval(com, result);
lisp__data.env.head -= 2;
lisp__data.env.length -= 2;
com->block->bind -= 2;
com_Unbind(com, 2);
CompileStackLeave(com, 2, 0);
CompileFiniBlock(com);
FORM_LEAVE();
}
void
Com_Eq(LispCom *com, LispBuiltin *builtin)
{
LispObj *left, *right;
LispByteOpcode code;
char *name;
right = ARGUMENT(1);
left = ARGUMENT(0);
CompileStackEnter(com, 1, 1);
ComEval(com, left);
com_Bytecode(com, XBC_PUSH);
ComEval(com, right);
name = STRFUN(builtin);
switch (name[3]) {
case 'L':
code = XBC_EQL;
break;
case 'U':
code = name[5] == 'P' ? XBC_EQUALP : XBC_EQUAL;
break;
default:
code = XBC_EQ;
break;
}
com_Bytecode(com, code);
CompileStackLeave(com, 1, 1);
}
void
Com_Go(LispCom *com, LispBuiltin *builtin)
{
int bind;
LispObj *tag;
CodeTree *tree;
CodeBlock *block;
tag = ARGUMENT(0);
block = com->block;
bind = block->bind;
while (block) {
if (block->type == LispBlockClosure || block->type == LispBlockBody)
break;
block = block->prev;
if (block)
bind += block->bind;
}
if (!block || block->type != LispBlockBody)
LispDestroy("%s called not within a block", STRFUN(builtin));
com_Unbind(com, bind);
tree = NEW_TREE(CodeTreeGo);
tree->data.object = tag;
}
void
Com_If(LispCom *com, LispBuiltin *builtin)
{
CodeTree *group, *tree;
LispObj *test, *then, *oelse;
oelse = ARGUMENT(2);
then = ARGUMENT(1);
test = ARGUMENT(0);
ComEval(com, test);
group = NEW_TREE(CodeTreeJumpIf);
group->code = XBC_JUMPNIL;
ComEval(com, then);
if (oelse != UNSPEC) {
tree = NEW_TREE(CodeTreeJump);
tree->code = XBC_JUMP;
group->group = tree;
group = tree;
ComEval(com, oelse);
}
tree = NEW_TREE(CodeTreeJumpIf);
tree->code = XBC_NOOP;
group->group = tree;
}
void
Com_Last(LispCom *com, LispBuiltin *builtin)
{
LispObj *list, *count;
count = ARGUMENT(1);
list = ARGUMENT(0);
ComEval(com, list);
CompileStackEnter(com, 1, 1);
com_Bytecode(com, XBC_PUSH);
if (count == UNSPEC)
count = FIXNUM(1);
ComEval(com, count);
CompileStackLeave(com, 1, 1);
com_Bytecode(com, XBC_LAST);
}
void
Com_Length(LispCom *com, LispBuiltin *builtin)
{
LispObj *sequence;
sequence = ARGUMENT(0);
ComEval(com, sequence);
com_Bytecode(com, XBC_LENGTH);
}
void
Com_Let(LispCom *com, LispBuiltin *builtin)
{
int count;
LispObj *symbol, *value, *pair;
LispObj *init, *body;
body = ARGUMENT(1);
init = ARGUMENT(0);
if (init == NIL) {
ComProgn(com, body);
return;
}
CHECK_CONS(init);
for (count = 0; CONSP(init); init = CDR(init), count++) {
pair = CAR(init);
if (CONSP(pair)) {
symbol = CAR(pair);
pair = CDR(pair);
if (CONSP(pair)) {
value = CAR(pair);
if (CDR(pair) != NIL)
LispDestroy("%s: too much arguments to initialize %s",
STRFUN(builtin), STROBJ(symbol));
}
else
value = NIL;
}
else {
symbol = pair;
value = NIL;
}
CHECK_SYMBOL(symbol);
CHECK_CONSTANT(symbol);
ComPush(com, symbol, value, 1, 0, 0);
}
CompileStackEnter(com, count, 0);
com_Bind(com, count);
com->block->bind += count;
lisp__data.env.head += count;
ComProgn(com, body);
lisp__data.env.head -= count;
lisp__data.env.length -= count;
com->block->bind -= count;
com_Unbind(com, count);
CompileStackLeave(com, count, 0);
}
void
Com_Letx(LispCom *com, LispBuiltin *builtin)
{
int count;
LispObj *symbol, *value, *pair;
LispObj *init, *body;
body = ARGUMENT(1);
init = ARGUMENT(0);
if (init == NIL) {
ComProgn(com, body);
return;
}
CHECK_CONS(body);
for (count = 0; CONSP(init); init = CDR(init), count++) {
pair = CAR(init);
if (CONSP(pair)) {
symbol = CAR(pair);
pair = CDR(pair);
if (CONSP(pair)) {
value = CAR(pair);
if (CDR(pair) != NIL)
LispDestroy("%s: too much arguments to initialize %s",
STRFUN(builtin), STROBJ(symbol));
}
else
value = NIL;
}
else {
symbol = pair;
value = NIL;
}
CHECK_SYMBOL(symbol);
CHECK_CONSTANT(symbol);
ComPush(com, symbol, value, 1, 0, 0);
com_Bind(com, 1);
++lisp__data.env.head;
++com->block->bind;
}
CompileStackEnter(com, count, 0);
ComProgn(com, body);
com_Unbind(com, count);
com->block->bind -= count;
lisp__data.env.head -= count;
lisp__data.env.length -= count;
CompileStackLeave(com, count, 0);
}
void
Com_Listp(LispCom *com, LispBuiltin *builtin)
{
ComPredicate(com, builtin, XBP_LISTP);
}
void
Com_Loop(LispCom *com, LispBuiltin *builtin)
{
CodeTree *tree, *group;
LispObj *body;
body = ARGUMENT(0);
CompileIniBlock(com, LispBlockTag, NIL);
tree = NEW_TREE(CodeTreeJump);
tree->code = XBC_NOOP;
if (CONSP(body))
ComProgn(com, body);
else
com_Bytecode(com, XBC_NIL);
group = NEW_TREE(CodeTreeJump);
group->code = XBC_JUMP;
group->group = tree;
CompileFiniBlock(com);
}
void
Com_Nthcdr(LispCom *com, LispBuiltin *builtin)
{
LispObj *oindex, *list;
list = ARGUMENT(1);
oindex = ARGUMENT(0);
ComEval(com, oindex);
CompileStackEnter(com, 1, 1);
com_Bytecode(com, XBC_PUSH);
ComEval(com, list);
CompileStackLeave(com, 1, 1);
com_Bytecode(com, XBC_NTHCDR);
}
void
Com_Null(LispCom *com, LispBuiltin *builtin)
{
LispObj *list;
list = ARGUMENT(0);
if (list == NIL)
com_Bytecode(com, XBC_T);
else if (ComConstantp(com, list))
com_Bytecode(com, XBC_NIL);
else {
ComEval(com, list);
com_Bytecode(com, XBC_INV);
}
}
void
Com_Numberp(LispCom *com, LispBuiltin *builtin)
{
ComPredicate(com, builtin, XBP_NUMBERP);
}
void
Com_Or(LispCom *com, LispBuiltin *builtin)
{
LispObj *args;
args = ARGUMENT(0);
if (CONSP(args)) {
ComEval(com, CAR(args));
args = CDR(args);
if (CONSP(args)) {
CodeTree *tree = NULL, *group;
group = NEW_TREE(CodeTreeJumpIf);
group->code = XBC_JUMPT;
for (; CONSP(args); args = CDR(args)) {
ComEval(com, CAR(args));
tree = NEW_TREE(CodeTreeJumpIf);
tree->code = XBC_JUMPT;
group->group = tree;
group = tree;
}
group->code = XBC_NOOP;
group->group = tree;
}
}
else
com_Bytecode(com, XBC_NIL);
}
void
Com_Progn(LispCom *com, LispBuiltin *builtin)
{
LispObj *body;
body = ARGUMENT(0);
ComProgn(com, body);
}
void
Com_Return(LispCom *com, LispBuiltin *builtin)
{
ComReturnFrom(com, builtin, 0);
}
void
Com_ReturnFrom(LispCom *com, LispBuiltin *builtin)
{
ComReturnFrom(com, builtin, 1);
}
void
Com_Rplac_(LispCom *com, LispBuiltin *builtin)
{
LispObj *place, *value;
value = ARGUMENT(1);
place = ARGUMENT(0);
CompileStackEnter(com, 1, 1);
ComEval(com, place);
com_Bytecode(com, XBC_PUSH);
ComEval(com, value);
com_Bytecode(com, STRFUN(builtin)[5] == 'A' ? XBC_RPLACA : XBC_RPLACD);
CompileStackLeave(com, 1, 1);
}
void
Com_Setq(LispCom *com, LispBuiltin *builtin)
{
int offset;
LispObj *form, *symbol, *value;
form = ARGUMENT(0);
for (; CONSP(form); form = CDR(form)) {
symbol = CAR(form);
CHECK_SYMBOL(symbol);
CHECK_CONSTANT(symbol);
form = CDR(form);
if (!CONSP(form))
LispDestroy("%s: odd number of arguments", STRFUN(builtin));
value = CAR(form);
ComEval(com, value);
offset = ComGetVariable(com, symbol);
if (offset >= 0)
com_Set(com, offset);
else
com_SetSym(com, symbol->data.atom);
}
}
void
Com_Tagbody(LispCom *com, LispBuiltin *builtin)
{
LispObj *body;
body = ARGUMENT(0);
if (CONSP(body)) {
CompileIniBlock(com, LispBlockBody, NIL);
ComProgn(com, body);
com_Bytecode(com, XBC_NIL);
CompileFiniBlock(com);
}
else
com_Bytecode(com, XBC_NIL);
}
void
Com_Unless(LispCom *com, LispBuiltin *builtin)
{
CodeTree *group, *tree;
LispObj *test, *body;
body = ARGUMENT(1);
test = ARGUMENT(0);
ComEval(com, test);
group = NEW_TREE(CodeTreeJumpIf);
group->code = XBC_JUMPT;
ComProgn(com, body);
tree = NEW_TREE(CodeTreeJumpIf);
tree->code = XBC_NOOP;
group->group = tree;
}
void
Com_Until(LispCom *com, LispBuiltin *builtin)
{
CodeTree *tree, *group, *ltree, *lgroup;
LispObj *test, *body;
body = ARGUMENT(1);
test = ARGUMENT(0);
ltree = NEW_TREE(CodeTreeJump);
ltree->code = XBC_NOOP;
ComEval(com, test);
group = NEW_TREE(CodeTreeJumpIf);
group->code = XBC_JUMPT;
ComProgn(com, body);
lgroup = NEW_TREE(CodeTreeJump);
lgroup->code = XBC_JUMP;
lgroup->group = ltree;
tree = NEW_TREE(CodeTreeJumpIf);
tree->code = XBC_NOOP;
group->group = tree;
}
void
Com_When(LispCom *com, LispBuiltin *builtin)
{
CodeTree *group, *tree;
LispObj *test, *body;
body = ARGUMENT(1);
test = ARGUMENT(0);
ComEval(com, test);
group = NEW_TREE(CodeTreeJumpIf);
group->code = XBC_JUMPNIL;
ComProgn(com, body);
tree = NEW_TREE(CodeTreeJumpIf);
tree->code = XBC_NOOP;
group->group = tree;
}
void
Com_While(LispCom *com, LispBuiltin *builtin)
{
CodeTree *tree, *group, *ltree, *lgroup;
LispObj *test, *body;
body = ARGUMENT(1);
test = ARGUMENT(0);
ltree = NEW_TREE(CodeTreeJump);
ltree->code = XBC_NOOP;
ComEval(com, test);
group = NEW_TREE(CodeTreeJumpIf);
group->code = XBC_JUMPNIL;
ComProgn(com, body);
lgroup = NEW_TREE(CodeTreeJump);
lgroup->code = XBC_JUMP;
lgroup->group = ltree;
tree = NEW_TREE(CodeTreeJumpIf);
tree->code = XBC_NOOP;
group->group = tree;
}
static void
ComPredicate(LispCom *com, LispBuiltin *builtin, LispBytePredicate predicate)
{
LispObj *object;
object = ARGUMENT(0);
if (ComConstantp(com, object)) {
switch (predicate) {
case XBP_CONSP:
com_Bytecode(com, CONSP(object) ? XBC_T : XBC_NIL);
break;
case XBP_LISTP:
com_Bytecode(com, CONSP(object) || object == NIL ?
XBC_T : XBC_NIL);
break;
case XBP_NUMBERP:
com_Bytecode(com, NUMBERP(object) ? XBC_T : XBC_NIL);
break;
}
}
else {
ComEval(com, object);
com_BytecodeChar(com, XBC_PRED, predicate);
}
}
static void
ComReturnFrom(LispCom *com, LispBuiltin *builtin, int from)
{
int bind;
CodeTree *tree;
LispObj *name, *result;
CodeBlock *block = com->block;
if (from) {
result = ARGUMENT(1);
name = ARGUMENT(0);
}
else {
result = ARGUMENT(0);
name = NIL;
}
if (result == UNSPEC)
result = NIL;
bind = block->bind;
while (block) {
if (block->type == LispBlockClosure)
break;
else if (block->type == LispBlockTag && block->tag == name)
break;
block = block->prev;
if (block)
bind += block->bind;
}
if (!block || block->tag != name)
LispDestroy("%s: no visible %s block", STRFUN(builtin), STROBJ(name));
ComEval(com, result);
com_Unbind(com, bind);
tree = NEW_TREE(CodeTreeReturn);
tree->data.block = block;
}
static int
ComConstantp(LispCom *com, LispObj *object)
{
switch (OBJECT_TYPE(object)) {
case LispAtom_t:
if (object->data.atom->package == lisp__data.keyword)
break;
return (0);
case LispCons_t:
case LispQuote_t:
case LispBackquote_t:
case LispComma_t:
case LispFunctionQuote_t:
return (0);
default:
break;
}
return (1);
}
static int
FindIndex(void *item, void **table, int length)
{
long cmp;
int left, right, i;
left = 0;
right = length - 1;
while (left <= right) {
i = (left + right) >> 1;
cmp = (char*)item - (char*)table[i];
if (cmp == 0)
return (i);
else if (cmp < 0)
right = i - 1;
else
left = i + 1;
}
return (-1);
}
static int
compare(const void *left, const void *right)
{
long cmp = *(char**)left - *(char**)right;
return (cmp < 0 ? -1 : 1);
}
static int
BuildTablePointer(void *pointer, void ***pointers, int *num_pointers)
{
int i;
if ((i = FindIndex(pointer, *pointers, *num_pointers)) < 0) {
*pointers = LispRealloc(*pointers,
sizeof(void*) * (*num_pointers + 1));
(*pointers)[*num_pointers] = pointer;
if (++*num_pointers > 1)
qsort(*pointers, *num_pointers, sizeof(void*), compare);
i = FindIndex(pointer, *pointers, *num_pointers);
}
return (i);
}
static void
ComAddVariable(LispCom *com, LispObj *symbol, LispObj *value)
{
LispAtom *atom = symbol->data.atom;
if (atom && atom->string && !com->macro) {
int i, length = com->block->variables.length;
i = BuildTablePointer(atom, (void***)&com->block->variables.symbols,
&com->block->variables.length);
if (com->block->variables.length != length) {
com->block->variables.flags =
LispRealloc(com->block->variables.flags,
com->block->variables.length * sizeof(int));
if (i < length)
memmove(com->block->variables.flags + i + 1,
com->block->variables.flags + i,
(length - i) * sizeof(int));
com->block->variables.flags[i] = 0;
}
}
LispAddVar(symbol, value);
}
static int
ComGetVariable(LispCom *com, LispObj *symbol)
{
LispAtom *name;
int i, base, offset;
Atom_id id;
name = symbol->data.atom;
if (name->constant) {
if (name->package == lisp__data.keyword)
return (SYMBOL_KEYWORD);
return (SYMBOL_CONSTANT);
}
offset = name->offset;
id = name->string;
base = lisp__data.env.lex;
i = lisp__data.env.head - 1;
if (offset <= i && offset >= com->lex && lisp__data.env.names[offset] == id) {
COM_VARIABLE_USED(name);
return (offset - base);
}
for (; i >= com->lex; i--)
if (lisp__data.env.names[i] == id) {
name->offset = i;
COM_VARIABLE_USED(name);
return (i - base);
}
if (!name->a_object) {
++com->warnings;
LispWarning("variable %s is neither declared nor bound",
name->string);
}
return (SYMBOL_UNBOUND);
}
static void
ComVariableSetFlag(LispCom *com, LispAtom *atom, int flag)
{
int i;
CodeBlock *block = com->block;
while (block) {
i = FindIndex(atom, (void**)block->variables.symbols,
block->variables.length);
if (i >= 0) {
block->variables.flags[i] |= flag;
if ((flag & VARIABLE_ARGUMENT) ||
!(block->variables.flags[i] & VARIABLE_ARGUMENT))
break;
}
block = block->prev;
}
}
static void
ComLabel(LispCom *com, LispObj *label)
{
int i;
CodeTree *tree;
for (i = 0; i < com->block->tagbody.length; i++)
if (label == com->block->tagbody.labels[i])
LispDestroy("TAGBODY: tag %s specified more than once",
STROBJ(label));
if (com->block->tagbody.length >= com->block->tagbody.space) {
com->block->tagbody.labels =
LispRealloc(com->block->tagbody.labels,
sizeof(LispObj*) * (com->block->tagbody.space + 8));
com->block->tagbody.codes =
LispRealloc(com->block->tagbody.codes,
sizeof(CodeTree*) * (com->block->tagbody.space + 8));
com->block->tagbody.space += 8;
}
com->block->tagbody.labels[com->block->tagbody.length++] = label;
tree = NEW_TREE(CodeTreeLabel);
tree->data.object = label;
}
static void
ComPush(LispCom *com, LispObj *symbol, LispObj *value,
int eval, int builtin, int compile)
{
if (compile) {
if (builtin)
lisp__data.stack.values[lisp__data.stack.length++] = value;
else
ComAddVariable(com, symbol, value);
return;
}
else if (com->macro) {
ComAddVariable(com, symbol, value);
return;
}
else if (eval && !ComConstantp(com, value)) {
switch (OBJECT_TYPE(value)) {
case LispAtom_t: {
int offset = ComGetVariable(com, value);
if (offset >= 0) {
if (builtin)
com_LoadPush(com, offset);
else
com_LoadLet(com, offset, symbol->data.atom);
}
else if (offset == SYMBOL_CONSTANT) {
value = value->data.atom->property->value;
if (builtin)
com_LoadConPush(com, value);
else
com_LoadConLet(com, value, symbol->data.atom);
}
else {
if (builtin)
com_LoadSymPush(com, value->data.atom);
else
com_LoadSymLet(com, value->data.atom,
symbol->data.atom);
}
} break;
default:
ComEval(com, value);
if (builtin)
com_Bytecode(com, XBC_PUSH);
else
com_Let(com, symbol->data.atom);
break;
}
if (builtin)
lisp__data.stack.values[lisp__data.stack.length++] = value;
else
ComAddVariable(com, symbol, value);
return;
}
if (builtin) {
com_LoadConPush(com, value);
lisp__data.stack.values[lisp__data.stack.length++] = value;
}
else {
com_LoadConLet(com, value, symbol->data.atom);
ComAddVariable(com, symbol, value);
}
}
static int
ComCall(LispCom *com, LispArgList *alist,
LispObj *name, LispObj *values,
int eval, int builtin, int compile)
{
char *desc;
int i, count, base;
LispObj **symbols, **defaults, **sforms;
if (builtin) {
base = lisp__data.stack.length;
if (base + alist->num_arguments > lisp__data.stack.space) {
do
LispMoreStack();
while (base + alist->num_arguments > lisp__data.stack.space);
}
}
else
base = lisp__data.env.length;
desc = alist->description;
switch (*desc++) {
case '.':
goto normal_label;
case 'o':
goto optional_label;
case 'k':
goto key_label;
case 'r':
goto rest_label;
case 'a':
goto aux_label;
default:
goto done_label;
}
normal_label:
i = 0;
symbols = alist->normals.symbols;
count = alist->normals.num_symbols;
for (; i < count && CONSP(values); i++, values = CDR(values)) {
ComPush(com, symbols[i], CAR(values), eval, builtin, compile);
if (!builtin && !com->macro)
COM_VARIABLE_ARGUMENT(symbols[i]->data.atom);
}
if (i < count)
LispDestroy("%s: too few arguments", STROBJ(name));
switch (*desc++) {
case 'o':
goto optional_label;
case 'k':
goto key_label;
case 'r':
goto rest_label;
case 'a':
goto aux_label;
default:
goto done_label;
}
optional_label:
i = 0;
count = alist->optionals.num_symbols;
symbols = alist->optionals.symbols;
defaults = alist->optionals.defaults;
sforms = alist->optionals.sforms;
for (; i < count && CONSP(values); i++, values = CDR(values)) {
ComPush(com, symbols[i], CAR(values), eval, builtin, compile);
if (!builtin && !com->macro)
COM_VARIABLE_ARGUMENT(symbols[i]->data.atom);
if (sforms[i]) {
ComPush(com, sforms[i], T, 0, builtin, compile);
if (!builtin && !com->macro)
COM_VARIABLE_ARGUMENT(sforms[i]->data.atom);
}
}
for (; i < count; i++) {
if (!builtin) {
int lex = com->lex;
int head = lisp__data.env.head;
com->lex = base;
lisp__data.env.head = lisp__data.env.length;
ComPush(com, symbols[i], defaults[i], 1, 0, compile);
if (!com->macro)
COM_VARIABLE_ARGUMENT(symbols[i]->data.atom);
lisp__data.env.head = head;
com->lex = lex;
}
else
ComPush(com, symbols[i], defaults[i], eval, 1, compile);
if (sforms[i]) {
ComPush(com, sforms[i], NIL, 0, builtin, compile);
if (!builtin && !com->macro)
COM_VARIABLE_ARGUMENT(sforms[i]->data.atom);
}
}
switch (*desc++) {
case 'k':
goto key_label;
case 'r':
goto rest_label;
case 'a':
goto aux_label;
default:
goto done_label;
}
key_label:
{
int varset;
LispObj *val, *karg, **keys;
count = alist->keys.num_symbols;
symbols = alist->keys.symbols;
defaults = alist->keys.defaults;
sforms = alist->keys.sforms;
keys = alist->keys.keys;
for (karg = values; CONSP(karg); karg = CDR(karg)) {
val = CAR(karg);
if (KEYWORDP(val)) {
for (i = 0; i < alist->keys.num_symbols; i++)
if (!keys[i] && symbols[i] == val)
break;
}
else if (!builtin &&
QUOTEP(val) && SYMBOLP(val->data.quote)) {
for (i = 0; i < alist->keys.num_symbols; i++)
if (keys[i] && ATOMID(keys[i]) == ATOMID(val->data.quote))
break;
}
else
i = alist->keys.num_symbols;
if (i == alist->keys.num_symbols) {
char function_name[36];
strcpy(function_name, STROBJ(name));
LispDestroy("%s: invalid keyword %s",
function_name, STROBJ(val));
}
karg = CDR(karg);
if (!CONSP(karg))
LispDestroy("%s: &KEY needs arguments as pairs",
STROBJ(name));
}
for (i = 0; i < alist->keys.num_symbols; i++) {
val = defaults[i];
varset = 0;
if (!builtin && keys[i]) {
Atom_id atom = ATOMID(keys[i]);
for (karg = values; CONSP(karg); karg = CDR(karg)) {
val = CAR(karg);
if (QUOTEP(val) && atom == ATOMID(val->data.quote)) {
val = CADR(karg);
varset = 1;
break;
}
karg = CDR(karg);
}
}
else {
for (karg = values; CONSP(karg); karg = CDR(karg)) {
if (symbols[i] == CAR(karg)) {
val = CADR(karg);
varset = 1;
break;
}
karg = CDR(karg);
}
}
if (varset) {
ComPush(com, symbols[i], val, eval, builtin, compile);
if (sforms[i])
ComPush(com, sforms[i], T, 0, builtin, compile);
}
else {
if (!builtin) {
int lex = com->lex;
int head = lisp__data.env.head;
com->lex = base;
lisp__data.env.head = lisp__data.env.length;
ComPush(com, symbols[i], val, eval, 0, compile);
lisp__data.env.head = head;
com->lex = lex;
}
else
ComPush(com, symbols[i], val, eval, builtin, compile);
if (sforms[i])
ComPush(com, sforms[i], NIL, 0, builtin, compile);
}
if (!builtin && !com->macro) {
COM_VARIABLE_ARGUMENT(symbols[i]->data.atom);
if (sforms[i])
COM_VARIABLE_ARGUMENT(sforms[i]->data.atom);
}
}
}
if (*desc == 'a') {
values = NIL;
goto aux_label;
}
goto finished_label;
rest_label:
if (!eval || !CONSP(values) || (compile && !builtin))
ComPush(com, alist->rest, values, eval, builtin, compile);
else {
char *string;
LispObj *list, *car = NIL;
int count, constantp;
for (count = 0, constantp = 1, list = values;
CONSP(list);
list = CDR(list), count++) {
car = CAR(list);
if (!ComConstantp(com, car))
constantp = 0;
}
string = builtin ? ATOMID(name) : NULL;
if (string && (count < MAX_BCONS || constantp) &&
strcmp(string, "LIST") &&
strcmp(string, "APPLY") &&
strcmp(string, "VECTOR") &&
(strcmp(string, "APPEND") || !CONSP(car))) {
if (constantp) {
ComPush(com, alist->rest, values, 0, builtin, compile);
}
else {
CompileStackEnter(com, count - 1, 1);
for (; CONSP(CDR(values)); values = CDR(values)) {
ComEval(com, CAR(values));
com_Bytecode(com, XBC_PUSH);
}
CompileStackLeave(com, count - 1, 1);
ComEval(com, CAR(values));
values = NIL;
com_Bytecode(com, (LispByteOpcode)(XBC_BCONS + (count - 1)));
}
}
else {
ComEval(com, CAR(values));
com->stack.cpstack += 2;
if (com->stack.pstack < com->stack.cpstack)
com->stack.pstack = com->stack.cpstack;
com_Bytecode(com, XBC_LSTAR);
for (values = CDR(values); CONSP(values); values = CDR(values)) {
ComEval(com, CAR(values));
com_Bytecode(com, XBC_LCONS);
}
com_Bytecode(com, XBC_LFINI);
if (builtin)
com_Bytecode(com, XBC_PUSH);
else {
com_Let(com, alist->rest->data.atom);
ComAddVariable(com, alist->rest, values);
}
com->stack.cpstack -= 2;
}
}
if (!builtin && !com->macro)
COM_VARIABLE_ARGUMENT(alist->rest->data.atom);
if (*desc != 'a')
goto finished_label;
aux_label:
i = 0;
count = alist->auxs.num_symbols;
symbols = alist->auxs.symbols;
defaults = alist->auxs.initials;
if (!builtin && !compile) {
int lex = com->lex;
com->lex = base;
lisp__data.env.head = lisp__data.env.length;
for (; i < count; i++) {
ComPush(com, symbols[i], defaults[i], 1, 0, 0);
if (!com->macro)
COM_VARIABLE_ARGUMENT(symbols[i]->data.atom);
++lisp__data.env.head;
}
com->lex = lex;
}
else {
for (; i < count; i++) {
ComPush(com, symbols[i], defaults[i], eval, builtin, compile);
if (!builtin && !com->macro)
COM_VARIABLE_ARGUMENT(symbols[i]->data.atom);
}
}
done_label:
if (CONSP(values))
LispDestroy("%s: too many arguments", STROBJ(name));
finished_label:
if (builtin)
lisp__data.stack.base = base;
else
lisp__data.env.head = lisp__data.env.length;
return (base);
}
static void
ComFuncall(LispCom *com, LispObj *function, LispObj *arguments, int eval)
{
int base, compile;
LispAtom *atom;
LispArgList *alist;
LispBuiltin *builtin;
LispObj *lambda;
switch (OBJECT_TYPE(function)) {
case LispFunction_t:
function = function->data.atom->object;
case LispAtom_t:
atom = function->data.atom;
alist = atom->property->alist;
if (atom->a_builtin) {
builtin = atom->property->fun.builtin;
compile = builtin->compile != NULL;
if (com->macro || compile || builtin->type == LispMacro)
eval = 0;
if (!com->macro && builtin->type == LispMacro) {
LispObj *obj;
for (obj = arguments; CONSP(obj); obj = CDR(obj)) {
if (SYMBOLP(CAR(obj)))
COM_VARIABLE_USED(CAR(obj)->data.atom);
}
}
FORM_ENTER();
if (!compile && !com->macro)
CompileStackEnter(com, alist->num_arguments, 1);
base = ComCall(com, alist, function, arguments,
eval, 1, compile);
if (compile)
builtin->compile(com, builtin);
else {
com_Call(com, alist->num_arguments, builtin);
CompileStackLeave(com, alist->num_arguments, 1);
}
lisp__data.stack.base = lisp__data.stack.length = base;
FORM_LEAVE();
}
else if (atom->a_function) {
int macro;
lambda = atom->property->fun.function;
macro = lambda->funtype == LispMacro;
if (macro)
ComMacroCall(com, alist, function, lambda, arguments);
else {
if (com->toplevel->type == LispBlockClosure &&
com->toplevel->tag == function)
ComRecursiveCall(com, alist, function, arguments);
else {
#if 0
ComInlineCall(com, alist, function, arguments,
lambda->data.lambda.code);
#else
com_Funcall(com, function, arguments);
#endif
}
}
}
else if (atom->a_defstruct &&
atom->property->structure.function != STRUCT_NAME &&
atom->property->structure.function != STRUCT_CONSTRUCTOR) {
LispObj *definition = atom->property->structure.definition;
if (!CONSP(arguments) || CONSP(CDR(arguments)))
LispDestroy("%s: too %s arguments", atom->string,
CONSP(arguments) ? "many" : "few");
ComEval(com, CAR(arguments));
if (atom->property->structure.function == STRUCT_CHECK)
com_Structp(com, definition);
else
com_Struct(com,
atom->property->structure.function, definition);
}
else if (atom->a_compiled) {
FORM_ENTER();
CompileStackEnter(com, alist->num_arguments, 0);
base = ComCall(com, alist, function, arguments, 1, 0, 0);
com_Bytecall(com, alist->num_arguments,
atom->property->fun.function);
CompileStackLeave(com, alist->num_arguments, 0);
lisp__data.env.head = lisp__data.env.length = base;
FORM_LEAVE();
}
else {
++com->warnings;
LispWarning("call to undefined function %s", atom->string);
com_Funcall(com, function, arguments);
}
break;
case LispLambda_t:
lambda = function->data.lambda.code;
alist = (LispArgList*)function->data.lambda.name->data.opaque.data;
ComInlineCall(com, alist, NIL, arguments, lambda->data.lambda.code);
break;
case LispCons_t:
if (CAR(function) == Olambda) {
function = EVAL(function);
if (LAMBDAP(function)) {
GC_ENTER();
GC_PROTECT(function);
lambda = function->data.lambda.code;
alist = (LispArgList*)function->data.lambda.name->data.opaque.data;
ComInlineCall(com, alist, NIL, arguments, lambda->data.lambda.code);
GC_LEAVE();
break;
}
}
default:
LispDestroy("EVAL: %s is invalid as a function",
STROBJ(function));
break;
}
}
static void
ComProgn(LispCom *com, LispObj *code)
{
if (CONSP(code)) {
for (; CONSP(code); code = CDR(code))
ComEval(com, CAR(code));
}
else
com_Bytecode(com, XBC_NIL);
}
static void
ComEval(LispCom *com, LispObj *object)
{
int offset;
LispObj *form;
switch (OBJECT_TYPE(object)) {
case LispAtom_t:
if (IN_TAGBODY())
ComLabel(com, object);
else {
offset = ComGetVariable(com, object);
if (offset >= 0)
com_Load(com, offset);
else if (offset == SYMBOL_KEYWORD)
com_LoadCon(com, object);
else if (offset == SYMBOL_CONSTANT)
com_LoadCon(com, LispGetVar(object));
else
com_LoadSym(com, object->data.atom);
}
break;
case LispCons_t: {
form = com->form;
com->form = object;
ComFuncall(com, CAR(object), CDR(object), 1);
com->form = form;
} break;
case LispQuote_t:
com_LoadCon(com, object->data.quote);
break;
case LispBackquote_t:
ComMacroBackquote(com, object);
break;
case LispComma_t:
LispDestroy("EVAL: comma outside of backquote");
break;
case LispFunctionQuote_t:
object = object->data.quote;
if (SYMBOLP(object))
object = LispSymbolFunction(object);
else if (CONSP(object) && CAR(object) == Olambda) {
object = EVAL(object);
RPLACD(com->plist, CONS(CAR(com->plist), CDR(com->plist)));
RPLACA(com->plist, object);
}
else
LispDestroy("FUNCTION: %s is not a function", STROBJ(object));
com_LoadCon(com, object);
break;
case LispFixnum_t:
if (IN_TAGBODY()) {
ComLabel(com, object);
break;
}
default:
com_LoadCon(com, object);
break;
}
}
static void
ComRecursiveCall(LispCom *com, LispArgList *alist,
LispObj *name, LispObj *arguments)
{
int base, lex;
lex = lisp__data.env.lex;
FORM_ENTER();
base = ComCall(com, alist, name, arguments, 1, 0, 0);
CompileStackEnter(com, alist->num_arguments, 0);
#if 0
com_Bind(com, alist->num_arguments);
com->block->bind += alist->num_arguments;
#endif
com_BytecodeChar(com, XBC_LETREC, alist->num_arguments);
#if 0
com_Unbind(com, alist->num_arguments);
com->block->bind -= alist->num_arguments;
#endif
CompileStackLeave(com, alist->num_arguments, 0);
FORM_LEAVE();
lisp__data.env.lex = lex;
lisp__data.env.head = lisp__data.env.length = base;
}
static void
ComInlineCall(LispCom *com, LispArgList *alist,
LispObj *name, LispObj *arguments, LispObj *lambda)
{
int base, lex;
lex = lisp__data.env.lex;
FORM_ENTER();
CompileIniBlock(com, LispBlockClosure, name);
base = ComCall(com, alist, name, arguments, 1, 0, 0);
CompileStackEnter(com, alist->num_arguments, 0);
com_Bind(com, alist->num_arguments);
com->block->bind += alist->num_arguments;
ComProgn(com, lambda);
com_Unbind(com, alist->num_arguments);
com->block->bind -= alist->num_arguments;
CompileStackLeave(com, alist->num_arguments, 0);
CompileFiniBlock(com);
FORM_LEAVE();
lisp__data.env.lex = lex;
lisp__data.env.head = lisp__data.env.length = base;
}
static LispObj *
ComMacroExpandBackquote(LispCom *com, LispObj *object)
{
return (LispEvalBackquote(object->data.quote, 1));
}
static LispObj *
ComMacroExpandFuncall(LispCom *com, LispObj *function, LispObj *arguments)
{
return (LispFuncall(function, arguments, 1));
}
static LispObj *
ComMacroExpandEval(LispCom *com, LispObj *object)
{
LispObj *result;
switch (OBJECT_TYPE(object)) {
case LispAtom_t:
result = LispGetVar(object);
if (result == NULL)
LispDestroy("EVAL: the variable %s is unbound",
STROBJ(object));
break;
case LispCons_t:
result = ComMacroExpandFuncall(com, CAR(object), CDR(object));
break;
case LispQuote_t:
result = object->data.quote;
break;
case LispBackquote_t:
result = ComMacroExpandBackquote(com, object);
break;
case LispComma_t:
LispDestroy("EVAL: comma outside of backquote");
case LispFunctionQuote_t:
result = EVAL(object);
break;
default:
result = object;
break;
}
return (result);
}
static LispObj *
ComMacroExpand(LispCom *com, LispObj *lambda)
{
LispObj *result, **presult = &result;
int jumped, *pjumped = &jumped, backquote, *pbackquote = &backquote;
LispBlock *block;
int interpreter_lex, interpreter_head, interpreter_base;
interpreter_base = lisp__data.stack.length;
interpreter_head = lisp__data.env.length;
interpreter_lex = lisp__data.env.lex;
*presult = NIL;
*pjumped = 1;
*pbackquote = !CONSP(lambda);
block = LispBeginBlock(NIL, LispBlockProtect);
if (setjmp(block->jmp) == 0) {
if (!backquote) {
for (; CONSP(lambda); lambda = CDR(lambda))
result = ComMacroExpandEval(com, CAR(lambda));
}
else
result = ComMacroExpandBackquote(com, lambda);
*pjumped = 0;
}
LispEndBlock(block);
if (!lisp__data.destroyed && jumped)
LispDestroy("*** EVAL: bad jump in macro expansion");
if (lisp__data.destroyed) {
LispMessage("*** EVAL: aborting macro expansion");
LispDestroy(".");
}
lisp__data.env.lex = interpreter_lex;
lisp__data.stack.length = interpreter_base;
lisp__data.env.head = lisp__data.env.length = interpreter_head;
return (result);
}
static void
ComMacroCall(LispCom *com, LispArgList *alist,
LispObj *name, LispObj *lambda, LispObj *arguments)
{
int base;
LispObj *body;
++com->macro;
base = ComCall(com, alist, name, arguments, 0, 0, 0);
body = lambda->data.lambda.code;
body = ComMacroExpand(com, body);
--com->macro;
lisp__data.env.head = lisp__data.env.length = base;
CAR(com->form) = body;
ComEval(com, body);
}
static void
ComMacroBackquote(LispCom *com, LispObj *lambda)
{
LispObj *body;
++com->macro;
body = ComMacroExpand(com, lambda);
--com->macro;
CAR(com->form) = body;
com_LoadCon(com, body);
}