Apple-2gs-SW
/
ORCA-Pascal
mirror of https://github.com/byteworksinc/ORCA-Pascal.git
1
0
Fork 0
Code Issues Projects Releases Wiki Activity
ORCA-Pascal/cgi.pas

1253 lines
31 KiB
ObjectPascal
Raw Permalink Blame History

{$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?}
debugStrFlag: boolean; {gsbug/niftylist debug names?}
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}
debugStrFlag := false; {don't generate gsbug debug strings}
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'}
Reference in New Issue View Git Blame Copy Permalink