mirror of
https://github.com/byteworksinc/ORCA-Pascal.git
synced 2025-02-16 14:30:30 +00:00
1251 lines
31 KiB
ObjectPascal
1251 lines
31 KiB
ObjectPascal
{$optimize -1}
|
|
{---------------------------------------------------------------}
|
|
{ }
|
|
{ ORCA Code Generator Interface }
|
|
{ }
|
|
{ This unit serves as the glue code attaching a compiler }
|
|
{ to the code generator. It provides subroutines in a }
|
|
{ format that is convinient for the compiler during }
|
|
{ semantic analysis, and produces intermediate code records }
|
|
{ as output. These intermediate code records are then }
|
|
{ passed on to the code generator for optimization and }
|
|
{ native code generation. }
|
|
{ }
|
|
{$copy 'cgi.comments'}
|
|
{---------------------------------------------------------------}
|
|
|
|
unit CodeGeneratorInterface;
|
|
|
|
interface
|
|
|
|
{$segment 'cg'}
|
|
|
|
{$LibPrefix '0/obj/'}
|
|
|
|
uses PCommon;
|
|
|
|
{---------------------------------------------------------------}
|
|
|
|
const
|
|
{Code Generation}
|
|
{---------------}
|
|
maxLocalLabel = 300; {max # local variables}
|
|
maxString = 8000; {max # chars in string space}
|
|
|
|
{Error interface: these constants map }
|
|
{code generator error numbers into the }
|
|
{numbers used by the compiler's Error }
|
|
{subroutine. }
|
|
{--------------------------------------}
|
|
cge1 = 113; {compiler error}
|
|
cge2 = 111; {implementation restriction: too many local labels}
|
|
cge3 = 132; {implementation restriction: string space exhausted}
|
|
|
|
{size of internal types}
|
|
{----------------------}
|
|
cgByteSize = 1;
|
|
cgWordSize = 2;
|
|
cgLongSize = 4;
|
|
cgPointerSize = 4;
|
|
cgRealSize = 4;
|
|
cgDoubleSize = 8;
|
|
cgCompSize = 8;
|
|
cgExtendedSize = 10;
|
|
|
|
{token buffer (.int file)}
|
|
{------------------------}
|
|
{NOTE: tokenBuffSize also defined in objout.asm}
|
|
tokenBuffSize = 4095; {size of the token buffer}
|
|
|
|
type
|
|
{misc}
|
|
{----}
|
|
segNameType = packed array[1..10] of char; {segment name}
|
|
|
|
{p code}
|
|
{------}
|
|
pcodes = {pcode names}
|
|
(pc_adi,pc_adr,pc_and,pc_dvi,pc_dvr,pc_cnn,pc_cnv,pc_ior,pc_mod,pc_mpi,
|
|
pc_mpr,pc_ngi,pc_ngr,pc_not,pc_sbi,pc_sbr,pc_sto,pc_dec,dc_loc,pc_ent,
|
|
pc_fjp,pc_inc,pc_ind,pc_ixa,pc_lao,pc_lca,pc_ldo,pc_mov,pc_ret,pc_sro,
|
|
pc_xjp,pc_cup,pc_equ,pc_geq,pc_grt,pc_lda,pc_ldc,pc_leq,pc_les,pc_lod,
|
|
pc_neq,pc_str,pc_ujp,pc_add,pc_lnm,pc_nam,pc_cui,pc_cum,pc_tjp,dc_lab,
|
|
pc_usr,pc_umi,pc_udi,pc_lla,pc_lsl,pc_lad,pc_uim,dc_enp,pc_stk,dc_glb,
|
|
dc_dst,dc_str,pc_cop,pc_cpo,pc_tl1,pc_tl2,dc_pin,pc_shl,pc_shr,pc_bnd,
|
|
pc_bor,pc_bxr,pc_bnt,pc_bnl,pc_mpl,pc_dvl,pc_mdl,pc_sll,pc_slr,pc_bal,
|
|
pc_ngl,pc_adl,pc_sbl,pc_blr,pc_blx,pc_siz,dc_sym,pc_lnd,pc_lor,pc_vsr,
|
|
pc_uml,pc_udl,pc_ulm,pc_pds,dc_cns,dc_prm,pc_bno,pc_nop,pc_csp,pc_chk,
|
|
pc_abi,pc_abr,pc_abl,pc_sqi,pc_sql,pc_sqr,pc_rnd,pc_rn4,pc_odd,pc_odl,
|
|
pc_at2,pc_sgs,pc_uni,pc_pwr,pc_int,pc_dif,pc_inn,pc_prs,pc_fix,dc_fun,
|
|
pc_sin,pc_cos,pc_exp,pc_sqt,pc_log,pc_atn,pc_tan,pc_acs,pc_asn,pc_vct);
|
|
|
|
{intermediate code}
|
|
{-----------------}
|
|
baseTypeEnum = (cgByte,cgUByte,cgWord,cgUWord,cgLong,cgULong,
|
|
cgReal,cgDouble,cgComp,cgExtended,cgString,cgVoid,
|
|
cgSet);
|
|
|
|
setPtr = ^setRecord; {set constant}
|
|
setRecord = record
|
|
smax: integer;
|
|
sval: packed array[1..setsize] of char;
|
|
end;
|
|
|
|
icptr = ^intermediate_code;
|
|
intermediate_code = record {intermediate code record}
|
|
opcode: pcodes; {operation code}
|
|
p,q,r,s: integer; {operands}
|
|
lab: pStringPtr; {named label pointer}
|
|
next: icptr; {ptr to next statement}
|
|
left, right: icptr; {leaves for trees}
|
|
parents: integer; {number of parents}
|
|
case optype: baseTypeEnum of
|
|
cgByte,
|
|
cgUByte,
|
|
cgWord,
|
|
cgUWord : (opnd: longint; llab,slab: integer);
|
|
cgLong,
|
|
cgULong : (lval,lval2: longint);
|
|
cgReal,
|
|
cgDouble,
|
|
cgComp,
|
|
cgExtended : (rval: double);
|
|
cgString : (str: pStringPtr);
|
|
cgSet : (setp: setPtr);
|
|
cgVoid : (pval: longint; pstr: pStringPtr);
|
|
end;
|
|
|
|
{basic blocks}
|
|
{------------}
|
|
iclist = ^iclistRecord; {used to form lists of records}
|
|
iclistRecord = record
|
|
next: iclist;
|
|
op: icptr;
|
|
end;
|
|
|
|
blockPtr = ^block; {basic block edges}
|
|
blockListPtr = ^blockListRecord; {lists of blocks}
|
|
block = record
|
|
last, next: blockPtr; {for doubly linked list of blocks}
|
|
dfn: integer; {depth first order index}
|
|
visited: boolean; {has this node been visited?}
|
|
code: icptr; {code in the block}
|
|
c_in: iclist; {list of reaching definitions}
|
|
c_out: iclist; {valid definitions on exit}
|
|
c_gen: iclist; {generated definitions}
|
|
dom: blockListPtr; {dominators of this block}
|
|
end;
|
|
|
|
blockListRecord = record {lists of blocks}
|
|
next, last: blockListPtr;
|
|
dfn: integer;
|
|
end;
|
|
|
|
{65816 native code generation}
|
|
{----------------------------}
|
|
addressingMode = (implied,immediate, {65816 addressing modes}
|
|
longabs,longrelative,relative,absolute,direct,gnrLabel,gnrSpace,
|
|
gnrConstant,genaddress,special,longabsolute);
|
|
|
|
var
|
|
{misc}
|
|
{----}
|
|
keepflag: integer; {keep flag}
|
|
currentSegment,defaultSegment: segNameType; {current & default seg names}
|
|
symLength: integer; {length of debug symbol table}
|
|
|
|
|
|
{DAG construction}
|
|
{----------------}
|
|
DAGhead: icPtr; {1st ic in DAG list}
|
|
DAGblocks: blockPtr; {list of basic blocks}
|
|
|
|
|
|
{variables used to control the }
|
|
{quality or characteristics of }
|
|
{code }
|
|
{------------------------------}
|
|
cLineOptimize: boolean; {+o flag set?}
|
|
code: icptr; {current intermediate code record}
|
|
codeGeneration: boolean; {is code generation on?}
|
|
commonSubexpression: boolean; {do common subexpression removal?}
|
|
debugFlag: boolean; {generate debugger calls?}
|
|
floatCard: integer; {0 -> SANE; 1 -> FPE}
|
|
floatSlot: integer; {FPE slot}
|
|
isDynamic: boolean; {are segments dynamic?}
|
|
jslOptimizations: boolean; {do jsl optimizations?}
|
|
loopOptimizations: boolean; {do loop optimizations?}
|
|
npeephole: boolean; {do native code peephole optimizations?}
|
|
peephole: boolean; {do peephole optimization?}
|
|
profileFlag: boolean; {generate profiling code?}
|
|
rangeCheck: boolean; {generate range checks?}
|
|
registers: boolean; {do register optimizations?}
|
|
saveStack: boolean; {save, restore caller's stack reg?}
|
|
segmentKind: integer; {kind field of segment (ored with start/data)}
|
|
smallMemoryModel: boolean; {is the small model in use?}
|
|
stackSize: integer; {amount of stack space to reserve}
|
|
stringsize: 0..maxstring; {amount of string space left}
|
|
stringspace: packed array[1..maxstring] of char; {string table}
|
|
toolParms: boolean; {generate tool format paramaters?}
|
|
traceBack: boolean; {generate traceback code?}
|
|
|
|
{current instruction info}
|
|
{------------------------}
|
|
isJSL: boolean; {is the current opcode a jsl?}
|
|
|
|
{desk accessory variables}
|
|
{------------------------}
|
|
isNewDeskAcc: boolean; {is this a new desk acc?}
|
|
isClassicDeskAcc: boolean; {is this a classic desk acc?}
|
|
isCDev: boolean; {is this a control panel device?}
|
|
isNBA: boolean; {is this a new button action?}
|
|
isXCMD: boolean; {is this an XCMD?}
|
|
rtl: boolean; {return with an rtl?}
|
|
|
|
openName,closeName,actionName, {names of the required procedures}
|
|
initName: pStringPtr;
|
|
refreshPeriod: integer; {refresh period}
|
|
eventMask: integer; {event mask}
|
|
menuLine: pString; {name in menu bar}
|
|
|
|
{token buffer (.int file)}
|
|
{------------------------}
|
|
tokenDisp: 0..tokenBuffSize; {disp in token buffer}
|
|
tokenLen: longint; {size of token buffer}
|
|
tokenHandle: handle; {token file handle}
|
|
tokenNameGS: gsosOutStringPtr; {token file name}
|
|
tokenPtr: ptr; {pointer to active part of token file}
|
|
|
|
{---------------------------------------------------------------}
|
|
|
|
procedure CloseToken;
|
|
|
|
{ close the token file (.int file) }
|
|
|
|
|
|
procedure CodeGenFini;
|
|
|
|
{ terminal processing }
|
|
|
|
|
|
procedure CodeGenInit (keepName: gsosOutStringPtr; keepFlag: integer;
|
|
partial: boolean);
|
|
|
|
{ code generator initialization }
|
|
{ }
|
|
{ parameters: }
|
|
{ keepName - name of the output file }
|
|
{ keepFlag - keep status: }
|
|
{ 0 - don't keep the output }
|
|
{ 1 - create a new object module }
|
|
{ 2 - a .root already exists }
|
|
{ 3 - at least on .letter file exists }
|
|
{ partial - is this a partial compile? }
|
|
|
|
|
|
procedure CodeGenScalarInit;
|
|
|
|
{ initialize codegen scalars }
|
|
|
|
|
|
procedure DefaultSegName (s: segNameType);
|
|
|
|
{ set the default segment name }
|
|
{ }
|
|
{ parameters: }
|
|
{ s - segment name }
|
|
|
|
|
|
procedure Gen0 (fop: pcodes);
|
|
|
|
{ generate an implied operand instruction }
|
|
{ }
|
|
{ parameters: }
|
|
{ fop - operation code }
|
|
|
|
|
|
procedure Gen1 (fop: pcodes; fp2: integer);
|
|
|
|
{ generate an instruction with one numeric operand }
|
|
{ }
|
|
{ parameters: }
|
|
{ fop - operation code }
|
|
{ fp2 - operand }
|
|
|
|
|
|
procedure Gen2 (fop: pcodes; fp1, fp2: integer);
|
|
|
|
{ generate an instruction with two numeric operands }
|
|
{ }
|
|
{ parameters: }
|
|
{ fop - operation code }
|
|
{ fp1 - first operand }
|
|
{ fp2 - second operand }
|
|
|
|
|
|
procedure Gen3 (fop: pcodes; fp1, fp2, fp3: integer);
|
|
|
|
{ generate an instruction with three numeric operands }
|
|
{ }
|
|
{ parameters: }
|
|
{ fop - operation code }
|
|
{ fp1 - first operand }
|
|
{ fp2 - second operand }
|
|
{ fp3 - third operand }
|
|
|
|
|
|
procedure Gen0t (fop: pcodes; tp: baseTypeEnum);
|
|
|
|
{ generate a typed implied operand instruction }
|
|
{ }
|
|
{ parameters: }
|
|
{ fop - operation code }
|
|
{ tp - base type }
|
|
|
|
|
|
procedure Gen1t (fop: pcodes; fp1: integer; tp: baseTypeEnum);
|
|
|
|
{ generate a typed instruction with two numeric operands }
|
|
{ }
|
|
{ parameters: }
|
|
{ fop - operation code }
|
|
{ fp1 - operand }
|
|
{ tp - base type }
|
|
|
|
|
|
procedure Gen2t (fop: pcodes; fp1, fp2: integer; tp: baseTypeEnum);
|
|
|
|
{ generate a typed instruction with two numeric operands }
|
|
{ }
|
|
{ parameters: }
|
|
{ fop - operation code }
|
|
{ fp1 - first operand }
|
|
{ fp2 - second operand }
|
|
{ tp - base type }
|
|
|
|
|
|
procedure Gen3t (fop: pcodes; fp1, fp2, fp3: integer; tp: baseTypeEnum);
|
|
|
|
{ generate a typed instruction with three numeric operands }
|
|
{ }
|
|
{ parameters: }
|
|
{ fop - operation code }
|
|
{ fp1 - first operand }
|
|
{ fp2 - second operand }
|
|
{ fp3 - third operand }
|
|
{ tp - base type }
|
|
|
|
|
|
procedure Gen4t (fop: pcodes; fp1, fp2, fp3, fp4: integer; tp: baseTypeEnum);
|
|
|
|
{ generate a typed instruction with four numeric operands }
|
|
{ }
|
|
{ parameters: }
|
|
{ fop - operation code }
|
|
{ fp1 - first operand }
|
|
{ fp2 - second operand }
|
|
{ fp3 - third operand }
|
|
{ fp4 - fourth operand }
|
|
{ tp - base type }
|
|
|
|
|
|
procedure Gen0Name (fop: pcodes; name: pStringPtr);
|
|
|
|
{ generate a p-code with a name }
|
|
{ }
|
|
{ parameters: }
|
|
{ fop - operation code }
|
|
{ name - named label }
|
|
|
|
|
|
procedure Gen1Name (fop: pcodes; fp1: integer; name: pStringPtr);
|
|
|
|
{ generate a one operand p-code with a name }
|
|
{ }
|
|
{ parameters: }
|
|
{ fop - operation code }
|
|
{ fp1 - first operand }
|
|
{ name - named label }
|
|
|
|
|
|
procedure Gen2Name (fop: pcodes; fp1, fp2: integer; name: pStringPtr);
|
|
|
|
{ generate a two operand p-code with a name }
|
|
{ }
|
|
{ parameters: }
|
|
{ fop - operation code }
|
|
{ fp1 - first operand }
|
|
{ fp2 - second operand }
|
|
{ name - named label }
|
|
|
|
|
|
procedure Gen1tName (fop: pcodes; fp1: integer; tp: baseTypeEnum;
|
|
name: pStringPtr);
|
|
|
|
{ generate a typed one operand p-code with a name }
|
|
{ }
|
|
{ parameters: }
|
|
{ fop - operation code }
|
|
{ fp1 - first operand }
|
|
{ tp - base type }
|
|
{ name - named label }
|
|
|
|
|
|
procedure Gen2tName (fop: pcodes; fp1, fp2: integer; tp: baseTypeEnum;
|
|
name: pStringPtr);
|
|
|
|
{ generate a typed two operand p-code with a name }
|
|
{ }
|
|
{ parameters: }
|
|
{ fop - operation code }
|
|
{ fp1 - first operand }
|
|
{ fp2 - second operand }
|
|
{ tp - base type }
|
|
{ name - named label }
|
|
|
|
|
|
procedure Gen1L1t (fop: pcodes; fp1: integer; lval: longint; tp: baseTypeEnum);
|
|
|
|
{ generate an instruction with one integer and one longint }
|
|
{ }
|
|
{ parameters: }
|
|
{ fop - operation code }
|
|
{ fp1 - integer parameter }
|
|
{ lval - longint parameter }
|
|
{ tp - base type }
|
|
|
|
|
|
procedure GenL1t (fop: pcodes; lval: longint; tp: baseTypeEnum);
|
|
|
|
{ generate an instruction that uses a longint }
|
|
{ }
|
|
{ parameters: }
|
|
{ fop - operation code }
|
|
{ lval - longint parameter }
|
|
{ tp - base type }
|
|
|
|
|
|
procedure GenL2t (fop: pcodes; lval, lval2: longint; tp: baseTypeEnum);
|
|
|
|
{ generate an instruction that uses two longints }
|
|
{ }
|
|
{ parameters: }
|
|
{ fop - operation code }
|
|
{ lval, lval2 - longint parameters }
|
|
{ tp - base type }
|
|
|
|
|
|
procedure GenLdcLong (lval: longint);
|
|
|
|
{ load a long constant }
|
|
{ }
|
|
{ parameters: }
|
|
{ lval - value to load }
|
|
|
|
|
|
procedure GenLdcReal (rval: double);
|
|
|
|
{ load a real constant }
|
|
{ }
|
|
{ parameters: }
|
|
{ rval - value to load }
|
|
|
|
|
|
procedure GenLdcSet (cval: constantRec);
|
|
|
|
{ load a set constant }
|
|
{ }
|
|
{ parameters: }
|
|
{ cval - value to load }
|
|
|
|
|
|
procedure GenPS (fop: pcodes; str: pStringPtr);
|
|
|
|
{ generate an instruction that uses a p-string operand }
|
|
{ }
|
|
{ parameters: }
|
|
{ fop - operation code }
|
|
{ str - pointer to string }
|
|
|
|
|
|
procedure InitLabels; extern;
|
|
|
|
{ initialize the labels array for a procedure }
|
|
|
|
|
|
{procedure InitWriteCode; {debug}
|
|
|
|
{ initialize the intermediate code opcode table }
|
|
|
|
|
|
procedure NextSegName (s: segNameType);
|
|
|
|
{ set the segment name for the next segment created }
|
|
{ }
|
|
{ parameters: }
|
|
{ s - segment name }
|
|
|
|
|
|
{procedure PrintBlocks (tag: pStringPtr; bp: blockPtr); {debug}
|
|
|
|
{ print a series of basic blocks }
|
|
{ }
|
|
{ parameters: }
|
|
{ tag - label for lines }
|
|
{ bp - first block to print }
|
|
|
|
|
|
{procedure WriteCode (code: icptr); {debug}
|
|
|
|
{ print an intermediate code instruction }
|
|
{ }
|
|
{ Parameters: }
|
|
{ code - intermediate code instruction to write }
|
|
|
|
{---------------------------------------------------------------}
|
|
|
|
implementation
|
|
|
|
{var
|
|
opt: array[pcodes] of packed array[1..3] of char; {debug}
|
|
|
|
function NewHandle (blockSize: longint; userID, memAttributes: integer;
|
|
memLocation: univ ptr): handle; tool ($02, $09);
|
|
|
|
{Imported from ObjOut.pas:}
|
|
|
|
procedure CloseObj; extern;
|
|
|
|
{ close the current obj file }
|
|
|
|
|
|
procedure TokenOut (b: byte); extern;
|
|
|
|
{ Write a byte to the interface file }
|
|
{ }
|
|
{ parameters: }
|
|
{ b - byte to write }
|
|
|
|
|
|
{Imported from DAG.pas:}
|
|
|
|
procedure DAG (code: icptr); extern;
|
|
|
|
{ place an op code in a DAG or tree }
|
|
{ }
|
|
{ parameters: }
|
|
{ code - opcode }
|
|
|
|
|
|
{Imported from Native.pas:}
|
|
|
|
procedure InitFile (keepName: gsosOutStringPtr; keepFlag: integer; partial: boolean);
|
|
extern;
|
|
|
|
{ Set up the object file }
|
|
{ }
|
|
{ parameters: }
|
|
{ keepName - name of the output file }
|
|
{ keepFlag - keep status: }
|
|
{ 0 - don't keep the output }
|
|
{ 1 - create a new object module }
|
|
{ 2 - a .root already exists }
|
|
{ 3 - at least on .letter file exists }
|
|
{ partial - is this a partial compile? }
|
|
|
|
{---------------------------------------------------------------}
|
|
|
|
{ copy 'cgi.debug'} {debug}
|
|
|
|
procedure CloseToken;
|
|
|
|
{ close the token file (.int file) }
|
|
|
|
var
|
|
dsRec: destroyOSDCB; {DestroyGS record}
|
|
ffRec: fastFileDCBGS; {FastFile record}
|
|
i: 1..8; {loop/index variable}
|
|
|
|
begin {CloseToken}
|
|
if GetFileType(tokenNameGS^) = BIN then begin
|
|
dsRec.pCount := 1; {destroy any old file}
|
|
dsRec.pathname := @tokenNameGS^.theString;
|
|
DestroyGS(dsRec);
|
|
end; {if}
|
|
if doingUnit and codegeneration then begin
|
|
ffRec.pCount := 13;
|
|
ffRec.action := 3 {save} ;
|
|
ffRec.flags := $C000;
|
|
ffRec.fileHandle := tokenHandle;
|
|
ffRec.pathName := @tokenNameGS^.theString;
|
|
ffRec.access := $00C3;
|
|
ffRec.fileType := DVU;
|
|
ffRec.auxType := AuxUnit;
|
|
ffRec.storageType := 1;
|
|
for i := 1 to 8 do
|
|
ffRec.createDate[i] := 0;
|
|
ffRec.modDate := ffRec.createDate;
|
|
ffRec.option := nil;
|
|
ffRec.fileLength := tokenLen + tokenDisp;
|
|
FastFileGS(ffRec);
|
|
if ToolError <> 0 then
|
|
TermError(12, nil);
|
|
ffRec.action := 7 {purge} ;
|
|
ffRec.fileHandle := tokenHandle;
|
|
FastFileGS(ffRec);
|
|
if ToolError <> 0 then
|
|
TermError(12, nil);
|
|
end; {if}
|
|
end; {CloseToken}
|
|
|
|
|
|
procedure CodeGenFini;
|
|
|
|
{ terminal processing }
|
|
|
|
begin {CodeGenFini}
|
|
CloseObj; {close the open object file}
|
|
end; {CodeGenFini}
|
|
|
|
|
|
procedure CodeGenInit {keepName: gsosOutStringPtr; keepFlag: integer;
|
|
partial: boolean};
|
|
|
|
{ code generator initialization }
|
|
{ }
|
|
{ parameters: }
|
|
{ keepName - name of the output file }
|
|
{ keepFlag - keep status: }
|
|
{ 0 - don't keep the output }
|
|
{ 1 - create a new object module }
|
|
{ 2 - a .root already exists }
|
|
{ 3 - at least on .letter file exists }
|
|
{ partial - is this a partial compile? }
|
|
|
|
const
|
|
usesVersion = 1; {current uses file format version}
|
|
|
|
begin {CodeGenInit}
|
|
{initialize the debug tables {debug}
|
|
{InitWriteCode; {debug}
|
|
|
|
{initialize the label table}
|
|
InitLabels;
|
|
|
|
codeGeneration := true; {turn on code generation}
|
|
|
|
{set up the DAG variables}
|
|
DAGhead := nil; {no ics in DAG list}
|
|
|
|
InitFile(keepName, keepFlag, partial); {open the keep file}
|
|
|
|
if doingUnit then begin
|
|
new(tokenNameGS); {create the token file name}
|
|
tokenNameGS^ := keepName^;
|
|
if tokenNameGS^.theString.size < maxPath then
|
|
tokenNameGS^.theString.theString[tokenNameGS^.theString.size+1] := chr(0);
|
|
tokenNameGS^.theString.theString := concat(tokenNameGS^.theString.theString, '.int');
|
|
tokenNameGS^.theString.size := length(tokenNameGS^.theString.theString);
|
|
if memoryFlag then {memory-based compiles are not allowed}
|
|
TermError(10, nil);
|
|
tokenHandle := {get a token buffer}
|
|
NewHandle(tokenBuffSize+1, UserID, $8000, nil);
|
|
if ToolError <> 0 then
|
|
TermError(3, nil);
|
|
tokenPtr := tokenHandle^;
|
|
tokenDisp := 0;
|
|
tokenLen := 0;
|
|
TokenOut(usesVersion);
|
|
end; {if}
|
|
end; {CodeGenInit}
|
|
|
|
|
|
procedure CodeGenScalarInit;
|
|
|
|
{ initialize codegen scalars }
|
|
|
|
begin {CodeGenScalarInit}
|
|
isJSL := false; {the current opcode is not a jsl}
|
|
isNewDeskAcc := false; {assume a normal program}
|
|
isCDev := false;
|
|
isClassicDeskAcc := false;
|
|
isNBA := false;
|
|
isXCMD := false;
|
|
codeGeneration := false; {code generation is not turned on yet}
|
|
currentSegment := ' '; {start with the blank segment}
|
|
defaultSegment := ' ';
|
|
smallMemoryModel := true; {small memory model}
|
|
dataBank := false; {don't save/restore data bank}
|
|
stackSize := 0; {default to the launcher's stack size}
|
|
toolParms := false; {generate tool format parameters?}
|
|
rtl := false; {return with a ~QUIT}
|
|
floatCard := 0; {use SANE}
|
|
floatSlot := 0; {default to slot 0}
|
|
stringSize := 0; {no strings, yet}
|
|
|
|
rangeCheck := false; {don't generate range checks}
|
|
profileFlag := false; {don't generate profiling code}
|
|
debugFlag := false; {don't generate debug code}
|
|
traceBack := false; {don't generate traceback code}
|
|
|
|
registers := cLineOptimize; {don't do register optimizations}
|
|
peepHole := cLineOptimize; {not doing peephole optimization (yet)}
|
|
npeepHole := cLineOptimize;
|
|
commonSubexpression := cLineOptimize; {not doing common subexpression elimination}
|
|
loopOptimizations := cLineOptimize; {not doing loop optimizations, yet}
|
|
jslOptimizations := cLineOptimize; {not doing jsl optimizations, yet}
|
|
|
|
{allocate the initial p-code}
|
|
code := pointer(Calloc(sizeof(intermediate_code)));
|
|
code^.optype := cgWord;
|
|
end; {CodeGenScalarInit}
|
|
|
|
|
|
procedure DefaultSegName {s: segNameType};
|
|
|
|
{ set the default segment name }
|
|
{ }
|
|
{ parameters: }
|
|
{ s - segment name }
|
|
|
|
begin {DefaultSegName}
|
|
currentSegment := s;
|
|
defaultSegment := s;
|
|
end; {DefaultSegName}
|
|
|
|
|
|
procedure Gen0 {fop: pcodes};
|
|
|
|
{ generate an implied operand instruction }
|
|
{ }
|
|
{ parameters: }
|
|
{ fop - operation code }
|
|
|
|
begin {Gen0}
|
|
if codeGeneration then begin
|
|
|
|
{generate the intermediate code instruction}
|
|
code^.opcode := fop;
|
|
{ if printSymbols then {debug}
|
|
{ WriteCode(code); {debug}
|
|
DAG(code); {generate the code}
|
|
|
|
{initialize volitile variables for next intermediate code}
|
|
code := pointer(Calloc(sizeof(intermediate_code)));
|
|
{code^.lab := nil;}
|
|
code^.optype := cgWord;
|
|
end; {if}
|
|
end; {Gen0}
|
|
|
|
|
|
procedure Gen1 {fop: pcodes; fp2: integer};
|
|
|
|
{ generate an instruction with one numeric operand }
|
|
{ }
|
|
{ parameters: }
|
|
{ fop - operation code }
|
|
{ fp2 - operand }
|
|
|
|
begin {Gen1}
|
|
if codeGeneration then begin
|
|
if fop = pc_ret then
|
|
code^.optype := cgVoid;
|
|
code^.q := fp2;
|
|
Gen0(fop);
|
|
end; {if}
|
|
end; {Gen1}
|
|
|
|
|
|
procedure Gen2 {fop: pcodes; fp1, fp2: integer};
|
|
|
|
{ generate an instruction with two numeric operands }
|
|
{ }
|
|
{ parameters: }
|
|
{ fop - operation code }
|
|
{ fp1 - first operand }
|
|
{ fp2 - second operand }
|
|
|
|
label 1;
|
|
|
|
var
|
|
lcode: icptr; {local copy of code}
|
|
|
|
begin {Gen2}
|
|
if codeGeneration then begin
|
|
lcode := code;
|
|
case fop of
|
|
|
|
dc_fun,pc_lnm,pc_tl1,pc_tl2,pc_lda,dc_loc,pc_mov: begin
|
|
lcode^.r := fp1;
|
|
lcode^.q := fp2;
|
|
end;
|
|
|
|
pc_cnn,pc_cnv:
|
|
if fp1 = fp2 then
|
|
goto 1
|
|
else if (baseTypeEnum(fp1) in [cgReal,cgDouble,cgComp,cgExtended])
|
|
and (baseTypeEnum(fp2) in [cgReal,cgDouble,cgComp,cgExtended]) then
|
|
goto 1
|
|
else if (baseTypeEnum(fp1) in [cgUByte,cgWord,cgUWord])
|
|
and (baseTypeEnum(fp2) in [cgWord,cgUWord]) then
|
|
goto 1
|
|
else if (baseTypeEnum(fp1) in [cgByte,cgUByte])
|
|
and (baseTypeEnum(fp2) in [cgByte,cgUByte]) then
|
|
goto 1
|
|
else
|
|
lcode^.q := (fp1 << 4) | fp2;
|
|
|
|
otherwise:
|
|
Error(cge1);
|
|
end; {case}
|
|
|
|
Gen0(fop);
|
|
end; {if}
|
|
1:
|
|
end; {Gen2}
|
|
|
|
|
|
procedure Gen3 {fop: pcodes; fp1, fp2, fp3: integer};
|
|
|
|
{ generate an instruction with three numeric operands }
|
|
{ }
|
|
{ parameters: }
|
|
{ fop - operation code }
|
|
{ fp1 - first operand }
|
|
{ fp2 - second operand }
|
|
{ fp3 - third operand }
|
|
|
|
var
|
|
lcode: icptr; {local copy of code}
|
|
|
|
begin {Gen3}
|
|
if codeGeneration then begin
|
|
lcode := code;
|
|
if fop = pc_lda then begin
|
|
lcode^.s := fp1;
|
|
lcode^.p := fp2;
|
|
lcode^.q := fp3;
|
|
end {if}
|
|
else begin
|
|
lcode^.s := fp1;
|
|
lcode^.q := fp2;
|
|
lcode^.r := fp3;
|
|
end; {else}
|
|
Gen0(fop);
|
|
end; {if}
|
|
end; {Gen3}
|
|
|
|
|
|
procedure Gen0t {fop: pcodes; tp: baseTypeEnum};
|
|
|
|
{ generate a typed implied operand instruction }
|
|
{ }
|
|
{ parameters: }
|
|
{ fop - operation code }
|
|
{ tp - base type }
|
|
|
|
begin {Gen0t}
|
|
if codeGeneration then begin
|
|
code^.optype := tp;
|
|
Gen0(fop);
|
|
end; {if}
|
|
end; {Gen0t}
|
|
|
|
|
|
procedure Gen1t {fop: pcodes; fp1: integer; tp: baseTypeEnum};
|
|
|
|
{ generate a typed instruction with two numeric operands }
|
|
{ }
|
|
{ parameters: }
|
|
{ fop - operation code }
|
|
{ fp1 - operand }
|
|
{ tp - base type }
|
|
|
|
var
|
|
lcode: icptr; {local copy of code}
|
|
|
|
begin {Gen1t}
|
|
if codeGeneration then begin
|
|
lcode := code;
|
|
lcode^.optype := tp;
|
|
lcode^.q := fp1;
|
|
Gen0(fop);
|
|
end; {if}
|
|
end; {Gen1t}
|
|
|
|
|
|
procedure Gen2t {fop: pcodes; fp1, fp2: integer; tp: baseTypeEnum};
|
|
|
|
{ generate a typed instruction with two numeric operands }
|
|
{ }
|
|
{ parameters: }
|
|
{ fop - operation code }
|
|
{ fp1 - first operand }
|
|
{ fp2 - second operand }
|
|
{ tp - base type }
|
|
|
|
var
|
|
lcode: icptr; {local copy of code}
|
|
|
|
begin {Gen2t}
|
|
if codeGeneration then begin
|
|
lcode := code;
|
|
lcode^.optype := tp;
|
|
lcode^.r := fp1;
|
|
lcode^.q := fp2;
|
|
Gen0(fop);
|
|
end; {if}
|
|
end; {Gen2t}
|
|
|
|
|
|
procedure Gen3t {fop: pcodes; fp1, fp2, fp3: integer; tp: baseTypeEnum};
|
|
|
|
{ generate a typed instruction with three numeric operands }
|
|
{ }
|
|
{ parameters: }
|
|
{ fop - operation code }
|
|
{ fp1 - first operand }
|
|
{ fp2 - second operand }
|
|
{ fp3 - third operand }
|
|
{ tp - base type }
|
|
|
|
var
|
|
lcode: icptr; {local copy of code}
|
|
|
|
begin {Gen3t}
|
|
if codeGeneration then begin
|
|
lcode := code;
|
|
lcode^.optype := tp;
|
|
if fop in [pc_lod, pc_str] then begin
|
|
lcode^.r := fp1;
|
|
lcode^.q := fp2;
|
|
lcode^.p := fp3;
|
|
end {if}
|
|
else begin
|
|
lcode^.s := fp1;
|
|
lcode^.q := fp2;
|
|
lcode^.r := fp3;
|
|
end; {else if}
|
|
Gen0(fop);
|
|
end; {if}
|
|
end; {Gen3t}
|
|
|
|
|
|
procedure Gen4t {fop: pcodes; fp1, fp2, fp3, fp4: integer; tp: baseTypeEnum};
|
|
|
|
{ generate a typed instruction with four numeric operands }
|
|
{ }
|
|
{ parameters: }
|
|
{ fop - operation code }
|
|
{ fp1 - first operand }
|
|
{ fp2 - second operand }
|
|
{ fp3 - third operand }
|
|
{ fp4 - fourth operand }
|
|
{ tp - base type }
|
|
|
|
var
|
|
lcode: icptr; {local copy of code}
|
|
|
|
begin {Gen4t}
|
|
if codeGeneration then begin
|
|
lcode := code;
|
|
lcode^.optype := tp;
|
|
lcode^.r := fp1;
|
|
lcode^.q := fp2;
|
|
lcode^.p := fp3;
|
|
lcode^.s := fp4;
|
|
Gen0(fop);
|
|
end; {if}
|
|
end; {Gen4t}
|
|
|
|
|
|
procedure Gen0Name {fop: pcodes; name: pStringPtr};
|
|
|
|
{ generate a p-code with a name }
|
|
{ }
|
|
{ parameters: }
|
|
{ fop - operation code }
|
|
{ name - named label }
|
|
|
|
begin {Gen0Name}
|
|
if codeGeneration then begin
|
|
code^.lab := name;
|
|
Gen0(fop);
|
|
end; {if}
|
|
end; {Gen0Name}
|
|
|
|
|
|
procedure Gen1Name {fop: pcodes; fp1: integer; name: pStringPtr};
|
|
|
|
{ generate a one operand p-code with a name }
|
|
{ }
|
|
{ parameters: }
|
|
{ fop - operation code }
|
|
{ fp1 - first operand }
|
|
{ name - named label }
|
|
|
|
var
|
|
lcode: icptr; {local copy of code}
|
|
|
|
begin {Gen1Name}
|
|
if codeGeneration then begin
|
|
lcode := code;
|
|
lcode^.q := fp1;
|
|
lcode^.lab := name;
|
|
Gen0(fop);
|
|
end; {if}
|
|
end; {Gen1Name}
|
|
|
|
|
|
procedure Gen2Name {fop: pcodes; fp1, fp2: integer; name: pStringPtr};
|
|
|
|
{ generate a two operand p-code with a name }
|
|
{ }
|
|
{ parameters: }
|
|
{ fop - operation code }
|
|
{ fp1 - first operand }
|
|
{ fp2 - second operand }
|
|
{ name - named label }
|
|
|
|
var
|
|
lcode: icptr; {local copy of code}
|
|
|
|
begin {Gen2Name}
|
|
if codeGeneration then begin
|
|
lcode := code;
|
|
lcode^.q := fp2;
|
|
lcode^.r := fp1;
|
|
lcode^.lab := name;
|
|
Gen0(fop);
|
|
end; {if}
|
|
end; {Gen2Name}
|
|
|
|
|
|
procedure Gen1tName {fop: pcodes; fp1: integer; tp: baseTypeEnum;
|
|
name: pStringPtr};
|
|
|
|
{ generate a typed one operand p-code with a name }
|
|
{ }
|
|
{ parameters: }
|
|
{ fop - operation code }
|
|
{ fp1 - first operand }
|
|
{ tp - base type }
|
|
{ name - named label }
|
|
|
|
var
|
|
lcode: icptr; {local copy of code}
|
|
|
|
begin {Gen1tName}
|
|
if codeGeneration then begin
|
|
lcode := code;
|
|
lcode^.q := fp1;
|
|
lcode^.lab := name;
|
|
lcode^.optype := tp;
|
|
Gen0(fop);
|
|
end; {if}
|
|
end; {Gen1tName}
|
|
|
|
|
|
procedure Gen2tName {fop: pcodes; fp1, fp2: integer; tp: baseTypeEnum;
|
|
name: pStringPtr};
|
|
|
|
{ generate a typed two operand p-code with a name }
|
|
{ }
|
|
{ parameters: }
|
|
{ fop - operation code }
|
|
{ fp1 - first operand }
|
|
{ fp2 - second operand }
|
|
{ tp - base type }
|
|
{ name - named label }
|
|
|
|
var
|
|
lcode: icptr; {local copy of code}
|
|
|
|
begin {Gen2tName}
|
|
if codeGeneration then begin
|
|
lcode := code;
|
|
lcode^.r := fp1;
|
|
lcode^.q := fp2;
|
|
lcode^.lab := name;
|
|
lcode^.optype := tp;
|
|
Gen0(fop);
|
|
end; {if}
|
|
end; {Gen2tName}
|
|
|
|
|
|
procedure Gen1L1t {fop: pcodes; fp1: integer; lval: longint; tp: baseTypeEnum};
|
|
|
|
{ generate an instruction with one integer and one longint }
|
|
{ }
|
|
{ parameters: }
|
|
{ fop - operation code }
|
|
{ fp1 - integer parameter }
|
|
{ lval - longint parameter }
|
|
{ tp - base type }
|
|
|
|
var
|
|
lcode: icptr; {local copy of code}
|
|
|
|
begin {Gen1L1t}
|
|
if codeGeneration then begin
|
|
lcode := code;
|
|
lcode^.optype := tp;
|
|
lcode^.q := fp1;
|
|
lcode^.lval := lval;
|
|
Gen0(fop);
|
|
end; {if}
|
|
end; {Gen1L1t}
|
|
|
|
|
|
procedure GenL1t {fop: pcodes; lval: longint; tp: baseTypeEnum};
|
|
|
|
{ generate an instruction that uses a longint }
|
|
{ }
|
|
{ parameters: }
|
|
{ fop - operation code }
|
|
{ lval - longint parameter }
|
|
{ tp - base type }
|
|
|
|
var
|
|
lcode: icptr; {local copy of code}
|
|
|
|
begin {GenL1t}
|
|
if codeGeneration then begin
|
|
lcode := code;
|
|
lcode^.optype := tp;
|
|
lcode^.lval := lval;
|
|
Gen0(fop);
|
|
end; {if}
|
|
end; {GenL1t}
|
|
|
|
|
|
procedure GenL2t {fop: pcodes; lval, lval2: longint; tp: baseTypeEnum};
|
|
|
|
{ generate an instruction that uses a longint and an int }
|
|
{ }
|
|
{ parameters: }
|
|
{ fop - operation code }
|
|
{ lval, lval2 - longint parameters }
|
|
{ tp - base type }
|
|
|
|
var
|
|
lcode: icptr; {local copy of code}
|
|
|
|
begin {GenL2t}
|
|
if codeGeneration then begin
|
|
lcode := code;
|
|
lcode^.optype := tp;
|
|
lcode^.lval := lval;
|
|
lcode^.lval2 := lval2;
|
|
Gen0(fop);
|
|
end; {if}
|
|
end; {GenL2t}
|
|
|
|
|
|
procedure GenLdcLong {lval: longint};
|
|
|
|
{ load a long constant }
|
|
{ }
|
|
{ parameters: }
|
|
{ lval - value to load }
|
|
|
|
var
|
|
lcode: icptr; {local copy of code}
|
|
|
|
begin {GenLdcLong}
|
|
if codeGeneration then begin
|
|
lcode := code;
|
|
if lval >= 0 then
|
|
lcode^.optype := cgULong
|
|
else
|
|
lcode^.optype := cgLong;
|
|
lcode^.lval := lval;
|
|
Gen0(pc_ldc);
|
|
end; {if}
|
|
end; {GenLdcLong}
|
|
|
|
|
|
procedure GenLdcReal {rval: double};
|
|
|
|
{ load a real constant }
|
|
{ }
|
|
{ parameters: }
|
|
{ rval - value to load }
|
|
|
|
var
|
|
lcode: icptr; {local copy of code}
|
|
|
|
begin {GenLdcReal}
|
|
if codeGeneration then begin
|
|
lcode := code;
|
|
lcode^.optype := cgReal;
|
|
lcode^.rval := rval;
|
|
Gen0(pc_ldc);
|
|
end; {if}
|
|
end; {GenLdcReal}
|
|
|
|
|
|
procedure GenLdcSet {cval: constantRec};
|
|
|
|
{ load a set constant }
|
|
{ }
|
|
{ parameters: }
|
|
{ cval - value to load }
|
|
|
|
var
|
|
i, k: unsigned; {loop/index variables}
|
|
lcode: icptr; {local copy of code}
|
|
|
|
begin {GenLdcSet}
|
|
if codeGeneration then begin
|
|
lcode := code;
|
|
lcode^.optype := cgSet;
|
|
i := cval.pmax div 8 + 1;
|
|
lcode^.setp := pointer(Calloc(3+i));
|
|
with lcode^.setp^ do begin
|
|
smax := i;
|
|
for k := 1 to i do
|
|
sval[k] := cval.ch[k-1];
|
|
end; {with}
|
|
Gen0(pc_ldc);
|
|
end; {if}
|
|
end; {GenLdcSet}
|
|
|
|
|
|
procedure GenPS {fop: pcodes; str: pStringPtr};
|
|
|
|
{ generate an instruction that uses a p-string operand }
|
|
{ }
|
|
{ parameters: }
|
|
{ fop - operation code }
|
|
{ str - pointer to string }
|
|
|
|
var
|
|
lcode: icptr; {local copy of code}
|
|
|
|
begin {GenPS}
|
|
if codeGeneration then begin
|
|
lcode := code;
|
|
lcode^.q := length(str^);
|
|
lcode^.optype := cgString;
|
|
lcode^.str := str;
|
|
Gen0(fop);
|
|
end; {if}
|
|
end; {GenPS}
|
|
|
|
|
|
procedure NextSegName {s: segNameType};
|
|
|
|
{ set the segment name for the next segment created }
|
|
{ }
|
|
{ parameters: }
|
|
{ s - segment name }
|
|
|
|
begin {NextSegmentName}
|
|
currentSegment := s;
|
|
end; {NextSegmentName}
|
|
|
|
end.
|
|
|
|
{$append 'cgi.asm'}
|