Compx86.cpp

// -------------------------------
// Copyright (c) Corman Technologies Inc.
// See LICENSE.txt for license information.
// -------------------------------
//
// File: compx86.cpp
// Contents: 80x86 bootstrap compiler for Corman Lisp
// History: 6/19/96 RGC Created.
// 11/16/99 RGC Lexical functions now are given priority
// over inlined ones.
// 1/18/00 RGC Compiler undefined function warnings are now
// appended to *undefined-functions* in some
// circumstances.
// 2/27/01 RGC Modified code generation of UNWIND-PROTECT
// to correctly handle return from the cleanup
// clauses via RETURN or GO.
// 6/13/01 RGC compileLambdaExpression() skips declarations when
// searching for the first block (for the name).
// 7/29/01 RGC Fixed a problem with LET* and special variable
// bindings that would show up if the initializer of
// a variable caused a non-local exit.
// Fixed a problem with THROW and the number of returned values.
// 10/10/01 RGC Fixed a problem with OPTIMIZE declarations.
// Added support for LOCALLY, LOAD-TIME-VALUE.
// 02/27/03 RGC Fixed incorrect implementation of LOAD-TIME-VALUE.
// 09/21/03 RGC Fixed a bug in the compiler when multiple blocks with the same 
// name are used in a function.
//
//
//
#include"stdafx.h"
#include<setjmp.h>
#include<assert.h>

#include"generic.h"
#include"lisp.h"
#include"compx86.h"
#include"lispmath.h"

typedef LispObj LispObj;

staticint ExpandMacrosInline = 1;

#defineCURRENT_IP (CBlength())
#defineCURRENT_IP_RAW (integer(CBlength()))


// static functions
static LispObj compileList(LispObj, LispObj, LispObj resultType);
static LispObj compileSymbol(LispObj, LispObj, LispObj resultType);
static LispObj compileSpecialOperator(LispObj, LispObj, LispObj resultType);
static LispObj compileFunctionCallForm(LispObj, LispObj);
static LispObj compileFunctionExpressionForm(LispObj, LispObj, LispObj resultType);
static LispObj compileLiteralForm(LispObj, LispObj, LispObj resultType);
static LispObj compileQuoteForm(LispObj, LispObj);
static LispObj compileSetqForm(LispObj, LispObj);
static LispObj compileFunctionSpecialOperator(LispObj, LispObj);
static LispObj compileBlockForm(LispObj, LispObj);
static LispObj compilePrognForm(LispObj, LispObj);
static LispObj compileNil(LispObj);
static LispObj compileIfForm(LispObj, LispObj);
static LispObj compileLetForm(LispObj, LispObj);
static LispObj compileFletForm(LispObj, LispObj);
static LispObj compileLabelsForm(LispObj, LispObj);
static LispObj compileLetstarForm(LispObj, LispObj);
static LispObj compileLoadTimeValueForm(LispObj, LispObj);
static LispObj compileLocallyForm(LispObj, LispObj);
static LispObj compileTagbodyForm(LispObj, LispObj);
static LispObj compileGoForm(LispObj, LispObj);
static LispObj compileReturnFromForm(LispObj, LispObj);
static LispObj compilePlusFunctionCall(LispObj, LispObj, LispObj resultType);
static LispObj compileMinusFunctionCall(LispObj, LispObj, LispObj resultType);
static LispObj compileNumericEqualFunctionCall(LispObj, LispObj);
static LispObj compileNumericCompareFunctionCall(LispObj, LispObj);
static LispObj compileConsFunctionCall(LispObj, LispObj);
static LispObj compileEqFunctionCall(LispObj, LispObj);
static LispObj compileCarFunctionCall(LispObj, LispObj);
static LispObj compileCdrFunctionCall(LispObj, LispObj);
static LispObj compileNullFunctionCall(LispObj, LispObj);
static LispObj compileArefFunctionCall(LispObj, LispObj);
static LispObj compileSetfArefFunctionCall(LispObj, LispObj);
static LispObj compileUrefFunctionCall(LispObj, LispObj);
static LispObj compileUrefSetFunctionCall(LispObj, LispObj);
static LispObj compileCatchForm(LispObj, LispObj);
static LispObj compileThrowForm(LispObj, LispObj);
static LispObj compileUnwindProtectForm(LispObj, LispObj);
static LispObj compileMultipleValueCallForm(LispObj, LispObj);
static LispObj compileEvalWhenForm(LispObj, LispObj);
static LispObj compileMultipleValueProg1Form(LispObj, LispObj);
static LispObj compileTheForm(LispObj, LispObj);
static LispObj compileCaptureCompilerEnvironmentForm(LispObj, LispObj);

static LispObj findLambdas(LispObj x);
static LispObj referencedByEmbeddedLambdas(LispObj sym);
staticvoidcompileVariableHeapBindings(LispObj newVars);
staticvoidcompileFunctionHeapBindings(LispObj newVars);

staticvoidprolog(long envSize);
staticvoidepilog(long envSize);
staticvoidcompileLambdaProlog(long envSize, LispObj needEBX, LispObj saveECX);
staticvoidcompileLambdaEpilog(LispObj needEBX);
staticvoidcompileArgsCheck(long num);
staticvoidcompileArgsRangeCheck(long low, long high);

static LispObj findRequiredArgs(LispObj lambdaList);
static LispObj findOptionalArgs(LispObj lambdaList);
static LispObj findRestArgs(LispObj lambdaList);
static LispObj findKeyArgs(LispObj lambdaList);
static LispObj findAuxArgs(LispObj lambdaList);
static LispObj findAllowOtherKeys(LispObj lambdaList);
static LispObj compileLambdaRequiredArgs(LispObj args, LispObj newVars, LispObj useBPOffset);
static LispObj compileLambdaOptionalArgs(LispObj args, LispObj newVars, LispObj argIndex);
static LispObj compileLambdaRestArgs(LispObj args, LispObj newVars, LispObj argIndex);
static LispObj compileLambdaKeyArgs(LispObj args, LispObj newVars, LispObj argIndex, LispObj allowOtherKeys);
static LispObj compileLambdaAuxArgs(LispObj args, LispObj newVars);
staticintisConstantObject(LispObj x);
static LispObj findLexFunction(LispObj sym);
staticvoidrestoreOptimizeDeclarationBindings(LispObj bindings);
static LispObj processOptimizeDeclarations(LispObj declareForms);
static LispObj processSpecialDeclarations(LispObj declareForms);
static LispObj processTypeDeclarations(LispObj declareForms);
static LispObj processDynamicExtentDeclarations(LispObj declareForms);
staticvoidpushTypeDeclaration(LispObj variable, LispObj type);
staticvoidpopTypeDeclarations(LispObj numVars);
staticvoidpushDEDeclaration(LispObj variable);
staticvoidpopDEDeclarations(LispObj numVars);
static LispObj isSymbolTypeSpecifier(LispObj symbol);
static LispObj findVariableType(LispObj variable);
static LispObj isDynamicExtent(LispObj var);
static LispObj findFunctionType(LispObj func);
static LispObj findEmbeddedReturnForms(LispObj sym, LispObj form, LispObj labels);
static LispObj findEmbeddedGoForms(LispObj sym, LispObj form);
static LispObj findBlockIncludingOuterLambdas(LispObj label);
static LispObj findTagbodyTag(LispObj tag);
static LispObj findTagIncludingOuterLambdas(LispObj tag);
static LispObj findBlockLabels(LispObj outer, LispObj target, LispObj labels);

static LispObj compileLexicalEntity(LispObj sym, LispObj dest, LispObj type);
static LispObj compileLexicalSlot(LispObj sym, LispObj dest, LispObj type);
static LispObj compileCurrentEnvironment(LispObj x, LispObj dest);
staticvoidaddCompilerFrameInfo(LispObj name, LispObj base, LispObj offset, LispObj indirect);
static LispObj processIgnoreDeclarations(LispObj declareForms);
static LispObj findVariableRecord(LispObj sym);
static LispObj compilerCheckTypes();
static LispObj compilerCheckArgsNum();
static LispObj compilerFoldConstants();
static LispObj compilerInlineFunctions();
static LispObj compilerOptimizeTailRecursion();
static LispObj compilerCheckKeyArgs();

#defineCODE_BUFFER_INFO1
#defineCODE_BUFFER_CBUF2
#defineCODE_BUFFER_REFS3
#defineCODE_BUFFER_CODE_INDEX4
#defineCODE_BUFFER_REF_INDEX5
#defineCODE_BUFFER_DYNAMIC_ENV_SIZE6
#defineCODE_BUFFER_HEAP_ENV_SIZE7
#defineCODE_BUFFER_STACK_INDEX8
#defineCODE_BUFFER_MAX_CODE_BYTES9
#defineCODE_BUFFER_MAX_REFS10
#defineCODE_BUFFER_SIZE11

#pragma warning (disable:4127) // conditional expression is constant
#pragma warning (disable:4244) // '=' : conversion from 'int' to 'unsigned char', possible loss of data

voidCBaddLong(unsignedlong b)
{
 LispObj buf = symbolValue(COMPILER_CODE_BUFFER);
 LispObj cbuf = UVECTOR(buf)[CODE_BUFFER_CBUF];
longindex = integer(UVECTOR(buf)[CODE_BUFFER_CODE_INDEX]);
byteArrayStart(cbuf)[index++] = (byte)(b & 0xff); 
byteArrayStart(cbuf)[index++] = (byte)((b >> 8) & 0xff); 
byteArrayStart(cbuf)[index++] = (byte)((b >> 16) & 0xff); 
byteArrayStart(cbuf)[index++] = (byte)((b >> 24) & 0xff); 
UVECTOR(buf)[CODE_BUFFER_CODE_INDEX] += wrapInteger(4);
if (UVECTOR(buf)[CODE_BUFFER_CODE_INDEX] >= UVECTOR(buf)[CODE_BUFFER_MAX_CODE_BYTES])
CBgrowCode();
}

voidCBaddByte(LispObj a)
{
 LispObj buf = symbolValue(COMPILER_CODE_BUFFER);
 LispObj cbuf = UVECTOR(buf)[CODE_BUFFER_CBUF];
longindex = integer(UVECTOR(buf)[CODE_BUFFER_CODE_INDEX]);
byteArrayStart(cbuf)[index] = (byte)(char)(integer(a)); 
UVECTOR(buf)[CODE_BUFFER_CODE_INDEX] += wrapInteger(1);
if (UVECTOR(buf)[CODE_BUFFER_CODE_INDEX] >= UVECTOR(buf)[CODE_BUFFER_MAX_CODE_BYTES])
CBgrowCode();
}

voidCBaddBytes(LispObj a, LispObj b)
{
 LispObj buf = symbolValue(COMPILER_CODE_BUFFER);
 LispObj cbuf = UVECTOR(buf)[CODE_BUFFER_CBUF];
longindex = integer(UVECTOR(buf)[CODE_BUFFER_CODE_INDEX]);
byteArrayStart(cbuf)[index++] = (byte)(char)(integer(a)); 
byteArrayStart(cbuf)[index++] = (byte)(char)(integer(b)); 
UVECTOR(buf)[CODE_BUFFER_CODE_INDEX] += wrapInteger(2);
if (UVECTOR(buf)[CODE_BUFFER_CODE_INDEX] >= UVECTOR(buf)[CODE_BUFFER_MAX_CODE_BYTES])
CBgrowCode();
}

voidCBaddBytes(LispObj a, LispObj b, LispObj c)
{
 LispObj buf = symbolValue(COMPILER_CODE_BUFFER);
 LispObj cbuf = UVECTOR(buf)[CODE_BUFFER_CBUF];
longindex = integer(UVECTOR(buf)[CODE_BUFFER_CODE_INDEX]);
byteArrayStart(cbuf)[index++] = (byte)(char)(integer(a)); 
byteArrayStart(cbuf)[index++] = (byte)(char)(integer(b)); 
byteArrayStart(cbuf)[index++] = (byte)(char)(integer(c)); 
UVECTOR(buf)[CODE_BUFFER_CODE_INDEX] += wrapInteger(3);
if (UVECTOR(buf)[CODE_BUFFER_CODE_INDEX] >= UVECTOR(buf)[CODE_BUFFER_MAX_CODE_BYTES])
CBgrowCode();
}

voidCBaddLongVal(LispObj a)
{
 LispObj buf = symbolValue(COMPILER_CODE_BUFFER);
 LispObj cbuf = UVECTOR(buf)[CODE_BUFFER_CBUF];
longindex = integer(UVECTOR(buf)[CODE_BUFFER_CODE_INDEX]);
long b = integer(a);
byteArrayStart(cbuf)[index++] = (byte)(b & 0xff);
byteArrayStart(cbuf)[index++] = (byte)((b >> 8) & 0xff); 
byteArrayStart(cbuf)[index++] = (byte)((b >> 16) & 0xff); 
byteArrayStart(cbuf)[index++] = (byte)((b >> 24) & 0xff); 
UVECTOR(buf)[CODE_BUFFER_CODE_INDEX] += wrapInteger(4);
if (UVECTOR(buf)[CODE_BUFFER_CODE_INDEX] >= UVECTOR(buf)[CODE_BUFFER_MAX_CODE_BYTES])
CBgrowCode();
}

voidCBaddObject(LispObj b)
{
 LispObj buf = symbolValue(COMPILER_CODE_BUFFER);
 LispObj cbuf = UVECTOR(buf)[CODE_BUFFER_CBUF];
longindex = integer(UVECTOR(buf)[CODE_BUFFER_CODE_INDEX]);
byteArrayStart(cbuf)[index++] = (byte)(b & 0xff);
byteArrayStart(cbuf)[index++] = (byte)((b >> 8) & 0xff); 
byteArrayStart(cbuf)[index++] = (byte)((b >> 16) & 0xff); 
byteArrayStart(cbuf)[index++] = (byte)((b >> 24) & 0xff); 
UVECTOR(buf)[CODE_BUFFER_CODE_INDEX] += wrapInteger(4);
if (UVECTOR(buf)[CODE_BUFFER_CODE_INDEX] >= UVECTOR(buf)[CODE_BUFFER_MAX_CODE_BYTES])
CBgrowCode();
}

voidCBsetByte(LispObj index, LispObj b)
{
 LispObj buf = symbolValue(COMPILER_CODE_BUFFER);
 LispObj cbuf = UVECTOR(buf)[CODE_BUFFER_CBUF];
byteArrayStart(cbuf)[integer(index)] = (byte)(integer(b) & 0xff); 
}

voidCBsetObject(LispObj index, LispObj x)
{
 LispObj buf = symbolValue(COMPILER_CODE_BUFFER);
 LispObj cbuf = UVECTOR(buf)[CODE_BUFFER_CBUF];
long i = integer(index);
byteArrayStart(cbuf)[i] = (byte)(x & 0xff); 
byteArrayStart(cbuf)[i + 1] = (byte)((x >> 8) & 0xff); 
byteArrayStart(cbuf)[i + 2] = (byte)((x >> 16) & 0xff); 
byteArrayStart(cbuf)[i + 3] = (byte)((x >> 24) & 0xff); 
}

voidCBsetLong(LispObj index, LispObj n)
{
 LispObj buf = symbolValue(COMPILER_CODE_BUFFER);
 LispObj cbuf = UVECTOR(buf)[CODE_BUFFER_CBUF];
long i = integer(index);
long x = integer(n);
byteArrayStart(cbuf)[i] = (byte)(x & 0xff); 
byteArrayStart(cbuf)[i + 1] = (byte)((x >> 8) & 0xff); 
byteArrayStart(cbuf)[i + 2] = (byte)((x >> 16) & 0xff); 
byteArrayStart(cbuf)[i + 3] = (byte)((x >> 24) & 0xff); 
}

voidCBref(LispObj obj, LispObj pos)
{
 LispObj buf = symbolValue(COMPILER_CODE_BUFFER);
 LispObj refs = UVECTOR(buf)[CODE_BUFFER_REFS];
long refIndex = integer(UVECTOR(buf)[CODE_BUFFER_REF_INDEX]);
arrayStart(refs)[refIndex++] = obj;
arrayStart(refs)[refIndex++] = pos;
UVECTOR(buf)[CODE_BUFFER_REF_INDEX] += wrapInteger(2);
if (UVECTOR(buf)[CODE_BUFFER_REF_INDEX] >= UVECTOR(buf)[CODE_BUFFER_MAX_REFS])
CBgrowRefs();
}

// Return the position (in the code) of the last stored literal reference, as a wrapped
// integer.
LispObj CBLastRefPos()
{
 LispObj buf = symbolValue(COMPILER_CODE_BUFFER);
 LispObj refs = UVECTOR(buf)[CODE_BUFFER_REFS];
long refIndex = integer(UVECTOR(buf)[CODE_BUFFER_REF_INDEX]);
returnarrayStart(refs)[refIndex - 1];
}

voidCBaddJumpTableRef(LispObj sym)
{
if (symbolValue(COMPILER_COLLECT_JUMP_TABLE_REFS) != NIL)
setSymbolValue(CODE_JUMP_TABLE_REFS, 
cons(wrapInteger(CURRENT_IP_RAW - 4),
cons(sym,
symbolValue(CODE_JUMP_TABLE_REFS))));
}

voidCBaddEnvTableRef(LispObj sym)
{
if (symbolValue(COMPILER_COLLECT_JUMP_TABLE_REFS) != NIL)
setSymbolValue(CODE_ENV_TABLE_REFS, 
cons(wrapInteger(CURRENT_IP_RAW - 4),
cons(sym,
symbolValue(CODE_ENV_TABLE_REFS))));
}

voidCBaddVarTableRef(LispObj sym)
{
if (symbolValue(COMPILER_COLLECT_VAR_TABLE_REFS) != NIL)
setSymbolValue(CODE_VAR_TABLE_REFS, 
cons(wrapInteger(CURRENT_IP_RAW - 4),
cons(sym,
symbolValue(CODE_VAR_TABLE_REFS))));
}

//
// Returns offset (from EBP) of allocated block
//
LispObj CBincDynamicEnvSize(LispObj size)
{
 LispObj buf = symbolValue(COMPILER_CODE_BUFFER);
UVECTOR(buf)[CODE_BUFFER_DYNAMIC_ENV_SIZE] += size;
returnwrapInteger(-4) - UVECTOR(buf)[CODE_BUFFER_DYNAMIC_ENV_SIZE];
}

// add lexical variable binding
voidCBaddStackVar(LispObj sym, LispObj place)
{
CBpushCleanup(list(LET, sym, place, 0, END_LIST));
}

// add lexical function binding
voidCBaddStackFunction(LispObj sym, LispObj place)
{
CBpushCleanup(list(FLET, sym, place, 0, END_LIST));
}

voidCBaddHeapVar(LispObj sym, LispObj place)
{
CBpushCleanup(list(LET, sym, place, 0, END_LIST));
}

voidCBaddLabels(LispObj labels)
{
CBpushCleanup(list(TAGBODY, labels, CBstackIndex(), END_LIST));
}

voidCBaddBlock(LispObj block)
{
CBpushCleanup(list(BLOCK, block, CBstackIndex(), END_LIST));
}

// add a lambda marker
voidCBaddLambda()
{
CBpushCleanup(list(LAMBDA, END_LIST));
}

voidCBpushCleanup(LispObj rec)
{
setSymbolValue(COMPILER_CLEANUPS, cons(rec, CBcleanups()));
}

// pops and returns most recently added cleanup form
LispObj CBpopCleanup()
{
 LispObj form = 0;
 LispObj temp = CBcleanups();
 LispObj line = 0;
assert(isCons(temp));
 form = CAR(temp);
setSymbolValue(COMPILER_CLEANUPS, CDR(temp));
assert(isCons(form));
if (CAR(form) == LET && CAR(CDR(CDR(CDR(form)))) == 0)
 {
if (symbolValue(COMPILER_WARN_ON_UNUSED_VAR) != NIL)
 {
// warn of unused variable
if (symbolValue(SOURCE_FILE) == NIL)
 {
if (symbolValue(COMPILER_FUNCTION_NAME) == NIL)
LispCall3(Funcall, WARN,
stringNode("Unused variable ~A in anonymous function"),
CAR(CDR(form)));
else
LispCall4(Funcall, WARN,
stringNode("Unused variable ~A in function ~S"),
CAR(CDR(form)), symbolValue(COMPILER_FUNCTION_NAME));
 }
else
 {
// warn of unused variable
 line = symbolValue(SOURCE_LINE);
if (isFixnum(line))
 line += wrapInteger(1); // 1-based offset for message
LispCall6(Funcall, WARN,
stringNode("Unused variable ~A in function ~S, File ~A, line ~A"),
CAR(CDR(form)), symbolValue(COMPILER_FUNCTION_NAME),
symbolValue(SOURCE_FILE),
 line);
 }
 }
 }
if (CAR(form) == FLET && CAR(CDR(CDR(CDR(form)))) == 0)
 {
// warn of unused local function
 }
return form;
}

// returns whole list
LispObj CBcleanups()
{
returnsymbolValue(COMPILER_CLEANUPS);
}

// this must not trigger a garbage collection!
voidCBinsertCode(LispObj position, void* b, LispObj numBytes)
{
 LispObj buf = symbolValue(COMPILER_CODE_BUFFER);
 LispObj cbuf = UVECTOR(buf)[CODE_BUFFER_CBUF];
 LispObj refs = UVECTOR(buf)[CODE_BUFFER_REFS];
 LispObj jumpTableRefs = symbolValue(CODE_JUMP_TABLE_REFS);
 LispObj varTableRefs = symbolValue(CODE_VAR_TABLE_REFS);
 LispObj envTableRefs = symbolValue(CODE_ENV_TABLE_REFS);
 byte* code = byteArrayStart(cbuf);
 LispObj* r = arrayStart(refs);
 LispObj t1 = 0;
long i = 0;
long refIndex = integer(UVECTOR(buf)[CODE_BUFFER_REF_INDEX]);
long pos = integer(position);
long bytes = integer(numBytes);

while (UVECTOR(buf)[CODE_BUFFER_CODE_INDEX] + wrapInteger(numBytes) 
 >= UVECTOR(buf)[CODE_BUFFER_MAX_CODE_BYTES])
 {
 r = 0;
 code = 0;
CBgrowCode();
 cbuf = UVECTOR(buf)[CODE_BUFFER_CBUF];
 refs = UVECTOR(buf)[CODE_BUFFER_REFS];
 code = byteArrayStart(cbuf);
 r = arrayStart(refs);
 }

memmove(code + pos + bytes, code + pos, integer(CBlength()) - pos);
memmove(code + pos, b, bytes);
UVECTOR(buf)[CODE_BUFFER_CODE_INDEX] += numBytes;

// now update references
for (i = 0; i < refIndex; i+=2)
 {
if (integer(r[i + 1]) >= pos)
 r[i + 1] += numBytes;
 }

// if any LOAD-TIME-VALUE forms were compiled, add those here
 t1 = symbolValue(LOAD_TIME_VALUES);
while (isCons(t1))
 {
if (integer(CAR(CDR(t1))) >= pos)
CAR(CDR(t1)) += numBytes;
 t1 = CDR(CDR(t1));
 }

// update jump table references
while (isCons(jumpTableRefs))
 {
if (integer(CAR(jumpTableRefs)) >= pos)
CAR(jumpTableRefs) += numBytes;
 jumpTableRefs = CDR(CDR(jumpTableRefs));
 }

// update var table references
while (isCons(varTableRefs))
 {
if (integer(CAR(varTableRefs)) >= pos)
CAR(varTableRefs) += numBytes;
 varTableRefs = CDR(CDR(varTableRefs));
 }

// update env table references
while (isCons(envTableRefs))
 {
if (integer(CAR(envTableRefs)) >= pos)
CAR(envTableRefs) += numBytes;
 envTableRefs = CDR(CDR(envTableRefs));
 }

 code = 0;
 r = 0;
}

voidCBincStackIndex(LispObj num)
{ 
UVECTOR(symbolValue(COMPILER_CODE_BUFFER))[CODE_BUFFER_STACK_INDEX] += num; 
}

voidCBdecStackIndex(LispObj num)
{ 
UVECTOR(symbolValue(COMPILER_CODE_BUFFER))[CODE_BUFFER_STACK_INDEX] -= num; 
}

voidCBsetStackIndex(LispObj num)
{ 
UVECTOR(symbolValue(COMPILER_CODE_BUFFER))[CODE_BUFFER_STACK_INDEX] = num; 
}

LispObj CBstackIndex()
{ 
returnUVECTOR(symbolValue(COMPILER_CODE_BUFFER))[CODE_BUFFER_STACK_INDEX]; 
}

voidCBgrowCode()
{
 LispObj bv = 0;
 LispObj buf = symbolValue(COMPILER_CODE_BUFFER);
 LispObj cbuf = UVECTOR(buf)[CODE_BUFFER_CBUF];
UVECTOR(buf)[CODE_BUFFER_MAX_CODE_BYTES] *= 2;
 bv = byteVector(UVECTOR(buf)[CODE_BUFFER_MAX_CODE_BYTES] + wrapInteger(16));
memcpy(byteArrayStart(bv), byteArrayStart(cbuf), integer(UVECTOR(buf)[CODE_BUFFER_CODE_INDEX]));
UVECTOR(buf)[CODE_BUFFER_CBUF] = bv;
}

voidCBgrowRefs()
{
 LispObj v = 0;
 LispObj buf = symbolValue(COMPILER_CODE_BUFFER);
 LispObj refs = UVECTOR(buf)[CODE_BUFFER_REFS];
UVECTOR(buf)[CODE_BUFFER_MAX_REFS] *= 2;
 v = vectorNode(UVECTOR(buf)[CODE_BUFFER_MAX_REFS] + wrapInteger(8));
memcpy(arrayStart(v), arrayStart(refs), integer(UVECTOR(buf)[CODE_BUFFER_REF_INDEX]) * sizeof(LispObj));
UVECTOR(buf)[CODE_BUFFER_REFS] = v;
}

LispObj CBcode() { returnUVECTOR(symbolValue(COMPILER_CODE_BUFFER))[CODE_BUFFER_CBUF]; }
LispObj CBreferences() { returnUVECTOR(symbolValue(COMPILER_CODE_BUFFER))[CODE_BUFFER_REFS]; }
LispObj CBlength() { returnUVECTOR(symbolValue(COMPILER_CODE_BUFFER))[CODE_BUFFER_CODE_INDEX]; } 
LispObj CBnumReferences() { returnUVECTOR(symbolValue(COMPILER_CODE_BUFFER))[CODE_BUFFER_REF_INDEX] / 2; }
LispObj CBdynamicEnvSize() { returnUVECTOR(symbolValue(COMPILER_CODE_BUFFER))[CODE_BUFFER_DYNAMIC_ENV_SIZE]; }
LispObj CBheapEnvSize() { returnUVECTOR(symbolValue(COMPILER_CODE_BUFFER))[CODE_BUFFER_HEAP_ENV_SIZE]; }

#defineMAX_CODE_BYTES0x1000
#defineMAX_REFS0x400

LispObj makeCodeBuffer()
{
 LispObj s = 0;
 LispObj bv = 0;
 LispObj rv = 0;

 bv = byteVector(wrapInteger(MAX_CODE_BYTES + 16));
 rv = vectorNode(wrapInteger((MAX_REFS * 2) + 8));

 s = AllocVector(CODE_BUFFER_SIZE);
UVECTOR(s)[0] |= (StructureType << 3);
UVECTOR(s)[CODE_BUFFER_INFO] = COMPILER_CODE_BUFFER;
UVECTOR(s)[CODE_BUFFER_CBUF] = bv;
UVECTOR(s)[CODE_BUFFER_REFS] = rv;
UVECTOR(s)[CODE_BUFFER_CODE_INDEX] = 0;
UVECTOR(s)[CODE_BUFFER_REF_INDEX] = 0;
UVECTOR(s)[CODE_BUFFER_DYNAMIC_ENV_SIZE]= 0;
UVECTOR(s)[CODE_BUFFER_HEAP_ENV_SIZE] = 0;
UVECTOR(s)[CODE_BUFFER_STACK_INDEX] = 0;
UVECTOR(s)[CODE_BUFFER_MAX_CODE_BYTES] = wrapInteger(MAX_CODE_BYTES);
UVECTOR(s)[CODE_BUFFER_MAX_REFS] = wrapInteger(MAX_REFS * 2);

return s; 
}

//
// If it is NIL, return NIL.
// Otherwise, reverse the list, and store it into a simple vector.
// Returns the vector.
LispObj convertRefsToVector(LispObj list)
{
 LispObj t0 = 0;
 LispObj t1 = 0;
if (list == NIL)
return list;
 t0 = Cnreverse(list);
 t1 = wrapInteger(listLength(t0));
 t0 = vectorNode(t1, t0);
return t0;
}

//
// If it is NIL, return NIL.
// Otherwise, reverse the list, and store it into a simple vector.
// The first 4 cells are reserved for EBP, EBX, EDI and ESI.
// Returns the vector.
LispObj convertFrameInfoToVector(LispObj list)
{
 LispObj t0 = 0;
 LispObj t1 = 0;
if (list == NIL)
return list;
 t0 = Cnreverse(list);
 t0 = cons(0, cons(0, cons(0, cons(0, t0))));
 t1 = wrapInteger(listLength(t0));
 t0 = vectorNode(t1, t0);
return t0;
}

//
// Like copyTree, but does not copy quoted list structure.
//
static LispObj copyTreeUnquoted(LispObj tree)
{
if (isCons(tree))
 {
if (CAR(tree) == QUOTE)
returncons(QUOTE, CDR(tree));
else
returncons(copyTreeUnquoted(CAR(tree)), copyTreeUnquoted(CDR(tree)));
 }
else
return tree;
}

//
// compileExpression()
// Takes an arbitrary lisp expression as its argument, 
// and compiles it to produce a Lisp functions, which
// when executed, will imitate the behavior of interpreting
// the expression.
// Returns the compiled expression.
//
LispObj compileExpression(LispObj x, LispObj lexMacros, LispObj lexSymbolMacros)
{
 LispObj f = 0;
long stackNeeded = 0;
 LispObj info = NIL;
 LispObj t1 = 0;

pushDynamicBinding(COLLECT_LEXICAL_MACROS, NIL);
pushDynamicBinding(LEXICAL_MACROS, lexMacros); // from previous (outer) lambda
pushDynamicBinding(COLLECT_LEXICAL_SYMBOL_MACROS, NIL);
pushDynamicBinding(LEXICAL_SYMBOL_MACROS, lexSymbolMacros); // from previous (outer) lambda

if (ExpandMacrosInline)
if (symbolValue(MACROEXPAND_INLINE) == NIL)
 ExpandMacrosInline = 0;

if (!ExpandMacrosInline)
 {
 x = LispCall3(Funcall, symbolFunction(MACROEXPAND_ALL), x, NIL);
 x = LispCall2(Funcall, symbolFunction(COLLECT_LITERALS), x);
 }

// add the source file to the info list
 t1 = symbolValue(SOURCE_FILE);
if (t1 != NIL)
 {
 info = cons(t1, info);
 info = cons(SOURCE_FILE, info);
 }
// add the source line to the info list
 t1 = symbolValue(SOURCE_LINE);
if (t1 != NIL)
 {
 info = cons(t1, info);
 info = cons(SOURCE_LINE, info);
 }

 t1 = symbolValue(SAVE_DEBUG_INFO);
if (t1 != NIL)
 {
// add the source line to the info list
 t1 = symbolValue(SOURCE_LINES);
if (t1 != NIL)
 {
 info = cons(t1, info);
 info = cons(SOURCE_LINES, info);
 }
 }

pushDynamicBinding(COMPILER_CLEANUPS, NIL);
pushDynamicBinding(EMBEDDED_LAMBDAS, NIL);
pushDynamicBinding(ENV_COUNTER, 0);
pushDynamicBinding(COMPILER_CODE_BUFFER, NIL);
pushDynamicBinding(COMPILER_VARIABLE_TYPES, NIL);
pushDynamicBinding(COMPILER_DYNAMIC_EXTENT_VARS, NIL);
pushDynamicBinding(CODE_JUMP_TABLE_REFS, NIL);
pushDynamicBinding(CODE_ENV_TABLE_REFS, NIL);
pushDynamicBinding(CODE_VAR_TABLE_REFS, NIL);
pushDynamicBinding(COMPILED_SPECIALS, NIL);
pushDynamicBinding(COMPILER_FRAME_INFO, NIL);
pushDynamicBinding(COMPILER_LAMBDA_LIST, NIL);
pushDynamicBinding(COMPILING_LAMBDA, NIL);
pushDynamicBinding(LOAD_TIME_VALUES, NIL);

 t1 = list(COLLECT_LEXICAL_MACROS, 
 LEXICAL_MACROS,
 COLLECT_LEXICAL_SYMBOL_MACROS,
 LEXICAL_SYMBOL_MACROS,
 COMPILER_CLEANUPS, 
 EMBEDDED_LAMBDAS,
 ENV_COUNTER, 
 COMPILER_CODE_BUFFER,
 COMPILER_VARIABLE_TYPES,
 COMPILER_DYNAMIC_EXTENT_VARS,
 CODE_JUMP_TABLE_REFS,
 CODE_ENV_TABLE_REFS,
 CODE_VAR_TABLE_REFS,
 COMPILED_SPECIALS,
 COMPILER_FRAME_INFO,
 COMPILER_LAMBDA_LIST,
 COMPILING_LAMBDA,
 LOAD_TIME_VALUES,
 END_LIST);
establishSpecialBindings(t1);

setSymbolValue(EMBEDDED_LAMBDAS, findLambdas(x));
setSymbolValue(COMPILER_CODE_BUFFER, makeCodeBuffer());

CBsetStackIndex(0);
compileForm(x, Dest_EAX, T);
if (CBstackIndex() != 0)
Error("Stack index invalid after expression compilation: ~A", CBstackIndex());

 stackNeeded = integer(CBdynamicEnvSize());
epilog(stackNeeded);
prolog(stackNeeded);

// if needed, add the jump table references to the info list
 t1 = symbolValue(COMPILER_COLLECT_JUMP_TABLE_REFS);
if (t1 != NIL)
 {
 t1 = cons(convertRefsToVector(symbolValue(CODE_JUMP_TABLE_REFS)), info);
 info = cons(CODE_JUMP_TABLE_REFS, t1);
 t1 = cons(convertRefsToVector(symbolValue(CODE_ENV_TABLE_REFS)), info);
 info = cons(CODE_ENV_TABLE_REFS, t1);
 }

// if needed, add the variable table references to the info list
 t1 = symbolValue(COMPILER_COLLECT_VAR_TABLE_REFS);
if (t1 != NIL)
 {
 t1 = cons(convertRefsToVector(symbolValue(CODE_VAR_TABLE_REFS)), info);
 info = cons(CODE_VAR_TABLE_REFS, t1);
 }

// save stack frame info if necessary
 t1 = symbolValue(COMPILER_SAVE_STACK_FRAME_INFO);
if (t1 != NIL)
 {
 t1 = symbolValue(COMPILED_SPECIALS);
while (isCons(t1))
 {
addCompilerFrameInfo(CAR(t1), wrapInteger(3) /* esi */, 
UVECTOR(CAR(t1))[SYMBOL_VAR_TABLE] * 4, wrapInteger(1) /* indirect */);
 t1 = CDR(t1);
 }

if (COMPILER_FRAME_INFO != NIL)
 {
 t1 = cons(convertFrameInfoToVector(symbolValue(COMPILER_FRAME_INFO)), info);
 info = cons(STACK_FRAME, t1);
 }
 }

// if any LOAD-TIME-VALUE forms were compiled, add those here
 t1 = symbolValue(LOAD_TIME_VALUES);
if (t1 != NIL)
 {
 info = cons(LOAD_TIME_VALUES, cons(t1, info));
 }

 f = compiledFunctionNode(CBcode(), CBlength(), 
CBreferences(), CBnumReferences(), NIL, info, 
symbolValue(APPEND_REFS_TO_CODE));

popDynamicBinding(ENV_COUNTER);
popDynamicBinding(EMBEDDED_LAMBDAS);
popDynamicBinding(COMPILER_CLEANUPS);
popDynamicBinding(COMPILER_CODE_BUFFER);
popDynamicBinding(COMPILER_VARIABLE_TYPES);
popDynamicBinding(COMPILER_DYNAMIC_EXTENT_VARS);
popDynamicBinding(CODE_JUMP_TABLE_REFS);
popDynamicBinding(CODE_ENV_TABLE_REFS);
popDynamicBinding(CODE_VAR_TABLE_REFS);
popDynamicBinding(COMPILED_SPECIALS);
popDynamicBinding(COMPILER_FRAME_INFO);
popDynamicBinding(COMPILER_LAMBDA_LIST);
popDynamicBinding(LEXICAL_MACROS);
popDynamicBinding(LEXICAL_SYMBOL_MACROS);
popDynamicBinding(COLLECT_LEXICAL_MACROS);
popDynamicBinding(COLLECT_LEXICAL_SYMBOL_MACROS);
popDynamicBinding(COMPILING_LAMBDA);
popDynamicBinding(LOAD_TIME_VALUES);
popSpecials();

return f;
}
staticint counter = 0;

LispObj compileLambdaExpression(LispObj lambda, LispObj name, LispObj env, LispObj lexMacros, LispObj lexSymbolMacros)
{
 LispObj lambdaList = 0;
 LispObj forms = 0;
 LispObj newVars = NIL;
long stackNeeded = 0;
 LispObj f = 0;
 LispObj requiredArgs = 0;
 LispObj optionalArgs = 0;
 LispObj restArgs = 0;
 LispObj keyArgs = 0;
 LispObj auxArgs = 0;
long minArgs = 0;
long maxArgs = 0;
 LispObj allowOtherKeys = NIL;
long numRequiredArgs = 0;
long numOptionalArgs = 0;
long numAuxArgs = 0;
 LispObj declarations = 0;
 LispObj decForm = 0;
 LispObj info = NIL;
 LispObj funcname = name;
 LispObj specials = 0;
 LispObj compilerBindings = NIL;
 LispObj numTypeDeclarations = 0;
 LispObj numDynamicExtentDeclarations = 0;
 LispObj t1 = 0;
 LispObj origLambda = lambda;
 LispObj lexicalMacros = 0;
 LispObj lexicalSymbolMacros = 0;
 LispObj specialDecs = NIL;
long i = 0;
long numLocals = 0;
long emptyKeywordList = 0;

 counter++;

// add the source file to the info list
 t1 = symbolValue(SOURCE_FILE);
if (t1 != NIL)
 {
 info = cons(t1, info);
 info = cons(SOURCE_FILE, info);
 }
// add the source line to the info list
 t1 = symbolValue(SOURCE_LINE);
if (t1 != NIL)
 {
 info = cons(t1, info);
 info = cons(SOURCE_LINE, info);
 }

 t1 = symbolValue(SAVE_DEBUG_INFO);
if (t1 != NIL)
 {
// add the source line to the info list
 t1 = symbolValue(SOURCE_LINES);
if (t1 != NIL)
 {
 info = cons(t1, info);
 info = cons(SOURCE_LINES, info);
 }
 }

if (ExpandMacrosInline)
 {
 t1 = symbolValue(MACROEXPAND_INLINE);
if (t1 == NIL)
 ExpandMacrosInline = 0;
 }

pushDynamicBinding(COLLECT_LEXICAL_MACROS, NIL);
pushDynamicBinding(LEXICAL_MACROS, lexMacros); // from previous (outer) lambda
pushDynamicBinding(COLLECT_LEXICAL_SYMBOL_MACROS, NIL);
pushDynamicBinding(LEXICAL_SYMBOL_MACROS, lexSymbolMacros); // from previous (outer) lambda
if (!ExpandMacrosInline)
 {
 t1 = symbolFunction(MACROEXPAND_ALL_EXCEPT_TOP);
 lambda = LispCall3(Funcall, t1, lambda, NIL);
 lexicalMacros = symbolValue(COLLECT_LEXICAL_MACROS);
 lexicalSymbolMacros = symbolValue(COLLECT_LEXICAL_SYMBOL_MACROS);
 }

pushDynamicBinding(COMPILER_CLEANUPS, env);
pushDynamicBinding(EMBEDDED_LAMBDAS, NIL);
pushDynamicBinding(ENV_COUNTER, 0);
pushDynamicBinding(LAMBDA_SPECIAL_VARS, NIL);
pushDynamicBinding(LAMBDA_DECLARATIONS, NIL);
pushDynamicBinding(LAMBDA_SPECIAL_DECS, symbolValue(LAMBDA_SPECIAL_DECS));
pushDynamicBinding(COMPILER_CODE_BUFFER, NIL);
pushDynamicBinding(COMPILER_VARIABLE_TYPES, symbolValue(COMPILER_VARIABLE_TYPES));
pushDynamicBinding(COMPILER_DYNAMIC_EXTENT_VARS, symbolValue(COMPILER_DYNAMIC_EXTENT_VARS));
pushDynamicBinding(COMPILER_FUNCTION_NAME, NIL);
pushDynamicBinding(COMPILER_USES_ENV, NIL);
pushDynamicBinding(CODE_JUMP_TABLE_REFS, NIL);
pushDynamicBinding(CODE_ENV_TABLE_REFS, NIL);
pushDynamicBinding(CODE_VAR_TABLE_REFS, NIL);
pushDynamicBinding(COMPILED_SPECIALS, NIL);
pushDynamicBinding(COMPILER_FRAME_INFO, NIL);
pushDynamicBinding(COMPILER_LAMBDA_LIST, NIL);
pushDynamicBinding(COMPILING_LAMBDA, T);
pushDynamicBinding(LOAD_TIME_VALUES, NIL);

 t1 = list(COLLECT_LEXICAL_MACROS, LEXICAL_MACROS, 
 COLLECT_LEXICAL_SYMBOL_MACROS, LEXICAL_SYMBOL_MACROS,
 COMPILER_CLEANUPS, EMBEDDED_LAMBDAS,
 ENV_COUNTER, LAMBDA_SPECIAL_VARS, LAMBDA_DECLARATIONS,
 LAMBDA_SPECIAL_DECS, COMPILER_CODE_BUFFER, COMPILER_VARIABLE_TYPES,
 COMPILER_DYNAMIC_EXTENT_VARS,
 COMPILER_FUNCTION_NAME, COMPILER_USES_ENV, 
 CODE_JUMP_TABLE_REFS, CODE_ENV_TABLE_REFS,
 CODE_VAR_TABLE_REFS, COMPILED_SPECIALS, COMPILER_FRAME_INFO, 
 COMPILER_LAMBDA_LIST, COMPILING_LAMBDA, LOAD_TIME_VALUES, END_LIST);
establishSpecialBindings(t1);

 t1 = CDR(lambda);
 t1 = findLambdas(t1);
setSymbolValue(EMBEDDED_LAMBDAS, t1);
 t1 = makeCodeBuffer();
setSymbolValue(COMPILER_CODE_BUFFER, t1);

CBaddLambda();

if (!isCons(CDR(lambda)))
Error("Invalid lambda expression: ~A", lambda);
 lambdaList = CAR(CDR(lambda));
if (!isList(lambdaList))
Error("Invalid lambda expression: ~A", lambda);
setSymbolValue(COMPILER_LAMBDA_LIST, lambdaList);
 forms = CDR(CDR(lambda));

if (funcname == NIL)
 {
// skip declarations
 f = forms;
while (isCons(f))
 {
if (!isCons(CAR(f)) || (CAR(CAR(f)) != DECLARE))
break;
 f = CDR(f);
 }
if (isCons(f) && isCons(CAR(f))
 && CAR(CAR(f)) == BLOCK && isCons(CDR(CAR(f))))
 funcname = CAR(CDR(CAR(f)));
 }

// add the lambda expression to the info list
 t1 = symbolValue(COMPILER_SAVE_LAMBDAS);
if (t1 != NIL || LispCall2(Funcall, INLINE_PROCLAIM_P, funcname) != NIL)
 {
 t1 = cons(copyTreeUnquoted(origLambda), info);
 info = cons(LAMBDA, t1);
 } 

// add the lambda list to the info list
if (symbolValue(COMPILER_SAVE_LAMBDA_LISTS) != NIL)
 info = cons(LAMBDA_LIST, cons(lambdaList, info));

// add the function name to the info list
 info = cons(FUNCTION_NAME, cons(funcname, info));
setSymbolValue(COMPILER_FUNCTION_NAME, funcname);

if (compilerOptimizeTailRecursion() != NIL)
 {
 lambda = LispCall3(Funcall, REMOVE_TAIL_RECURSION, lambda, funcname);
 lambdaList = CAR(CDR(lambda));
setSymbolValue(COMPILER_LAMBDA_LIST, lambdaList);
 forms = CDR(CDR(lambda));
 }

 requiredArgs = findRequiredArgs(lambdaList);
 numRequiredArgs = listLength(requiredArgs);
 minArgs = numRequiredArgs;
 maxArgs = numRequiredArgs;
 optionalArgs = findOptionalArgs(lambdaList);
 numOptionalArgs = listLength(optionalArgs); 
 maxArgs += numOptionalArgs;
 restArgs = findRestArgs(lambdaList);
if (restArgs != NIL)
 maxArgs = -1; // no limit to number of args
 keyArgs = findKeyArgs(lambdaList);
// if list contains arguments, the first value is &key
if (keyArgs != NIL)
 {
 keyArgs = CDR(keyArgs);
 maxArgs = -1; // no limit to number of args
if (keyArgs == NIL)
 emptyKeywordList = 1; // this special case has caused problems
 }
 allowOtherKeys = findAllowOtherKeys(lambdaList);
if (allowOtherKeys != NIL)
 maxArgs = -1; // no limit to number of args
 auxArgs = findAuxArgs(lambdaList);
 numAuxArgs = listLength(auxArgs);
 numLocals = numRequiredArgs + numOptionalArgs + listLength(restArgs)