qbit/xenocara
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity
882509e84e
xenocara/app/xedit/lisp/compile.c
matthieu b44ff0aad7 xedit 1.1.1
2008-10-13 20:53:31 +00:00

2225 lines
53 KiB
C
Raw Blame History

/*
* Copyright (c) 2002 by The XFree86 Project, Inc.
*
* Permission is hereby granted, free of charge, to any person obtaining a
* copy of this software and associated documentation files (the "Software"),
* to deal in the Software without restriction, including without limitation
* the rights to use, copy, modify, merge, publish, distribute, sublicense,
* and/or sell copies of the Software, and to permit persons to whom the
* Software is furnished to do so, subject to the following conditions:
*
* The above copyright notice and this permission notice shall be included in
* all copies or substantial portions of the Software.
*
* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
* THE XFREE86 PROJECT BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
* WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF
* OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
* SOFTWARE.
*
* Except as contained in this notice, the name of the XFree86 Project shall
* not be used in advertising or otherwise to promote the sale, use or other
* dealings in this Software without prior written authorization from the
* XFree86 Project.
*
* Author: Paulo César Pereira de Andrade
*/
/* $XFree86: xc/programs/xedit/lisp/compile.c,v 1.15tsi Exp $ */
#define VARIABLE_USED 0x0001
#define VARIABLE_ARGUMENT 0x0002
/*
* Prototypes
*/
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*);
/*
* Implementation
*/
void
Com_And(LispCom *com, LispBuiltin *builtin)
/*
and &rest args
*/
{
LispObj *args;
args = ARGUMENT(0);
if (CONSP(args)) {
/* Evaluate first argument */
ComEval(com, CAR(args));
args = CDR(args);
/* If more than one argument, create jump list */
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;
}
/* Finish form the last CodeTree code is changed to sign the
* end of the AND list */
group->code = XBC_NOOP;
if (group)
group->group = tree;
}
}
else
/* Identity of AND is T */
com_Bytecode(com, XBC_T);
}
void
Com_Block(LispCom *com, LispBuiltin *builtin)
/*
block name &rest body
*/
{
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
/* Just load NIL without starting an empty block */
com_Bytecode(com, XBC_NIL);
}
void
Com_C_r(LispCom *com, LispBuiltin *builtin)
/*
c[ad]{1,4}r list
*/
{
LispObj *list;
char *desc;
list = ARGUMENT(0);
desc = STRFUN(builtin);
if (*desc == 'F') /* FIRST */
desc = "CAR";
else if (*desc == 'R') /* REST */
desc = "CDR";
/* Check if it is a list of constants */
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)
/*
cond &rest body
*/
{
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;
/* The code to execute if the test is true */
ComProgn(com, CDR(code));
/* Add a node signaling the end of the PROGN code */
tree = NEW_TREE(CodeTreeCond);
tree->code = XBC_JUMPT;
if (group)
group->group = tree;
group = tree;
}
}
if (!count)
com_Bytecode(com, XBC_NIL);
else
/* Where to jump after T progn */
group->code = XBC_NOOP;
}
void
Com_Cons(LispCom *com, LispBuiltin *builtin)
/*
cons car cdr
*/
{
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)
/*
consp object
*/
{
ComPredicate(com, builtin, XBP_CONSP);
}
void
Com_Dolist(LispCom *com, LispBuiltin *builtin)
/*
dolist init &rest body
*/
{
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;
/* Generate code for the body of the form.
* The generated code uses two objects unavailable to user code,
* in the format:
* (block NIL
* (let ((? list) (item NIL))
* (tagbody
* . ; the DOT object as a label
* (when (consp list)
* (setq item (car ?))
* @body ; code to be executed
* (setq ? (cdr ?))
* (go .)
* )
* )
* (setq item nil)
* result
* )
* )
*/
/* XXX All of the logic below should be simplified at some time
* by adding more opcodes for compound operations ... */
/* Relative offsets the locally added variables will have at run time */
unbound = lisp__data.env.length - lisp__data.env.lex;
item = unbound + 1;
/* Start BLOCK NIL */
FORM_ENTER();
CompileIniBlock(com, LispBlockTag, NIL);
/* Add the <?> variable */
ComPush(com, UNBOUND, list, 1, 0, 0);
/* Add the <item> variable */
ComPush(com, symbol, NIL, 0, 0, 0);
/* Stack length is increased */
CompileStackEnter(com, 2, 0);
/* Bind variables */
com_Bind(com, 2);
com->block->bind += 2;
lisp__data.env.head += 2;
/* Remember that iteration variable is used even if it not referenced */
COM_VARIABLE_USED(symbol->data.atom);
/* Initialize the TAGBODY */
FORM_ENTER();
CompileIniBlock(com, LispBlockBody, NIL);
/* Create the <.> label */
ComLabel(com, DOT);
/* Load <?> variable */
com_BytecodeShort(com, XBC_LOAD, unbound);
/* Check if <?> is a list */
com_BytecodeChar(com, XBC_PRED, XBP_CONSP);
/* Start WHEN block */
group = NEW_TREE(CodeTreeJumpIf);
group->code = XBC_JUMPNIL;
/* Load <?> again */
com_BytecodeShort(com, XBC_LOAD, unbound);
/* Get CAR of <?> */
com_Bytecode(com, XBC_CAR);
/* Store it in <item> */
com_BytecodeShort(com, XBC_SET, item);
/* Execute @BODY */
ComProgn(com, body);
/* Load <?> again */
com_BytecodeShort(com, XBC_LOAD, unbound);
/* Get CDR of <?> */
com_Bytecode(com, XBC_CDR);
/* Change value of <?> */
com_BytecodeShort(com, XBC_SET, unbound);
/* GO back to <.> */
tree = NEW_TREE(CodeTreeGo);
tree->data.object = DOT;
/* Finish WHEN block */
tree = NEW_TREE(CodeTreeJumpIf);
tree->code = XBC_NOOP;
group->group = tree;
/* Finish the TAGBODY */
CompileFiniBlock(com);
FORM_LEAVE();
/* Set <item> to NIL, in case result references it...
* Loaded value is NIL as the CONSP predicate */
com_BytecodeShort(com, XBC_SET, item);
/* Evaluate <result> */
ComEval(com, result);
/* Unbind variables */
lisp__data.env.head -= 2;
lisp__data.env.length -= 2;
com->block->bind -= 2;
com_Unbind(com, 2);
/* Stack length is reduced. */
CompileStackLeave(com, 2, 0);
/* Finish BLOCK NIL */
CompileFiniBlock(com);
FORM_LEAVE();
}
void
Com_Eq(LispCom *com, LispBuiltin *builtin)
/*
eq left right
eql left right
equal left right
equalp left right
*/
{
LispObj *left, *right;
LispByteOpcode code;
char *name;
right = ARGUMENT(1);
left = ARGUMENT(0);
CompileStackEnter(com, 1, 1);
/* Just like preparing to call a builtin function */
ComEval(com, left);
com_Bytecode(com, XBC_PUSH);
/* The second argument is now loaded */
ComEval(com, right);
/* Compare arguments and restore builtin stack */
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)
/*
go tag
*/
{
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));
/* Unbind any local variables */
com_Unbind(com, bind);
tree = NEW_TREE(CodeTreeGo);
tree->data.object = tag;
}
void
Com_If(LispCom *com, LispBuiltin *builtin)
/*
if test then &optional else
*/
{
CodeTree *group, *tree;
LispObj *test, *then, *oelse;
oelse = ARGUMENT(2);
then = ARGUMENT(1);
test = ARGUMENT(0);
/* Build code to execute test */
ComEval(com, test);
/* Add jump node to use if test is NIL */
group = NEW_TREE(CodeTreeJumpIf);
group->code = XBC_JUMPNIL;
/* Build T code */
ComEval(com, then);
if (oelse != UNSPEC) {
/* Remember start of NIL code */
tree = NEW_TREE(CodeTreeJump);
tree->code = XBC_JUMP;
group->group = tree;
group = tree;
/* Build NIL code */
ComEval(com, oelse);
}
/* Remember jump of T code */
tree = NEW_TREE(CodeTreeJumpIf);
tree->code = XBC_NOOP;
group->group = tree;
}
void
Com_Last(LispCom *com, LispBuiltin *builtin)
/*
last list &optional count
*/
{
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)
/*
length sequence
*/
{
LispObj *sequence;
sequence = ARGUMENT(0);
ComEval(com, sequence);
com_Bytecode(com, XBC_LENGTH);
}
void
Com_Let(LispCom *com, LispBuiltin *builtin)
/*
let init &rest body
*/
{
int count;
LispObj *symbol, *value, *pair;
LispObj *init, *body;
body = ARGUMENT(1);
init = ARGUMENT(0);
if (init == NIL) {
/* If no local variables */
ComProgn(com, body);
return;
}
CHECK_CONS(init);
/* Could optimize if the body is empty and the
* init form is known to have no side effects */
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);
/* Add the variable */
ComPush(com, symbol, value, 1, 0, 0);
}
/* Stack length is increased */
CompileStackEnter(com, count, 0);
/* Bind the added variables */
com_Bind(com, count);
com->block->bind += count;
lisp__data.env.head += count;
/* Generate code for the body of the form */
ComProgn(com, body);
/* Unbind the added variables */
lisp__data.env.head -= count;
lisp__data.env.length -= count;
com->block->bind -= count;
com_Unbind(com, count);
/* Stack length is reduced. */
CompileStackLeave(com, count, 0);
}
void
Com_Letx(LispCom *com, LispBuiltin *builtin)
/*
let* init &rest body
*/
{
int count;
LispObj *symbol, *value, *pair;
LispObj *init, *body;
body = ARGUMENT(1);
init = ARGUMENT(0);
if (init == NIL) {
/* If no local variables */
ComProgn(com, body);
return;
}
CHECK_CONS(body);
/* Could optimize if the body is empty and the
* init form is known to have no side effects */
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);
/* LET* is identical to &AUX arguments, just bind the symbol */
ComPush(com, symbol, value, 1, 0, 0);
/* Every added variable is binded */
com_Bind(com, 1);
/* Must be binded at compile time also */
++lisp__data.env.head;
++com->block->bind;
}
/* Generate code for the body of the form */
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)
/*
listp object
*/
{
ComPredicate(com, builtin, XBP_LISTP);
}
void
Com_Loop(LispCom *com, LispBuiltin *builtin)
/*
loop &rest body
*/
{
CodeTree *tree, *group;
LispObj *body;
body = ARGUMENT(0);
/* Start NIL block */
CompileIniBlock(com, LispBlockTag, NIL);
/* Insert node to mark LOOP start */
tree = NEW_TREE(CodeTreeJump);
tree->code = XBC_NOOP;
/* Execute @BODY */
if (CONSP(body))
ComProgn(com, body);
else
/* XXX bytecode.c code require that blocks have at least one opcode */
com_Bytecode(com, XBC_NIL);
/* Insert node to jump of start of LOOP */
group = NEW_TREE(CodeTreeJump);
group->code = XBC_JUMP;
group->group = tree;
/* Finish NIL block */
CompileFiniBlock(com);
}
void
Com_Nthcdr(LispCom *com, LispBuiltin *builtin)
/*
nthcdr index list
*/
{
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)
/*
null list
*/
{
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)
/*
numberp object
*/
{
ComPredicate(com, builtin, XBP_NUMBERP);
}
void
Com_Or(LispCom *com, LispBuiltin *builtin)
/*
or &rest args
*/
{
LispObj *args;
args = ARGUMENT(0);
if (CONSP(args)) {
/* Evaluate first argument */
ComEval(com, CAR(args));
args = CDR(args);
/* If more than one argument, create jump list */
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;
}
/* Finish form the last CodeTree code is changed to sign the
* end of the AND list */
group->code = XBC_NOOP;
group->group = tree;
}
}
else
/* Identity of OR is NIL */
com_Bytecode(com, XBC_NIL);
}
void
Com_Progn(LispCom *com, LispBuiltin *builtin)
/*
progn &rest body
*/
{
LispObj *body;
body = ARGUMENT(0);
ComProgn(com, body);
}
void
Com_Return(LispCom *com, LispBuiltin *builtin)
/*
return &optional result
*/
{
ComReturnFrom(com, builtin, 0);
}
void
Com_ReturnFrom(LispCom *com, LispBuiltin *builtin)
/*
return-from name &optional result
*/
{
ComReturnFrom(com, builtin, 1);
}
void
Com_Rplac_(LispCom *com, LispBuiltin *builtin)
/*
rplac[ad] place value
*/
{
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)
/*
setq &rest form
*/
{
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);
/* Generate code to load value */
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)
/*
tagbody &rest body
*/
{
LispObj *body;
body = ARGUMENT(0);
if (CONSP(body)) {
CompileIniBlock(com, LispBlockBody, NIL);
ComProgn(com, body);
/* Tagbody returns NIL */
com_Bytecode(com, XBC_NIL);
CompileFiniBlock(com);
}
else
/* Tagbody always returns NIL */
com_Bytecode(com, XBC_NIL);
}
void
Com_Unless(LispCom *com, LispBuiltin *builtin)
/*
unless test &rest body
*/
{
CodeTree *group, *tree;
LispObj *test, *body;
body = ARGUMENT(1);
test = ARGUMENT(0);
/* Generate code to evaluate test */
ComEval(com, test);
/* Add node after test */
group = NEW_TREE(CodeTreeJumpIf);
group->code = XBC_JUMPT;
/* Generate NIL code */
ComProgn(com, body);
/* Insert node to know where to jump if test is T */
tree = NEW_TREE(CodeTreeJumpIf);
tree->code = XBC_NOOP;
group->group = tree;
}
void
Com_Until(LispCom *com, LispBuiltin *builtin)
/*
until test &rest body
*/
{
CodeTree *tree, *group, *ltree, *lgroup;
LispObj *test, *body;
body = ARGUMENT(1);
test = ARGUMENT(0);
/* Insert node to mark LOOP start */
ltree = NEW_TREE(CodeTreeJump);
ltree->code = XBC_NOOP;
/* Build code for test */
ComEval(com, test);
group = NEW_TREE(CodeTreeJumpIf);
group->code = XBC_JUMPT;
/* Execute @BODY */
ComProgn(com, body);
/* Insert node to jump to test again */
lgroup = NEW_TREE(CodeTreeJump);
lgroup->code = XBC_JUMP;
lgroup->group = ltree;
/* Insert node to know where to jump if test is T */
tree = NEW_TREE(CodeTreeJumpIf);
tree->code = XBC_NOOP;
group->group = tree;
}
void
Com_When(LispCom *com, LispBuiltin *builtin)
/*
when test &rest body
*/
{
CodeTree *group, *tree;
LispObj *test, *body;
body = ARGUMENT(1);
test = ARGUMENT(0);
/* Generate code to evaluate test */
ComEval(com, test);
/* Add node after test */
group = NEW_TREE(CodeTreeJumpIf);
group->code = XBC_JUMPNIL;
/* Generate T code */
ComProgn(com, body);
/* Insert node to know where to jump if test is NIL */
tree = NEW_TREE(CodeTreeJumpIf);
tree->code = XBC_NOOP;
group->group = tree;
}
void
Com_While(LispCom *com, LispBuiltin *builtin)
/*
while test &rest body
*/
{
CodeTree *tree, *group, *ltree, *lgroup;
LispObj *test, *body;
body = ARGUMENT(1);
test = ARGUMENT(0);
/* Insert node to mark LOOP start */
ltree = NEW_TREE(CodeTreeJump);
ltree->code = XBC_NOOP;
/* Build code for test */
ComEval(com, test);
group = NEW_TREE(CodeTreeJumpIf);
group->code = XBC_JUMPNIL;
/* Execute @BODY */
ComProgn(com, body);
/* Insert node to jump to test again */
lgroup = NEW_TREE(CodeTreeJump);
lgroup->code = XBC_JUMP;
lgroup->group = ltree;
/* Insert node to know where to jump if test is NIL */
tree = NEW_TREE(CodeTreeJumpIf);
tree->code = XBC_NOOP;
group->group = tree;
}
/***********************************************************************
* Com_XXX helper functions
***********************************************************************/
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);
}
}
/* XXX Could receive an argument telling if is the last statement in the
* block(s), i.e. if a jump opcode should be generated or just the
* evaluation of the returned value. Probably this is better done in
* an optimization step. */
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)
/* A function call */
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));
/* Generate code to load result */
ComEval(com, result);
/* Check for added variables that the jump is skiping the unbind opcode */
com_Unbind(com, bind);
tree = NEW_TREE(CodeTreeReturn);
tree->data.block = block;
}
/***********************************************************************
* Helper functions
***********************************************************************/
static int
ComConstantp(LispCom *com, LispObj *object)
{
switch (OBJECT_TYPE(object)) {
case LispAtom_t:
/* Keywords are guaranteed to evaluate to itself */
if (object->data.atom->package == lisp__data.keyword)
break;
return (0);
/* Function call */
case LispCons_t:
/* Need macro expansion, these are special abstract objects */
case LispQuote_t:
case LispBackquote_t:
case LispComma_t:
case LispFunctionQuote_t:
return (0);
/* Anything else is a literal constant */
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->key && !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));
/* Variable was inserted in the middle of the list */
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)
/* Just load <symbol> from the byte stream, keywords are
* guaranteed to evaluate to itself. */
return (SYMBOL_KEYWORD);
return (SYMBOL_CONSTANT);
}
offset = name->offset;
id = name->key;
base = lisp__data.env.lex;
i = lisp__data.env.head - 1;
/* If variable is local */
if (offset <= i && offset >= com->lex && lisp__data.env.names[offset] == id) {
COM_VARIABLE_USED(name);
/* Relative offset */
return (offset - base);
}
/* name->offset may have been changed in a macro expansion */
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->key->value);
}
/* Not found, resolve <symbol> at run time */
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;
/* Descend block list if an argument to function being called
* has the same name as a bound variable in the current function.
*/
if ((flag & VARIABLE_ARGUMENT) ||
!(block->variables.flags[i] & VARIABLE_ARGUMENT))
break;
}
block = block->prev;
}
}
/***********************************************************************
* Bytecode compiler functions
***********************************************************************/
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));
/* Reserve space, will be used at link time when
* resolving GO jumps. */
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> is set, it is pushing an argument to one of
* Com_XXX functions. */
if (compile) {
if (builtin)
lisp__data.stack.values[lisp__data.stack.length++] = value;
else
ComAddVariable(com, symbol, value);
return;
}
/* If <com->macro> is set, it is expanding a macro, just add the local
* variable <symbol> bounded to <value>, so that it will be available
* when calling the interpreter to expand the macro. */
else if (com->macro) {
ComAddVariable(com, symbol, value);
return;
}
/* If <eval> is set, it must generate the opcodes to evaluate <value>.
* If <value> is a constant, just generate the opcodes to load it. */
else if (eval && !ComConstantp(com, value)) {
switch (OBJECT_TYPE(value)) {
case LispAtom_t: {
int offset = ComGetVariable(com, value);
if (offset >= 0) {
/* Load <value> from user stack at the relative offset */
if (builtin)
com_LoadPush(com, offset);
else
com_LoadLet(com, offset, symbol->data.atom);
}
/* ComConstantp() does not return true for this, as the
* current value must be computed. */
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 {
/* Load value bound to <value> at run time */
if (builtin)
com_LoadSymPush(com, value->data.atom);
else
com_LoadSymLet(com, value->data.atom,
symbol->data.atom);
}
} break;
default:
/* Generate code to evaluate <value> */
ComEval(com, value);
if (builtin)
com_Bytecode(com, XBC_PUSH);
else
com_Let(com, symbol->data.atom);
break;
}
/* Remember <symbol> will be bound, <value> only matters for
* the Com_XXX functions */
if (builtin)
lisp__data.stack.values[lisp__data.stack.length++] = value;
else
ComAddVariable(com, symbol, value);
return;
}
if (builtin) {
/* Load <value> as a constant in builtin stack */
com_LoadConPush(com, value);
lisp__data.stack.values[lisp__data.stack.length++] = value;
}
else {
/* Load <value> as a constant in stack */
com_LoadConLet(com, value, symbol->data.atom);
/* Remember <symbol> will be bound */
ComAddVariable(com, symbol, value);
}
}
/* This function does almost the same job as LispMakeEnvironment, but
* it is not optimized for speed, as it is not building argument lists
* to user code, but to Com_XXX functions, or helping in generating the
* opcodes to load arguments at bytecode run time. */
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;
/* This should never be executed, but make the check for safety */
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 arguments */
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 */
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;
/* default arguments are evaluated for macros */
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 */
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;
/* Check if arguments are correctly specified */
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
/* Just make the error test true */
i = alist->keys.num_symbols;
if (i == alist->keys.num_symbols) {
/* If not in argument specification list... */
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));
}
/* Add variables */
for (i = 0; i < alist->keys.num_symbols; i++) {
val = defaults[i];
varset = 0;
if (!builtin && keys[i]) {
Atom_id atom = ATOMID(keys[i]);
/* Special keyword specification, need to compare ATOMID
* and keyword specification must be a quoted object */
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 {
/* Normal keyword specification, can compare object pointers,
* as they point to the same object in the keyword package */
for (karg = values; CONSP(karg); karg = CDR(karg)) {
/* Don't check if argument is a valid keyword or
* special quoted keyword */
if (symbols[i] == CAR(karg)) {
val = CADR(karg);
varset = 1;
break;
}
karg = CDR(karg);
}
}
/* Add the variable to environment */
if (varset) {
ComPush(com, symbols[i], val, eval, builtin, compile);
if (sforms[i])
ComPush(com, sforms[i], T, 0, builtin, compile);
}
else {
/* default arguments are evaluated for macros */
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') {
/* &KEY uses all remaining arguments */
values = NIL;
goto aux_label;
}
goto finished_label;
/* &REST */
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;
/* Count number of arguments and check if it is a list of constants */
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)->value : NULL;
/* XXX FIXME should have a flag indicating if function call
* change the &REST arguments even if it is a constant list
* (or if the returned value may be changed). */
if (string && (count < MAX_BCONS || constantp) &&
strcmp(string, "LIST") &&
strcmp(string, "APPLY") && /* XXX depends on function argument */
strcmp(string, "VECTOR") &&
/* Append does not copy the last/single list */
(strcmp(string, "APPEND") || !CONSP(car))) {
if (constantp) {
/* If the builtin function changes the &REST parameters, must
* define a Com_XXX function for it. */
ComPush(com, alist->rest, values, 0, builtin, compile);
}
else {
CompileStackEnter(com, count - 1, 1);
for (; CONSP(CDR(values)); values = CDR(values)) {
/* Evaluate this argument */
ComEval(com, CAR(values));
/* Save result in builtin stack */
com_Bytecode(com, XBC_PUSH);
}
CompileStackLeave(com, count - 1, 1);
/* The last argument is not saved in the stack */
ComEval(com, CAR(values));
values = NIL;
com_Bytecode(com, (LispByteOpcode)(XBC_BCONS + (count - 1)));
}
}
else {
/* Allocate a fresh list of cons */
/* Generate code to load object */
ComEval(com, CAR(values));
com->stack.cpstack += 2;
if (com->stack.pstack < com->stack.cpstack)
com->stack.pstack = com->stack.cpstack;
/* Start building a gc protected list, with the loaded value */
com_Bytecode(com, XBC_LSTAR);
for (values = CDR(values); CONSP(values); values = CDR(values)) {
/* Generate code to load object */
ComEval(com, CAR(values));
/* Add loaded value to gc protected list */
com_Bytecode(com, XBC_LCONS);
}
/* Finish gc protected list */
com_Bytecode(com, XBC_LFINI);
/* Push loaded value */
if (builtin)
com_Bytecode(com, XBC_PUSH);
else {
com_Let(com, alist->rest->data.atom);
/* Remember this symbol will be bound */
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 */
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 one of:
* o expanding a macro
* o calling a builtin special form
* o builtin function is a macro
* don't evaluate arguments. */
if (com->macro || compile || builtin->type == LispMacro)
eval = 0;
if (!com->macro && builtin->type == LispMacro) {
/* Set flag of variable used, in case variable is only
* used as a builtin macro argument. */
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);
/* Build argument list in the interpreter stacks */
base = ComCall(com, alist, function, arguments,
eval, 1, compile);
/* If <compile> is set, it is a special form */
if (compile)
builtin->compile(com, builtin);
/* Else, generate opcodes to call builtin function */
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> is set, expand macro */
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->key->value,
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);
/* Build argument list in the interpreter stacks */
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 {
/* Not yet defined function/macro. */
++com->warnings;
LispWarning("call to undefined function %s", atom->key->value);
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:
/* XXX If bytecode objects are made available, should
* handle it here. */
LispDestroy("EVAL: %s is invalid as a function",
STROBJ(function));
/*NOTREACHED*/
break;
}
}
/* Generate opcodes for an implicit PROGN */
static void
ComProgn(LispCom *com, LispObj *code)
{
if (CONSP(code)) {
for (; CONSP(code); code = CDR(code))
ComEval(com, CAR(code));
}
else
/* If no code to execute, empty PROGN returns NIL */
com_Bytecode(com, XBC_NIL);
}
/* Generate opcodes to evaluate <object>. */
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)
/* Load from user stack at relative offset */
com_Load(com, offset);
else if (offset == SYMBOL_KEYWORD)
com_LoadCon(com, object);
else if (offset == SYMBOL_CONSTANT)
/* Symbol defined as constant, just load it's value */
com_LoadCon(com, LispGetVar(object));
else
/* Load value bound to symbol at run time */
com_LoadSym(com, object->data.atom);
}
break;
case LispCons_t: {
/* Macro expansion may be done in the object form */
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:
/* Macro expansion is stored in the current value of com->form */
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 will only be associated with bytecode later,
* so, make sure it is protected until compilation finishes */
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;
}
/*FALLTROUGH*/
default:
/* Constant object */
com_LoadCon(com, object);
break;
}
}
/***********************************************************************
* Lambda expansion helper functions
***********************************************************************/
static void
ComRecursiveCall(LispCom *com, LispArgList *alist,
LispObj *name, LispObj *arguments)
{
int base, lex;
/* Save state */
lex = lisp__data.env.lex;
FORM_ENTER();
/* Generate code to push function arguments in the stack */
base = ComCall(com, alist, name, arguments, 1, 0, 0);
/* Stack will grow this amount */
CompileStackEnter(com, alist->num_arguments, 0);
#if 0
/* Make the variables available at run time */
com_Bind(com, alist->num_arguments);
com->block->bind += alist->num_arguments;
#endif
com_BytecodeChar(com, XBC_LETREC, alist->num_arguments);
#if 0
/* The variables are now unbound */
com_Unbind(com, alist->num_arguments);
com->block->bind -= alist->num_arguments;
#endif
/* Stack length is reduced */
CompileStackLeave(com, alist->num_arguments, 0);
FORM_LEAVE();
/* Restore state */
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;
/* Save state */
lex = lisp__data.env.lex;
FORM_ENTER();
/* Start the inline function block */
CompileIniBlock(com, LispBlockClosure, name);
/* Generate code to push function arguments in the stack */
base = ComCall(com, alist, name, arguments, 1, 0, 0);
/* Stack will grow this amount */
CompileStackEnter(com, alist->num_arguments, 0);
/* Make the variables available at run time */
com_Bind(com, alist->num_arguments);
com->block->bind += alist->num_arguments;
/* Expand the lambda list */
ComProgn(com, lambda);
/* The variables are now unbound */
com_Unbind(com, alist->num_arguments);
com->block->bind -= alist->num_arguments;
/* Stack length is reduced */
CompileStackLeave(com, alist->num_arguments, 0);
/* Finish the inline function block */
CompileFiniBlock(com);
FORM_LEAVE();
/* Restore state */
lisp__data.env.lex = lex;
lisp__data.env.head = lisp__data.env.length = base;
}
/***********************************************************************
* Macro expansion helper functions.
***********************************************************************/
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);
/* Macro expansion requires bounded symbols */
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;
/* Save interpreter state */
interpreter_base = lisp__data.stack.length;
interpreter_head = lisp__data.env.length;
interpreter_lex = lisp__data.env.lex;
/* Use the variables */
*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 tried to jump out of the macro expansion block */
if (!lisp__data.destroyed && jumped)
LispDestroy("*** EVAL: bad jump in macro expansion");
/* Macro expansion did something wrong */
if (lisp__data.destroyed) {
LispMessage("*** EVAL: aborting macro expansion");
LispDestroy(".");
}
/* Restore interpreter state */
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;
/* Macro is expanded, store the result */
CAR(com->form) = body;
ComEval(com, body);
}
static void
ComMacroBackquote(LispCom *com, LispObj *lambda)
{
LispObj *body;
++com->macro;
body = ComMacroExpand(com, lambda);
--com->macro;
/* Macro is expanded, store the result */
CAR(com->form) = body;
com_LoadCon(com, body);
}
Reference in New Issue View Git Blame Copy Permalink