%
% LAP-TO-ASM.RED - LAP to assembler translator
%
% Author: Eric Benson
% Symbolic Computation Group
% Computer Science Dept.
% University of Utah
% Date: 13 August 1981
% Copyright (c) 1981 University of Utah
%
% <PSL.COMP>LAP-TO-ASM.RED.5, 30-Apr-82 14:47:52, Edit by BENSON
% Removed EVAL and IGNORE processing
Imports '(PathIn); % kernel build files use PATHIN
fluid '(!*Comp
!*PLap
DfPrint!*
CharactersPerWord
AddressingUnitsPerItem
AddressingUnitsPerFunctionCell
InputSymFile!*
OutputSymFile!*
CodeOut!*
DataOut!*
InitOut!*;
CodeFileNameFormat!*
DataFileNameFormat!*
InitFileNameFormat!*
ModuleName!*
UncompiledExpressions!*
NextIDNumber!*
OrderedIDList!*
NilNumber!*
!*MainFound
!*MAIN
!*DeclareBeforeUse
MainEntryPointName!*
EntryPoints!*
LocalLabels!*
CodeExternals!*
CodeExporteds!*
DataExternals!*
DataExporteds!*
ExternalDeclarationFormat!*
ExportedDeclarationFormat!*
LabelFormat!*
FullWordFormat!*
DoubleFloatFormat!*
ReserveDataBlockFormat!*
ReserveZeroBlockFormat!*
UndefinedFunctionCellInstructions!*
DefinedFunctionCellFormat!*
PrintExpressionForm!*
PrintExpressionFormPointer!*
CommentFormat!*
NumericRegisterNames!*
ExpressionCount!*
ASMOpenParen!*
ASMCloseParen!*
ToBeCompiledExpressions!*
GlobalDataFileName!*
);
global '(Semic!*);
InputSymFile!* := "psl.sym";
OutputSymFile!* := "psl.sym";
GlobalDataFileName!* := "global-data.red";
InitFileNameFormat!* := "%w.init";
lisp procedure DfPrintASM U; %. Called by TOP-loop, DFPRINT!*
begin scalar Nam, Ty, Fn;
if atom U then return NIL;
Fn := car U;
IF FN = 'PUTD THEN GOTO DB2;
IF NOT (FN MEMQ '(DE DF DM DN)) THEN GOTO DB1;
NAM:=CADR U;
U:='LAMBDA . CDDR U;
TY:=CDR ASSOC(FN, '((DE . EXPR)
(DF . FEXPR)
(DM . MACRO)
(DN . NEXPR)));
DB3: if Ty = 'MACRO then begin scalar !*Comp;
PutD(Nam, Ty, U); % Macros get defined now
end;
if FlagP(Nam, 'Lose) then <<
ErrorPrintF("*** %r has not been defined, because it is flagged LOSE",
Nam);
return NIL >>;
IF FLAGP(TY,'COMPILE) THEN
<< PUT(NAM,'CFNTYPE,LIST TY);
U := LIST('!*ENTRY,NAM,TY,LENGTH CADR U)
. !&COMPROC(U, NAM);
if !*PLAP then for each X in U do Print X;
if TY neq 'EXPR then
DfPrintASM list('put, MkQuote Nam, '(quote TYPE), MkQuote TY);
ASMOUTLAP U >>
ELSE % should never happen
SaveUncompiledExpression LIST('PUTD, MKQUOTE NAM,
MKQUOTE TY,
MKQUOTE U);
RETURN NIL;
DB1: % Simple S-EXPRESSION, maybe EVAL it;
IF NOT PAIRP U THEN RETURN NIL;
if (Fn := get(car U, 'ASMPreEval)) then return Apply(Fn, list U)
else if (Fn := GetD car U) and car Fn = 'MACRO then
return DFPRINTASM Apply(cdr Fn, list U);
SaveUncompiledExpression U;
RETURN NIL;
DB2: NAM:=CADR U;
TY:=CADDR U;
FN:=CADDDR U;
IF EQCAR(NAM,'QUOTE) THEN << NAM:=CADR NAM;
IF EQCAR(TY,'QUOTE) THEN << TY:=CADR TY;
IF PAIRP FN AND CAR FN MEMBER '(FUNCTION QUOTE) THEN << FN:=CADR FN;
IF TY MEMQ '(EXPR FEXPR MACRO NEXPR) THEN
<< U:=FN; GOTO DB3 >> >> >> >>;
GOTO DB1;
END;
lisp procedure ASMPreEvalLoadTime U;
DFPrintASM cadr U; % remove LOADTIME
put('LoadTime, 'ASMPreEval, 'ASMPreEvalLoadTime);
lisp procedure ASMPreEvalStartupTime U;
SaveForCompilation cadr U;
put('StartupTime, 'ASMPreEval, 'ASMPreEvalStartupTime);
lisp procedure ASMPreEvalProgN U;
for each X in cdr U do
DFPrintASM X;
put('ProgN, 'ASMPreEval, 'ASMPreEvalProgN);
put('WDeclare, 'ASMPreEval, 'Eval); % do it now
lisp procedure ASMPreEvalSetQ U;
begin scalar X, Val;
X := cadr U;
Val := caddr U;
return if ConstantP Val or Val = T then
<< FindIDNumber X;
put(X, 'InitialValue, Val);
NIL >>
else if null Val then
<< FindIDNumber X;
RemProp(X, 'InitialValue);
Flag(list X, 'NilInitialValue);
NIL >>
else if EqCar(Val, 'QUOTE) then
<< FindIDNumber X;
Val := cadr Val;
if null Val then
<< RemProp(X, 'InitialValue);
Flag(list X, 'NilInitialValue) >>
else
put(X, 'InitialValue, Val);
NIL >>
else if IDP Val and get(Val, 'InitialValue)
or FlagP(Val, 'NilInitialValue) then
<< if (Val := get(Val, 'InitialValue)) then
put(X, 'InitialValue, Val)
else Flag(list X, 'NilInitialValue) >>
else SaveUncompiledExpression U; % just check simple cases, else return
end;
put('SetQ, 'ASMPreEval, 'ASMPreEvalSetQ);
lisp procedure ASMPreEvalPutD U;
SaveUncompiledExpression CheckForEasySharedEntryPoints U;
lisp procedure CheckForEasySharedEntryPoints U;
%
% looking for (PUTD (QUOTE name1) xxxx (CDR (GETD (QUOTE name2))))
%
begin scalar NU, Nam, Exp;
NU := cdr U;
Nam := car NU;
if car Nam = 'QUOTE then Nam := cadr Nam else return U;
NU := cdr NU;
Exp := cadr NU;
if not (car Exp = 'CDR) then return U;
Exp := cadr Exp;
if not (car Exp = 'GETD) then return U;
Exp := cadr Exp;
if not (car Exp = 'QUOTE) then return U;
Exp := cadr Exp;
FindIDNumber Nam;
put(Nam, 'EntryPoint, FindEntryPoint Exp);
if not (car NU = '(QUOTE EXPR)) then return list('Put, '(Quote Type),
car NU);
return NIL;
end;
put('PutD, 'ASMPreEval, 'ASMPreEvalPutD);
lisp procedure ASMPreEvalFluidAndGlobal U;
<< if EqCar(cadr U, 'QUOTE) then Flag(cadr cadr U, 'NilInitialValue);
SaveUncompiledExpression U >>;
put('Fluid, 'ASMPreEval, 'ASMPreEvalFluidAndGlobal);
put('Global, 'ASMPreEval, 'ASMPreEvalFluidAndGlobal);
CommentOutCode <<
fluid '(NewFluids!* NewGlobals!*);
lisp procedure ASMPreEvalFluidAndGlobal U;
begin scalar L;
L := cadr U;
return if car L = 'QUOTE then
<< L := cadr L;
if car U = 'FLUID then
NewFluids!* := UnionQ(NewFluids!*, L) % take union
else NewGlobals!* := UnionQ(NewGlobals!*, L);
Flag(L, 'NilInitialValue);
NIL >>
else SaveUncompiledExpression U;
end;
put('Fluid, 'ASMPreEval, 'ASMPreEvalFluidAndGlobal);
put('Global, 'ASMPreEval, 'ASMPreEvalFluidAndGlobal);
>>;
lisp procedure ASMPreEvalLAP U;
if EqCar(cadr U, 'QUOTE) then ASMOutLap cadr cadr U
else SaveUncompiledExpression U;
put('LAP, 'ASMPreEval, 'ASMPreEvalLAP);
CommentOutCode <<
lisp procedure InitialPut(Nam, Ind, Val);
begin scalar L, P;
FindIDNumber Nam;
if (P := Atsoc(Ind, L := get(Nam, 'InitialPropertyList))) then
Rplacd(P, Val)
else put(Nam, 'InitialPropertyList, (Ind . Val) . L);
end;
lisp procedure InitialRemprop(Nam, Ind);
begin scalar L;
if (L := get(Nam, 'InitialPropertyList)) then
put(Nam, 'InitialPropertyList, DelAtQIP(Ind, L));
end;
lisp procedure InitialFlag1(Nam, Ind);
begin scalar L, P;
FindIDNumber Nam;
if not Ind memq (L := get(Nam, 'InitialPropertyList)) then
put(Nam, 'InitialPropertyList, Ind . L);
end;
lisp procedure InitialRemFlag1(Nam, Ind);
begin scalar L;
if (L := get(Nam, 'InitialPropertyList)) then
put(Nam, 'InitialPropertyList, DelQIP(Ind, L));
end;
lisp procedure ASMPreEvalPut U;
begin scalar Nam, Ind, Val;
Nam := second U;
Ind := third U;
Val := fourth U;
if EqCar(Nam, 'QUOTE) and EqCar(Ind, 'QUOTE) and
(ConstantP Val or Val = T or EqCar(Val, 'QUOTE)) then
InitialPut(second Nam, second Ind, if EqCar(Val, 'QUOTE) then
second Val else Val)
else SaveUncompiledExpression U;
end;
put('put, 'ASMPreEval, 'ASMPreEvalPut);
lisp procedure ASMPreEvalRemProp U;
begin scalar Nam, Ind;
Nam := second U;
Ind := third U;
if EqCar(Nam, 'QUOTE) and EqCar(Ind, 'QUOTE) then
InitialRemProp(second Nam, second Ind)
else SaveUncompiledExpression U;
end;
put('RemProp, 'ASMPreEval, 'ASMPreEvalRemProp);
lisp procedure ASMPreEvalDefList U;
begin scalar DList, Ind;
DList := second U;
Ind := third U;
if EqCar(DList, 'QUOTE) and EqCar(Ind, 'QUOTE) then
<< DList := second DList;
Ind := second Ind;
for each X in Dlist do InitialPut(first X, Ind, second X) >>
else SaveUncompiledExpression U;
end;
put('DefList, 'ASMPreEval, 'ASMPreEvalDefList);
lisp procedure ASMPreEvalFlag U;
begin scalar NameList, Ind;
NameList := second U;
Ind := third U;
if EqCar(NameList, 'QUOTE) and EqCar(Ind, 'QUOTE) then
<< Ind := second Ind;
for each X in second NameList do
InitialFlag1(X, Ind) >>
else SaveUncompiledExpression U;
end;
put('flag, 'ASMPreEval, 'ASMPreEvalFlag);
lisp procedure ASMPreEvalRemFlag U;
begin scalar NameList, Ind;
NameList := second U;
Ind := third U;
if EqCar(NameList, 'QUOTE) and EqCar(Ind, 'QUOTE) then
<< Ind := second Ind;
for each X in second NameList do
InitialRemFlag1(X, Ind) >>
else SaveUncompiledExpression U;
end;
put('RemFlag, 'ASMPreEval, 'ASMPreEvalRemFlag);
lisp procedure ASMPreEvalGlobal U;
begin scalar NameList;
NameList := second U;
if EqCar(NameList, 'QUOTE) then
for each X in second NameList do
InitialPut(X, 'TYPE, 'Global)
else SaveUncompiledExpression U;
end;
put('Global, 'ASMPreEval, 'ASMPreEvalGlobal);
lisp procedure ASMPreEvalFluid U;
begin scalar NameList;
NameList := second U;
if EqCar(NameList, 'QUOTE) then
for each X in second NameList do
InitialPut(X, 'TYPE, 'FLUID)
else SaveUncompiledExpression U;
end;
put('Fluid, 'ASMPreEval, 'ASMPreEvalFluid);
lisp procedure ASMPreEvalUnFluid U;
begin scalar NameList;
NameList := second U;
if EqCar(NameList, 'QUOTE) then
for each X in second NameList do
InitialRemProp(X, 'TYPE)
else SaveUncompiledExpression U;
end;
put('UnFluid, 'ASMPreEval, 'ASMPreEvalUnFluid);
>>;
lisp procedure SaveUncompiledExpression U;
if PairP U then
begin scalar OldOut;
OldOut := WRS InitOut!*;
Print U;
WRS OldOut;
end;
ToBeCompiledExpressions!* := NIL . NIL;
lisp procedure SaveForCompilation U;
if atom U or U member car ToBeCompiledExpressions!* then NIL
else if car U = 'progn then
for each X in cdr U do SaveForCompilation X
else TConc(ToBeCompiledExpressions!*, U);
SYMBOLIC PROCEDURE ASMOUT FIL;
begin scalar OldOut;
ModuleName!* := FIL;
Prin2T "ASMOUT: IN files; or type in expressions";
Prin2T "When all done execute ASMEND;";
CodeOut!* := Open(BldMsg(CodeFileNameFormat!*, ModuleName!*), 'OUTPUT);
OldOut := WRS CodeOut!*;
LineLength 1000;
WRS OldOut;
CodeFileHeader();
DataOut!* := Open(BldMsg(DataFileNameFormat!*, ModuleName!*), 'OUTPUT);
OldOut := WRS DataOut!*;
LineLength 1000;
WRS OldOut;
DataFileHeader();
InitOut!* := Open(BldMsg(InitFileNameFormat!*, ModuleName!*), 'OUTPUT);
ReadSYMFile();
DFPRINT!* := 'DFPRINTASM;
RemD 'OldLap;
PutD('OldLap, 'EXPR, cdr RemD 'Lap);
PutD('Lap, 'EXPR, cdr GetD 'ASMOutLap);
!*DEFN := T;
SEMIC!* := '!$ ; % to turn echo off for IN
if not ((ModuleName!* = "main")
or !*Main) then EVIN list GlobalDataFileName!*
else !*Main := T;
end;
lisp procedure ASMEnd;
<< off SysLisp;
if !*MainFound then
<< CompileUncompiledExpressions();
% WriteInitFile();
InitializeSymbolTable() >>
else WriteSymFile();
CodeFileTrailer();
Close CodeOut!*;
DataFileTrailer();
Close DataOut!*;
Close InitOut!*;
RemD 'Lap;
PutD('Lap, 'EXPR, cdr GetD 'OldLap);
DFPRINT!* := NIL;
!*DEFN := NIL >>;
FLAG('(ASMEND), 'IGNORE);
DEFINEROP('ASMEND,NIL,ESTAT('ASMEND));
lisp procedure CompileUncompiledExpressions();
<< CommentOutCode << AddFluidAndGlobalDecls(); >>;
DFPRINTASM list('DE, 'INITCODE, '(),
'PROGN . car ToBeCompiledExpressions!*) >>;
CommentOutCode <<
lisp procedure AddFluidAndGlobalDecls();
<< SaveUncompiledExpression list('GLOBAL, MkQuote NewGlobals!*);
SaveUncompiledExpression list('FLUID, MkQuote NewFluids!*) >>;
>>;
lisp procedure ReadSymFile();
LapIN InputSymFile!*;
lisp procedure WriteSymFile();
begin scalar NewOut, OldOut;
OldOut := WRS(NewOut := Open(OutputSymFile!*, 'OUTPUT));
print list('SaveForCompilation,
MkQuote('progn . car ToBeCompiledExpressions!*));
SaveIDList();
SetqPrint 'NextIDNumber!*;
SetqPrint 'StringGenSym!*;
MapObl function PutPrintEntryAndSym;
WRS OldOut;
Close NewOut;
end;
CommentOutCode <<
lisp procedure WriteInitFile();
begin scalar OldOut, NewOut;
NewOut := Open(InitFileName!*, 'OUTPUT);
OldOut := WRS NewOut;
for each X in car UncompiledExpressions!* do PrintInit X;
Close NewOut;
WRS OldOut;
end;
lisp procedure PrintInit X;
if EqCar(X, 'progn) then
for each Y in cdr X do PrintInit Y
else Print X;
>>;
lisp procedure SaveIDList();
<< Print list('setq, 'OrderedIDList!*, MkQuote car OrderedIDList!*);
Print quote(OrderedIDList!* :=
OrderedIDList!* . LastPair OrderedIDList!*) >>;
lisp procedure SetqPrint U;
print list('SETQ, U, MkQuote Eval U);
lisp procedure PutPrint(X, Y, Z);
print list('PUT, MkQuote X, MkQuote Y, MkQuote Z);
lisp procedure PutPrintEntryAndSym X;
begin scalar Y;
if (Y := get(X, 'EntryPoint)) then PutPrint(X, 'EntryPoint, Y);
if (Y := get(X, 'IDNumber)) then
PutPrint(X, 'IDNumber, Y);
CommentOutCode <<
if (Y := get(X, 'InitialPropertyList)) then
PutPrint(X, 'InitialPropertyList, Y);
>>;
if (Y := get(X, 'InitialValue)) then
PutPrint(X, 'InitialValue, Y)
else if FlagP(X, 'NilInitialValue) then
print list('flag, MkQuote list X, '(quote NilInitialValue));
if get(X, 'SCOPE) = 'EXTERNAL then
<< PutPrint(X, 'SCOPE, 'EXTERNAL);
PutPrint(X, 'ASMSymbol, get(X, 'ASMSymbol));
if get(X, 'WVar) then PutPrint(X, 'WVar, X)
else if get(X, 'WArray) then PutPrint(X, 'WArray, X)
else if get(X, 'WString) then PutPrint(X, 'WString, X)
else if (Y := get(X, 'WConst)) then PutPrint(X, 'WConst, Y) >>;
end;
lisp procedure FindIDNumber U;
begin scalar I;
return if (I := ID2Int U) <= 128 then I
else if (I := get(U, 'IDNumber)) then I
else
<< put(U, 'IDNumber, I := NextIDNumber!*);
OrderedIDList!* := TConc(OrderedIDList!*, U);
NextIDNumber!* := NextIDNumber!* + 1;
I >>;
end;
OrderedIDList!* := NIL . NIL;
NextIDNumber!* := 129;
lisp procedure InitializeSymbolTable();
begin scalar MaxSymbol;
MaxSymbol := get('MaxSymbols, 'WConst);
if MaxSymbol < NextIDNumber!* then
<< ErrorPrintF("*** MaxSymbols %r is too small; at least %r is needed",
MaxSymbol, NextIDNumber!*);
MaxSymbol := NextIDNumber!* + 100 >>;
Flag('(NIL), 'NilInitialValue);
put('T, 'InitialValue, 'T);
put('!$EOF!$, 'InitialValue, Int2ID get('EOF, 'CharConst));
put('!$EOL!$, 'InitialValue, '!
);
NilNumber!* := CompileConstant NIL;
DataAlignFullWord();
%/ This is a BUG? M.L. G.
%/ for I := NextIDNumber!* step 1 until MaxSymbol do
%/ DataPrintFullWord NilNumber!*;
InitializeSymVal();
DataReserveBlock((MaxSymbol - NextIDNumber!*) + 1);
InitializeSymPrp();
DataReserveBlock((MaxSymbol - NextIDNumber!*) + 1);
%/ This is a BUG? M.L. G.
%/ for I := NextIDNumber!* step 1 until MaxSymbol do
%/ DataPrintFullWord NilNumber!*;
InitializeSymNam MaxSymbol;
InitializeSymFnc();
DataReserveFunctionCellBlock((MaxSymbol - NextIDNumber!*) + 1);
DataAlignFullWord();
DataPrintGlobalLabel FindGlobalLabel 'NextSymbol;
DataPrintFullWord NextIDNumber!*;
end;
lisp procedure InitializeSymPrp();
<< CommentOutCode << InitializeHeap(); >>; % init prop lists
DataPrintGlobalLabel FindGlobalLabel 'SymPrp;
for I := 0 step 1 until 128 do
InitSymPrp1 Int2ID I;
for each X in car OrderedIDList!* do
InitSymPrp1 X >>;
lisp procedure InitSymPrp1 X;
<<
CommentOutCode <<
DataPrintFullWord(if (X := get(X, 'InitialPropertyList)) then
X
else NilNumber!*);
>>;
DataPrintFullWord NilNumber!* >>;
CommentOutCode <<
lisp procedure InitializeHeap();
begin scalar L;
DataPrintGlobalLabel FindGlobalLabel 'Heap;
for I := 0 step 1 until 128 do
PrintPropertyList Int2ID I;
for each X in car OrderedIDList!* do
PrintPropertyList X;
L := get('HeapSize, 'WConst);
end;
>>;
lisp procedure InitializeSymNam MaxSymbol;
<< DataPrintGlobalLabel FindGlobalLabel 'SymNam;
for I := 0 step 1 until 128 do
DataPrintFullWord CompileConstant ID2String Int2ID I;
for each IDName in car OrderedIDList!* do
DataPrintFullWord CompileConstant ID2String IDName;
MaxSymbol := MaxSymbol - 1;
for I := NextIDNumber!* step 1 until MaxSymbol do
DataPrintFullWord(I + 1);
DataPrintFullWord 0 >>;
lisp procedure InitializeSymVal();
<< DataPrintGlobalLabel FindGlobalLabel 'SymVal;
for I := 0 step 1 until 128 do InitSymVal1 Int2ID I;
for each X in car OrderedIDList!* do InitSymVal1 X >>;
lisp procedure InitSymVal1 X;
begin scalar Val;
return DataPrintFullWord(if (Val := get(X, 'InitialValue)) then
CompileConstant Val
else if FlagP(X, 'NilInitialValue) then
NilNumber!*
else list('MkItem, get('Unbound, 'WConst),
FindIDNumber X));
end;
lisp procedure InitializeSymFnc();
<< DataPrintGlobalLabel FindGlobalLabel 'SymFnc;
for I := 0 step 1 until 128 do InitSymFnc1 Int2ID I;
for each X in car OrderedIDList!* do InitSymFnc1 X >>;
lisp procedure InitSymFnc1 X;
begin scalar EP;
EP := get(X, 'EntryPoint);
if null EP then DataPrintUndefinedFunctionCell()
else DataPrintDefinedFunctionCell EP;
end;
lisp procedure ASMOutLap U;
begin scalar LocalLabels!*, OldOut;
U := Pass1Lap U; % Expand cmacros, quoted expressions
CodeBlockHeader();
OldOut := WRS CodeOut!*;
for each X in U do ASMOutLap1 X;
WRS OldOut;
CodeBlockTrailer();
end;
lisp procedure ASMOutLap1 X;
begin scalar Fn;
return if StringP X then PrintLabel X
else if atom X then PrintLabel FindLocalLabel X
else if (Fn := get(car X, 'ASMPseudoOp)) then Apply(Fn, list X)
else
% instruction output form is:
% "space" <opcode> [ "space" <operand> { "comma" <operand> } ] "newline"
<< Prin2 '! ; % Space
PrintOpcode car X;
X := cdr X;
if not null X then
<< Prin2 '! ; % SPACE
PrintOperand car X;
for each U in cdr X do
<< Prin2 '!,; % COMMA
PrintOperand U >> >>;
Prin2 !$EOL!$ >>; % NEWLINE
end;
put('!*Entry, 'ASMPseudoOp, 'ASMPrintEntry);
lisp procedure ASMPrintEntry X;
begin scalar Y;
PrintComment X;
X := cadr X;
Y := FindEntryPoint X;
if not FlagP(X, 'InternalFunction) then FindIDNumber X;
if X eq MainEntryPointName!* then
<< !*MainFound := T;
SpecialActionForMainEntryPoint() >>
else CodeDeclareExportedUse Y;
end;
Procedure CodeDeclareExportedUse Y;
if !*DeclareBeforeUse then
<< CodeDeclareExported Y;
PrintLabel Y >>
else
<< PrintLabel Y;
CodeDeclareExported Y >>;
lisp procedure FindEntryPoint X;
begin scalar E;
return if (E := get(X, 'EntryPoint)) then E
else if ASMSymbolP X and not get(X, 'ASMSymbol) then
<< put(X, 'EntryPoint, X);
X >>
else
<< E := StringGenSym();
put(X, 'EntryPoint, E);
E >>;
end;
lisp procedure ASMPseudoPrintFloat X;
PrintF(DoubleFloatFormat!*, cadr X);
put('Float, 'ASMPseudoOp, 'ASMPseudoPrintFloat);
lisp procedure ASMPseudoPrintFullWord X;
for each Y in cdr X do PrintFullWord Y;
put('FullWord, 'ASMPseudoOp, 'ASMPseudoPrintFullWord);
lisp procedure ASMPseudoPrintByte X;
PrintByteList cdr X;
put('Byte, 'ASMPseudoOp, 'ASMPseudoPrintByte);
lisp procedure ASMPseudoPrintHalfWord X;
PrintHalfWordList cdr X;
put('HalfWord, 'ASMPseudoOp, 'ASMPseudoPrintHalfWord);
lisp procedure ASMPseudoPrintString X;
PrintString cadr X;
put('String, 'ASMPseudoOp, 'ASMPseudoPrintString);
lisp procedure PrintOperand X;
if StringP X then Prin2 X
else if NumberP X then PrintNumericOperand X
else if IDP X then Prin2 FindLabel X
else begin scalar Hd, Fn;
Hd := car X;
if (Fn := get(Hd, 'OperandPrintFunction)) then
Apply(Fn, list X)
else if (Fn := GetD Hd) and car Fn = 'MACRO then
PrintOperand Apply(cdr Fn, list X)
else if (Fn := WConstEvaluable X) then PrintOperand Fn
else PrintExpression X;
end;
put('REG, 'OperandPrintFunction, 'PrintRegister);
lisp procedure PrintRegister X;
begin scalar Nam;
X := cadr X;
if StringP X then Prin2 X
else if NumberP X then Prin2 GetV(NumericRegisterNames!*, X)
else if Nam := RegisterNameP X then Prin2 Nam
else
<< ErrorPrintF("***** Unknown register %r", X);
Prin2 X >>;
end;
lisp procedure RegisterNameP X;
get(X, 'RegisterName);
lisp procedure ASMEntry X;
PrintExpression
list('plus2, 'SymFnc,
list('times2, AddressingUnitsPerFunctionCell,
list('IDLoc, cadr X)));
put('Entry, 'OperandPrintFunction, 'ASMEntry);
lisp procedure ASMInternalEntry X;
Prin2 FindEntryPoint cadr X;
put('InternalEntry, 'OperandPrintFunction, 'ASMInternalEntry);
put('InternalEntry, 'ASMExpressionFunction, 'ASMInternalEntry);
macro procedure ExtraReg U;
list('plus2, '(WArray ArgumentBlock), (cadr U - (LastActualReg!& + 1))
* AddressingUnitsPerItem);
lisp procedure ASMSyslispVarsPrint X;
Prin2 FindGlobalLabel cadr X;
DefList('((WVar ASMSyslispVarsPrint)
(WArray ASMSyslispVarsPrint)
(WString ASMSyslispVarsPrint)), 'OperandPrintFunction);
DefList('((WVar ASMSyslispVarsPrint)
(WArray ASMSyslispVarsPrint)
(WString ASMSyslispVarsPrint)), 'ASMExpressionFunction);
lisp procedure ASMPrintValueCell X;
PrintExpression list('plus2, 'SymVal,
list('times, AddressingUnitsPerItem,
list('IDLoc, cadr X)));
DefList('((fluid ASMPrintValueCell)
(!$fluid ASMPrintValueCell)
(global ASMPrintValueCell)
(!$global ASMPrintValueCell)), 'OperandPrintFunction);
% Redefinition of WDeclare for output to assembler file
% if either UpperBound or Initializer are NIL, they are considered to be
% unspecified.
fexpr procedure WDeclare U;
for each X in cddr U do WDeclare1(car X, car U, cadr U, cadr X, caddr X);
flag('(WDeclare), 'IGNORE);
lisp procedure WDeclare1(Name, Scope, Typ, UpperBound, Initializer);
if Typ = 'WCONST then
if Scope = 'EXTERNAL and not get(Name, 'WCONST) then
ErrorPrintF("*** A value has not been defined for WConst %r",
Name)
else
<< put(Name, 'SCOPE, if Scope = 'EXPORTED then 'EXTERNAL else Scope);
put(Name, 'WCONST, WConstReform Initializer) >>
else
<< put(Name, Typ, Name);
if Scope = 'EXTERNAL then
<< put(Name, 'SCOPE, 'EXTERNAL);
if not RegisterNameP Name then % kludge to avoid declaring
<< Name := LookupOrAddASMSymbol Name;
DataDeclareExternal Name; % registers as variables
CodeDeclareExternal Name >> >>
else
<< put(Name, 'SCOPE, if Scope = 'EXPORTED then 'EXTERNAL else Scope);
Name := LookupOrAddASMSymbol Name;
if !*DeclareBeforeUse then DataDeclareExported Name;
DataInit(Name,
Typ,
UpperBound,
Initializer);
if not !*DeclareBeforeUse then DataDeclareExported Name;
CodeDeclareExternal Name >> >>;
lisp procedure DataInit(ASMSymbol, Typ, UpperBound, Initializer);
<< DataAlignFullWord();
if Typ = 'WVAR then
<< if UpperBound then
ErrorPrintF "*** An UpperBound may not be specified for a WVar";
Initializer := if Initializer then WConstReform Initializer else 0;
DataPrintVar(ASMSymbol, Initializer) >>
else
<< if UpperBound and Initializer then
ErrorPrintF "*** Can't have both UpperBound and initializer"
else if not (UpperBound or Initializer) then
ErrorPrintF "*** Must have either UpperBound or initializer"
else if UpperBound then
DataPrintBlock(ASMSymbol, WConstReform UpperBound, Typ)
else
<< Initializer := if StringP Initializer then Initializer
else WConstReformLis Initializer;
DataPrintList(ASMSymbol, Initializer, Typ) >> >> >>;
lisp procedure WConstReform U;
begin scalar X;
return if FixP U or StringP U then U
else if IDP U then
if get(U, 'WARRAY) or get(U, 'WSTRING) then U
else if get(U,'WVAR) then list('GETMEM,U)
else if (X := get(U, 'WCONST)) then X
else ErrorPrintF("*** Unknown symbol %r in WConstReform", U)
else if PairP U then
if (X := get(car U, 'WConstReformPseudo)) then Apply(X, list U)
else if (X := get(car U, 'DOFN)) then X . WConstReformLis cdr U
else if MacroP car U then WConstReform Apply(cdr GetD car U, list U)
else car U . WConstReformLis cdr U
else ErrorPrintF("*** Illegal expression %r in WConstReform", U);
end;
lisp procedure WConstReformIdent U;
U;
put('InternalEntry, 'WConstReformPseudo, 'WConstReformIdent);
lisp procedure WConstReformQuote U;
CompileConstant cadr U;
put('QUOTE, 'WConstReformPseudo, 'WConstReformQuote);
lisp procedure WConstReformLis U;
for each X in U collect WConstReform X;
lisp procedure WConstReformLoc U; %. To handle &Foo[23]
<< U := WConstReform cadr U;
if car U neq 'GETMEM then
ErrorPrintF("*** Illegal constant addressing expression %r",
list('LOC, U))
else cadr U >>;
put('LOC, 'WConstReformPseudo, 'WConstReformLoc);
lisp procedure WConstReformIDLoc U;
FindIDNumber cadr U;
put('IDLoc, 'WConstReformPseudo, 'WConstReformIDLoc);
lisp procedure LookupOrAddASMSymbol U;
begin scalar X;
if not (X := get(U, 'ASMSymbol)) then X := AddASMSymbol U;
return X;
end;
lisp procedure AddASMSymbol U;
begin scalar X;
X := if ASMSymbolP U and not get(U, 'EntryPoint) then U
else StringGensym();
put(U, 'ASMSymbol, X);
return X;
end;
lisp procedure DataPrintVar(Name, Init);
begin scalar OldOut;
DataPrintLabel Name;
OldOut := WRS DataOut!*;
PrintFullWord Init;
WRS OldOut;
end;
lisp procedure DataPrintBlock(Name, Siz, Typ);
<< if Typ = 'WSTRING
then Siz := list('quotient, list('plus2, Siz, CharactersPerWord + 1),
CharactersPerWord)
else Siz := list('plus2, Siz, 1);
DataReserveZeroBlock(Name, Siz) >>;
lisp procedure DataPrintList(Nam, Init, Typ);
begin scalar OldOut;
DataPrintLabel Nam;
OldOut := WRS DataOut!*;
if Typ = 'WSTRING then
if StringP Init then
<< PrintFullWord Size Init;
PrintString Init >>
else
<< PrintFullWord(Length Init - 1);
PrintByteList Append(Init, '(0)) >>
else
if StringP Init then begin scalar S;
S := Size Init;
for I := 0 step 1 until S do
PrintFullWord Indx(Init, I);
end else for each X in Init do
PrintFullWord X;
WRS OldOut;
end;
lisp procedure DataPrintGlobalLabel X;
<< if !*DeclareBeforeUse then DataDeclareExported X;
DataPrintLabel X;
if not !*DeclareBeforeUse then DataDeclareExported X;
CodeDeclareExternal X >>;
lisp procedure DataDeclareExternal X;
if not (X member DataExternals!* or X member DataExporteds!*) then
<< DataExternals!* := X . DataExternals!*;
DataPrintF(ExternalDeclarationFormat!*, X, X) >>;
lisp procedure CodeDeclareExternal X;
if not (X member CodeExternals!* or X member CodeExporteds!*) then
<< CodeExternals!* := X . CodeExternals!*;
CodePrintF(ExternalDeclarationFormat!*, X, X) >>;
lisp procedure DataDeclareExported X;
<< if X member DataExternals!* or X member DataExporteds!* then
ErrorPrintF("***** %r multiply defined", X);
DataExporteds!* := X . DataExporteds!*;
DataPrintF(ExportedDeclarationFormat!*, X, X) >>;
lisp procedure CodeDeclareExported X;
<< if X member CodeExternals!* or X member CodeExporteds!* then
ErrorPrintF("***** %r multiply defined", X);
CodeExporteds!* := X . CodeExporteds!*;
CodePrintF(ExportedDeclarationFormat!*, X, X) >>;
lisp procedure PrintLabel X;
PrintF(LabelFormat!*, X,X);
lisp procedure DataPrintLabel X;
DataPrintF(LabelFormat!*, X,X);
lisp procedure CodePrintLabel X;
CodePrintF(LabelFormat!*, X,X);
lisp procedure PrintComment X;
PrintF(CommentFormat!*, X);
PrintExpressionForm!* := list('PrintExpression, MkQuote NIL);
PrintExpressionFormPointer!* := cdadr PrintExpressionForm!*;
% Save some consing
% instead of list('PrintExpression, MkQuote X), reuse the same list structure
lisp procedure PrintFullWord X;
<< RplacA(PrintExpressionFormPointer!*, X);
PrintF(FullWordFormat!*, PrintExpressionForm!*) >>;
lisp procedure DataPrintFullWord X;
<< RplacA(PrintExpressionFormPointer!*, X);
DataPrintF(FullWordFormat!*, PrintExpressionForm!*) >>;
lisp procedure CodePrintFullWord X;
<< RplacA(PrintExpressionFormPointer!*, X);
CodePrintF(FullWordFormat!*, PrintExpressionForm!*) >>;
lisp procedure DataReserveZeroBlock(Nam, X);
<< RplacA(PrintExpressionFormPointer!*,
list('Times2, AddressingUnitsPerItem, X));
DataPrintF(ReserveZeroBlockFormat!*, Nam, PrintExpressionForm!*) >>;
lisp procedure DataReserveBlock X;
<< RplacA(PrintExpressionFormPointer!*,
list('Times2, AddressingUnitsPerItem, X));
DataPrintF(ReserveDataBlockFormat!*, PrintExpressionForm!*) >>;
lisp procedure DataReserveFunctionCellBlock X;
<< RplacA(PrintExpressionFormPointer!*,
list('Times2, AddressingUnitsPerFunctionCell, X));
DataPrintF(ReserveDataBlockFormat!*, PrintExpressionForm!*) >>;
lisp procedure DataPrintUndefinedFunctionCell();
begin scalar OldOut;
OldOut := WRS DataOut!*;
for each X in UndefinedFunctionCellInstructions!* do
ASMOutLap1 X;
WRS OldOut;
end;
lisp procedure DataPrintDefinedFunctionCell X;
<<DataDeclareExternal X;
DataPrintF(DefinedFunctionCellFormat!*, X, X)>>;
% in case it's needed twice
lisp procedure DataPrintByteList X;
begin scalar OldOut;
OldOut := WRS DataOut!*;
PrintByteList X;
WRS OldOut;
end;
lisp procedure DataPrintExpression X;
begin scalar OldOut;
OldOut := WRS DataOut!*;
PrintExpression X;
WRS OldOut;
end;
lisp procedure CodePrintExpression X;
begin scalar OldOut;
OldOut := WRS CodeOut!*;
PrintExpression X;
WRS OldOut;
end;
ExpressionCount!* := -1;
lisp procedure PrintExpression X;
(lambda(ExpressionCount!*);
begin scalar Hd, Tl, Fn;
X := ResolveWConstExpression X;
if NumberP X or StringP X then Prin2 X
else if IDP X then Prin2 FindLabel X
else if atom X then
<< ErrorPrintF("***** Oddity in expression %r", X);
Prin2 X >>
else
<< Hd := car X;
Tl := cdr X;
if (Fn := get(Hd, 'BinaryASMOp)) then
<< if ExpressionCount!* > 0 then Prin2 ASMOpenParen!*;
PrintExpression car Tl;
Prin2 Fn;
PrintExpression cadr Tl;
if ExpressionCount!* > 0 then Prin2 ASMCloseParen!* >>
else if (Fn := get(Hd, 'UnaryASMOp)) then
<< Prin2 Fn;
PrintExpression car Tl >>
else if (Fn := get(Hd, 'ASMExpressionFormat)) then
Apply('PrintF, Fn . for each Y in Tl collect
list('PrintExpression, MkQuote Y))
else if (Fn := GetD Hd) and car Fn = 'MACRO then
PrintExpression Apply(cdr Fn, list X)
else if (Fn := get(Hd, 'ASMExpressionFunction)) then
Apply(Fn, list X)
else
<< ErrorPrintF("***** Unknown expression %r", X);
PrintF("*** Expression error %r ***", X) >> >>;
end)(ExpressionCount!* + 1);
lisp procedure ASMPrintWConst U;
PrintExpression cadr U;
put('WConst, 'ASMExpressionFunction, 'ASMPrintWConst);
DefList('((Plus2 !+)
(WPlus2 !+)
(Difference !-)
(WDifference !-)
(Times2 !*)
(WTimes2 !*)
(Quotient !/)
(WQuotient !/)), 'BinaryASMOp);
DefList('((Minus !-)
(WMinus !-)), 'UnaryASMOp);
lisp procedure CompileConstant X;
<< X := BuildConstant X;
if null cdr X then car X
else
<< If !*DeclareBeforeUse then CodeDeclareExported cadr X;
ASMOutLap cdr X;
DataDeclareExternal cadr X;
If Not !*DeclareBeforeUse then CodeDeclareExported cadr X;
car X >> >>;
CommentOutCode <<
lisp procedure CompileHeapData X;
begin scalar Y;
X := BuildConstant X;
return if null cdr X then car X
else
<< Y := WRS DataOut!*;
for each Z in cdr X do ASMOutLap1 Z;
DataDeclareExported cadr X;
WRS Y;
car X >>;
end;
>>;
lisp procedure DataPrintString X;
begin scalar OldOut;
OldOut := WRS DataOut!*;
PrintString X;
WRS OldOut;
end;
lisp procedure FindLabel X;
begin scalar Y;
return if (Y := Atsoc(X, LocalLabels!*)) then cdr Y
else if (Y := get(X, 'ASMSymbol)) then Y
else if (Y := get(X, 'WConst)) then Y
else FindLocalLabel X;
end;
lisp procedure FindLocalLabel X;
begin scalar Y;
return if (Y := Atsoc(X, LocalLabels!*)) then cdr Y
else
<< LocalLabels!* := (X . (Y := StringGensym())) . LocalLabels!*;
Y >>;
end;
lisp procedure FindGlobalLabel X;
get(X, 'ASMSymbol) or ErrorPrintF("***** Undefined symbol %r", X);
lisp procedure CodePrintF(Fmt, A1, A2, A3, A4);
begin scalar OldOut;
OldOut := WRS CodeOut!*;
PrintF(Fmt, A1, A2, A3, A4);
WRS OldOut;
end;
lisp procedure DataPrintF(Fmt, A1, A2, A3, A4);
begin scalar OldOut;
OldOut := WRS DataOut!*;
PrintF(Fmt, A1, A2, A3, A4);
WRS OldOut;
end;
% Kludge of the year, just to avoid having IDLOC defined during compilation
CompileTime fluid '(MACRO);
MACRO := 'MACRO;
PutD('IDLoc, MACRO,
function lambda X;
FindIDNumber cadr X);
END;