mirror of
https://github.com/byteworksinc/ORCA-C.git
synced 2024-05-28 12:41:35 +00:00
bb1bd176f4
This provides a more straightforward way to place the compiler in a "strict conformance" mode. This could essentially be achieved by setting several pragma options, but having a single setting is simpler. "Compatibility modes" for older standards can also be selected, although these actually continue to enable most C17 features (since they are unlikely to cause compatibility problems for older code).
1484 lines
54 KiB
ObjectPascal
1484 lines
54 KiB
ObjectPascal
{$optimize 7}
|
|
{---------------------------------------------------------------}
|
|
{ }
|
|
{ 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 convenient 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 CCommon;
|
|
|
|
const
|
|
{Error interface: these constants map }
|
|
{code generator error numbers into the }
|
|
{numbers used by the compiler's Error }
|
|
{subroutine. }
|
|
{--------------------------------------}
|
|
cge1 = 57; {compiler error}
|
|
cge2 = 58; {implementation restriction: too many local labels}
|
|
cge3 = 60; {implementation restriction: string space exhausted}
|
|
|
|
{65816 native code generation}
|
|
{----------------------------}
|
|
{instruction modifier flags}
|
|
shift8 = 1; {shift operand right 8 bits}
|
|
shift16 = 2; {shift operand right 16 bits}
|
|
toolCall = 4; {generate a tool call}
|
|
stringReference = 8; {generate a string reference}
|
|
isPrivate = 32; {is the label private?}
|
|
constantOpnd = 64; {the absolute operand is a constant}
|
|
localLab = 128; {the operand is a local lab}
|
|
forFlags = 256; {instruction used for effect on flags only}
|
|
subtract1 = 512; {subtract 1 from address operand}
|
|
shiftLeft8 = 1024; {shift operand left 8 bits}
|
|
|
|
m_adc_abs = $6D; {op code #s for 65816 instructions}
|
|
m_adc_dir = $65;
|
|
m_adc_imm = $69;
|
|
m_adc_s = $63;
|
|
m_adc_indl = $67;
|
|
m_adc_indly = $77;
|
|
m_and_abs = $2D;
|
|
m_and_dir = $25;
|
|
m_and_imm = $29;
|
|
m_and_s = $23;
|
|
m_and_indl = $27;
|
|
m_and_indly = $37;
|
|
m_asl_a = $0A;
|
|
m_bcc = $90;
|
|
m_bcs = $B0;
|
|
m_beq = $F0;
|
|
m_bit_imm = $89;
|
|
m_bmi = $30;
|
|
m_bne = $D0;
|
|
m_bpl = $10;
|
|
m_bra = $80;
|
|
m_brl = $82;
|
|
m_bvs = $70;
|
|
m_clc = $18;
|
|
m_cmp_abs = $CD;
|
|
m_cmp_dir = $C5;
|
|
m_cmp_dirX = $D5;
|
|
m_cmp_imm = $C9;
|
|
m_cmp_long = $CF;
|
|
m_cmp_s = $C3;
|
|
m_cmp_indl = $C7;
|
|
m_cmp_indly = $D7;
|
|
m_cop = $02;
|
|
m_cpx_abs = 236;
|
|
m_cpx_dir = 228;
|
|
m_cpx_imm = 224;
|
|
m_dea = 58;
|
|
m_dec_abs = 206;
|
|
m_dec_absX = $DE;
|
|
m_dec_dir = 198;
|
|
m_dec_dirX = 214;
|
|
m_dex = 202;
|
|
m_dey = 136;
|
|
m_eor_abs = 77;
|
|
m_eor_dir = 69;
|
|
m_eor_imm = 73;
|
|
m_eor_s = 67;
|
|
m_eor_indl = $47;
|
|
m_eor_indly = $57;
|
|
m_ina = 26;
|
|
m_inc_abs = 238;
|
|
m_inc_absX = $FE;
|
|
m_inc_dir = 230;
|
|
m_inc_dirX = 246;
|
|
m_inx = 232;
|
|
m_iny = 200;
|
|
m_jml = 92;
|
|
m_jmp_indX = $7C;
|
|
m_jsl = 34;
|
|
m_lda_abs = 173;
|
|
m_lda_absx = 189;
|
|
m_lda_dir = 165;
|
|
m_lda_dirx = 181;
|
|
m_lda_imm = 169;
|
|
m_lda_indl = 167;
|
|
m_lda_indly = 183;
|
|
m_lda_long = 175;
|
|
m_lda_longx = 191;
|
|
m_lda_s = 163;
|
|
m_ldx_abs = 174;
|
|
m_ldx_dir = 166;
|
|
m_ldx_imm = 162;
|
|
m_ldy_abs = 172;
|
|
m_ldy_absX = 188;
|
|
m_ldy_dir = 164;
|
|
m_ldy_dirX = 180;
|
|
m_ldy_imm = 160;
|
|
m_lsr_a = 74;
|
|
m_mvn = 84;
|
|
m_ora_abs = 13;
|
|
m_ora_dir = 5;
|
|
m_ora_dirX = 21;
|
|
m_ora_imm = 9;
|
|
m_ora_long = 15;
|
|
m_ora_longX = 31;
|
|
m_ora_s = 3;
|
|
m_ora_indl = $07;
|
|
m_ora_indly = $17;
|
|
m_pea = 244;
|
|
m_pei_dir = 212;
|
|
m_pha = 72;
|
|
m_phb = 139;
|
|
m_phd = 11;
|
|
m_phx = 218;
|
|
m_phy = 90;
|
|
m_php = 8;
|
|
m_pla = 104;
|
|
m_plb = 171;
|
|
m_pld = 43;
|
|
m_plx = 250;
|
|
m_ply = 122;
|
|
m_plp = 40;
|
|
m_rep = 194;
|
|
m_rol_a = $2A;
|
|
m_ror_a = $6A;
|
|
m_rtl = 107;
|
|
m_rts = 96;
|
|
m_sbc_abs = 237;
|
|
m_sbc_dir = 229;
|
|
m_sbc_imm = 233;
|
|
m_sbc_s = 227;
|
|
m_sbc_indl = $E7;
|
|
m_sbc_indly = $F7;
|
|
m_sec = 56;
|
|
m_sep = 226;
|
|
m_sta_abs = 141;
|
|
m_sta_absX = 157;
|
|
m_sta_dir = 133;
|
|
m_sta_dirX = 149;
|
|
m_sta_indl = 135;
|
|
m_sta_indlY = 151;
|
|
m_sta_long = 143;
|
|
m_sta_longX = 159;
|
|
m_sta_s = 131;
|
|
m_stx_dir = 134;
|
|
m_stx_abs = 142;
|
|
m_sty_abs = 140;
|
|
m_sty_dir = 132;
|
|
m_sty_dirX = 148;
|
|
m_stz_abs = 156;
|
|
m_stz_absX = 158;
|
|
m_stz_dir = 100;
|
|
m_stz_dirX = 116;
|
|
m_tax = 170;
|
|
m_tay = 168;
|
|
m_tcd = 91;
|
|
m_tcs = 27;
|
|
m_tdc = 123;
|
|
m_tsx = $BA;
|
|
m_txa = 138;
|
|
m_txs = $9A;
|
|
m_txy = 155;
|
|
m_tya = 152;
|
|
m_tyx = 187;
|
|
m_tsb_dir = $04;
|
|
m_tsb_abs = $0C;
|
|
m_tsc = 59;
|
|
m_xba = $EB;
|
|
|
|
d_lab = 256;
|
|
d_end = 257;
|
|
d_bmov = 258;
|
|
d_add = 259;
|
|
d_pin = 260;
|
|
d_wrd = 261;
|
|
d_sym = 262;
|
|
d_cns = 263;
|
|
d_dcb = 264;
|
|
d_dcw = 265;
|
|
d_dcl = 266;
|
|
|
|
max_opcode = 266;
|
|
|
|
asmFlag = $8000; {or'd with opcode to indicate asm code}
|
|
|
|
{Code Generation}
|
|
{---------------}
|
|
maxCBuff = 191; {length of constant buffer}
|
|
{Note: maxlabel is also defined in CCommon.pas}
|
|
{Note: maxlabel is also defined in CGC.asm}
|
|
maxLabel = 3275; {max # of internal labels}
|
|
maxLocalLabel = 512; {max # local variables}
|
|
maxString = 32760; {max # chars in string space}
|
|
|
|
{size of internal types}
|
|
{----------------------}
|
|
cgByteSize = 1;
|
|
cgWordSize = 2;
|
|
cgLongSize = 4;
|
|
cgQuadSize = 8;
|
|
cgPointerSize = 4;
|
|
cgRealSize = 4;
|
|
cgDoubleSize = 8;
|
|
cgCompSize = 8;
|
|
cgExtendedSize = 10;
|
|
|
|
type
|
|
segNameType = packed array[1..10] of char; {segment name}
|
|
stringSpaceType = packed array[1..maxstring] of char; {string space}
|
|
|
|
{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_ldl,pc_leq,pc_les,
|
|
pc_lil,pc_lld,pc_lli,pc_lod,pc_neq,pc_str,pc_ujp,pc_add,pc_lnm,pc_nam,
|
|
pc_cui,pc_lad,pc_tjp,dc_lab,pc_usr,pc_umi,pc_udi,
|
|
pc_uim,dc_enp,pc_stk,dc_glb,dc_dst,dc_str,pc_cop,pc_cpo,pc_tl1,
|
|
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,
|
|
dc_sym,pc_lnd,pc_lor,pc_vsr,pc_uml,pc_udl,pc_ulm,pc_pop,pc_gil,
|
|
pc_gli,pc_gdl,pc_gld,pc_cpi,pc_tri,pc_lbu,pc_lbf,pc_sbf,pc_cbf,dc_cns,
|
|
dc_prm,pc_nat,pc_bno,pc_nop,pc_psh,pc_ili,pc_iil,pc_ild,pc_idl,
|
|
pc_bqr,pc_bqx,pc_baq,pc_bnq,pc_ngq,pc_adq,pc_sbq,pc_mpq,pc_umq,pc_dvq,
|
|
pc_udq,pc_mdq,pc_uqm,pc_slq,pc_sqr,pc_wsr,pc_rbo,pc_fix);
|
|
|
|
{intermediate code}
|
|
{-----------------}
|
|
icptr = ^intermediate_code;
|
|
intermediate_code = record {intermediate code record}
|
|
opcode: pcodes; {operation code}
|
|
q,r,s: integer; {operands}
|
|
lab: stringPtr; {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: longint);
|
|
cgQuad,
|
|
cgUQuad : (qval: longlong);
|
|
cgReal,
|
|
cgDouble,
|
|
cgComp,
|
|
cgExtended : (rval: extended);
|
|
cgString : (
|
|
case isByteSeq: boolean of
|
|
false : (str: longStringPtr);
|
|
true : (data: ptr; len: longint);
|
|
);
|
|
cgVoid,
|
|
ccPointer : (pval: longint; pstr: longStringPtr);
|
|
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
|
|
{current instruction info}
|
|
{------------------------}
|
|
isJSL: boolean; {is the current opcode a jsl?}
|
|
|
|
{65816 native code generation}
|
|
{----------------------------}
|
|
longA,longI: boolean; {register sizes}
|
|
|
|
{variables used to control the }
|
|
{quality or characteristics of }
|
|
{code }
|
|
{------------------------------}
|
|
checkStack: boolean; {check stack for stack errors?}
|
|
cLineOptimize: boolean; {+o flag set?}
|
|
code: icptr; {current intermediate code record}
|
|
codeGeneration: boolean; {is code generation on?}
|
|
commonSubexpression: boolean; {do common subexpression removal?}
|
|
currentSegment,defaultSegment: segNameType; {current & default seg names}
|
|
segmentKind: integer; {kind field of segment (ored with start/data)}
|
|
debugFlag: boolean; {generate debugger calls?}
|
|
debugStrFlag: boolean; {gsbug/niftylist debug names?}
|
|
dataBank: boolean; {save, restore data bank?}
|
|
fastMath: boolean; {do FP math opts that break IEEE rules?}
|
|
floatCard: integer; {0 -> SANE; 1 -> FPE}
|
|
floatSlot: integer; {FPE slot}
|
|
loopOptimizations: boolean; {do loop optimizations?}
|
|
noroot: boolean; {prevent creation of .root file?}
|
|
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?}
|
|
rtl: boolean; {return with an rtl?}
|
|
saveStack: boolean; {save, restore caller's stack reg?}
|
|
smallMemoryModel: boolean; {is the small model in use?}
|
|
stackSize: integer; {amount of stack space to reserve}
|
|
strictVararg: boolean; {repair stack around vararg calls?}
|
|
stringsize: 0..maxstring; {amount of string space left}
|
|
stringspace: ^stringSpaceType; {string table}
|
|
symLength: integer; {length of debug symbol table}
|
|
toolParms: boolean; {generate tool format parameters?}
|
|
volatile: boolean; {has a volatile qualifier been used?}
|
|
hasVarargsCall: boolean; {does current function call any varargs fns?}
|
|
|
|
{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?}
|
|
openName,closeName,actionName, {names of the required procedures}
|
|
initName: stringPtr;
|
|
refreshPeriod: integer; {refresh period}
|
|
eventMask: integer; {event mask}
|
|
menuLine: pString; {name in menu bar}
|
|
|
|
{DAG construction}
|
|
{----------------}
|
|
DAGhead: icPtr; {1st ic in DAG list}
|
|
DAGblocks: blockPtr; {list of basic blocks}
|
|
|
|
{---------------------------------------------------------------}
|
|
|
|
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 InitWriteCode; {debug}
|
|
|
|
{ initialize the intermediate code opcode table }
|
|
|
|
|
|
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 Gen0Name (fop: pcodes; name: stringPtr);
|
|
|
|
{ generate a p-code with a name }
|
|
{ }
|
|
{ parameters: }
|
|
{ fop - operation code }
|
|
{ name - named label }
|
|
|
|
|
|
procedure Gen1Name (fop: pcodes; fp1: integer; name: stringPtr);
|
|
|
|
{ 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: stringPtr);
|
|
|
|
{ generate a two operand p-code with a name }
|
|
{ }
|
|
{ parameters: }
|
|
{ fop - operation code }
|
|
{ fp1 - first operand }
|
|
{ fp2 - second operand }
|
|
{ name - named label }
|
|
|
|
|
|
procedure Gen0tName (fop: pcodes; tp: baseTypeEnum; name: stringPtr);
|
|
|
|
{ generate a typed zero operand p-code with a name }
|
|
{ }
|
|
{ parameters: }
|
|
{ fop - operation code }
|
|
{ tp - base type }
|
|
{ name - named label }
|
|
|
|
|
|
procedure Gen1tName (fop: pcodes; fp1: integer; tp: baseTypeEnum;
|
|
name: stringPtr);
|
|
|
|
{ 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: stringPtr);
|
|
|
|
{ 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 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 - second operand }
|
|
{ tp - base type }
|
|
|
|
|
|
procedure GenPS (fop: pcodes; str: stringPtr);
|
|
|
|
{ generate an instruction that uses a p-string operand }
|
|
{ }
|
|
{ parameters: }
|
|
{ fop - operation code }
|
|
{ str - pointer to string }
|
|
|
|
|
|
procedure GenS (fop: pcodes; str: longstringPtr);
|
|
|
|
{ generate an instruction that uses a string operand }
|
|
{ }
|
|
{ parameters: }
|
|
{ fop - operation code }
|
|
{ str - pointer to string }
|
|
|
|
|
|
procedure GenBS (fop: pcodes; data: ptr; len: longint);
|
|
|
|
{ generate an instruction that uses a byte sequence operand }
|
|
{ }
|
|
{ parameters: }
|
|
{ fop - operation code }
|
|
{ data - pointer to data }
|
|
{ data - length of data }
|
|
|
|
|
|
procedure GenL1 (fop: pcodes; lval: longint; fp1: integer);
|
|
|
|
{ generate an instruction that uses a longint and an int }
|
|
{ }
|
|
{ parameters: }
|
|
{ lval - longint parameter }
|
|
{ fp1 - integer parameter }
|
|
|
|
|
|
procedure GenQ1 (fop: pcodes; qval: longlong; fp1: integer);
|
|
|
|
{ generate an instruction that uses a longlong and an int }
|
|
{ }
|
|
{ parameters: }
|
|
{ qval - longlong parameter }
|
|
{ fp1 - integer parameter }
|
|
|
|
|
|
procedure GenR1t (fop: pcodes; rval: extended; fp1: integer; tp: baseTypeEnum);
|
|
|
|
{ generate an instruction that uses a real and an int }
|
|
{ }
|
|
{ parameters: }
|
|
{ rval - real parameter }
|
|
{ fp1 - integer parameter }
|
|
{ tp - base type }
|
|
|
|
|
|
procedure GenLdcLong (lval: longint);
|
|
|
|
{ load a long constant }
|
|
{ }
|
|
{ parameters: }
|
|
{ lval - value to load }
|
|
|
|
|
|
procedure GenLdcQuad (qval: longlong);
|
|
|
|
{ load a long long constant }
|
|
{ }
|
|
{ parameters: }
|
|
{ qval - value to load }
|
|
|
|
|
|
procedure GenLdcReal (rval: extended);
|
|
|
|
{ load a real constant }
|
|
{ }
|
|
{ parameters: }
|
|
{ rval - value to load }
|
|
|
|
|
|
procedure GenTool (fop: pcodes; fp1, fp2: integer; dispatcher: longint);
|
|
|
|
{ generate a tool call }
|
|
{ }
|
|
{ parameters: }
|
|
{ fop - operation code }
|
|
{ fp1 - tool number }
|
|
{ fp2 - return size }
|
|
{ dispatcher - tool entry point }
|
|
|
|
|
|
{procedure PrintBlocks (tag: stringPtr; bp: blockPtr); {debug}
|
|
|
|
{ print a series of basic blocks }
|
|
{ }
|
|
{ parameters: }
|
|
{ tag - label for lines }
|
|
{ bp - first block to print }
|
|
|
|
|
|
function TypeSize (tp: baseTypeEnum): integer;
|
|
|
|
{ Find the size, in bytes, of a variable }
|
|
{ }
|
|
{ parameters: }
|
|
{ tp - base type of the variable }
|
|
|
|
|
|
{procedure WriteCode (code: icptr); {debug}
|
|
|
|
{ print an intermediate code instruction }
|
|
{ }
|
|
{ Parameters: }
|
|
{ code - intermediate code instruction to write }
|
|
|
|
|
|
procedure LimitPrecision (var rval: extended; tp: baseTypeEnum);
|
|
|
|
{ limit the precision and range of a real value to the type. }
|
|
{ }
|
|
{ parameters: }
|
|
{ rval - real value }
|
|
{ tp - type to limit precision to }
|
|
|
|
{------------------------------------------------------------------------------}
|
|
|
|
implementation
|
|
|
|
{var
|
|
opt: array[pcodes] of packed array[1..3] of char; {debug}
|
|
|
|
{Imported from CGC.pas:}
|
|
|
|
function Calloc (bytes: integer): ptr; extern;
|
|
|
|
{ Allocate memory from a pool and clear it. }
|
|
{ }
|
|
{ Parameters: }
|
|
{ bytes - number of bytes to allocate }
|
|
{ ptr - points to the first byte of the allocated memory }
|
|
{ }
|
|
{ Globals: }
|
|
{ useGlobalPool - should the memory come from the global }
|
|
{ (or local) pool }
|
|
|
|
|
|
procedure Error (err: integer); extern; {in scanner.pas}
|
|
|
|
{ flag an error }
|
|
{ }
|
|
{ err - error number }
|
|
|
|
|
|
function Malloc (bytes: integer): ptr; extern;
|
|
|
|
{ Allocate memory from a pool. }
|
|
{ }
|
|
{ Parameters: }
|
|
{ bytes - number of bytes to allocate }
|
|
{ ptr - points to the first byte of the allocated memory }
|
|
{ }
|
|
{ Globals: }
|
|
{ useGlobalPool - should the memory come from the global }
|
|
{ (or local) pool }
|
|
|
|
|
|
procedure InitLabels; extern;
|
|
|
|
{ initialize the labels array for a procedure }
|
|
|
|
|
|
{Imported from ObjOut.pas:}
|
|
|
|
procedure CloseObj; extern;
|
|
|
|
{ close the current obj file }
|
|
|
|
{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? }
|
|
|
|
|
|
{Imported from DAG.pas:}
|
|
|
|
procedure DAG (code: icptr); extern;
|
|
|
|
{ place an op code in a DAG or tree }
|
|
{ }
|
|
{ parameters: }
|
|
{ code - opcode }
|
|
|
|
{------------------------------------------------------------------------------}
|
|
|
|
|
|
{ copy 'cgi.debug'} {debug}
|
|
|
|
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? }
|
|
|
|
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 interface file}
|
|
end; {CodeGenInit}
|
|
|
|
|
|
procedure CodeGenFini;
|
|
|
|
{ terminal processing }
|
|
|
|
begin {CodeGenFini}
|
|
CloseObj; {close the open object file}
|
|
end; {CodeGenFini}
|
|
|
|
|
|
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}
|
|
strictVararg := {save/restore caller's stack around vararg}
|
|
(not cLineOptimize) or strictMode;
|
|
saveStack := not cLineOptimize; {save/restore caller's stack reg}
|
|
checkStack := false; {don't check stack for stack errors}
|
|
stackSize := 0; {default to the launcher's stack size}
|
|
toolParms := false; {generate tool format parameters?}
|
|
noroot := false; {create a .root segment}
|
|
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}
|
|
volatile := false; {no volatile qualifiers found}
|
|
|
|
registers := cLineOptimize; {don't do register optimizations}
|
|
peepHole := cLineOptimize; {not doing peephole optimization (yet)}
|
|
npeepHole := cLineOptimize;
|
|
fastMath := cLineOptimize;
|
|
commonSubexpression := cLineOptimize; {not doing common subexpression elimination}
|
|
loopOptimizations := cLineOptimize; {not doing loop optimizations, yet}
|
|
|
|
{allocate string space}
|
|
new(stringspace);
|
|
|
|
{allocate the initial p-code}
|
|
code := pointer(Calloc(sizeof(intermediate_code)));
|
|
code^.optype := cgWord;
|
|
end; {CodeGenScalarInit}
|
|
|
|
|
|
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 volatile 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
|
|
|
|
pc_lnm,pc_tl1,pc_lda,dc_loc,pc_mov: begin
|
|
lcode^.r := fp1;
|
|
lcode^.q := fp2;
|
|
end;
|
|
|
|
pc_cnn,pc_cnv:
|
|
if (fp1 = fp2)
|
|
and not (baseTypeEnum(fp2) in [cgReal,cgDouble,cgComp]) then
|
|
goto 1
|
|
else if (baseTypeEnum(fp1) in [cgReal,cgDouble,cgComp,cgExtended])
|
|
and (baseTypeEnum(fp2) = 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 [cgUByte])
|
|
and (baseTypeEnum(fp2) in [cgByte,cgUByte]) then
|
|
goto 1
|
|
else if (baseTypeEnum(fp1) = cgByte)
|
|
and (baseTypeEnum(fp2) = cgUByte) then
|
|
lcode^.q := (ord(cgWord) << 4) | ord(cgUByte)
|
|
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;
|
|
lcode^.s := fp1;
|
|
lcode^.q := fp2;
|
|
lcode^.r := fp3;
|
|
Gen0(fop);
|
|
end; {if}
|
|
end; {Gen3}
|
|
|
|
|
|
procedure Gen0Name {fop: pcodes; name: stringPtr};
|
|
|
|
{ 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: stringPtr};
|
|
|
|
{ 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: stringPtr};
|
|
|
|
{ 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 Gen0tName {fop: pcodes; tp: baseTypeEnum; name: stringPtr};
|
|
|
|
{ generate a typed zero operand p-code with a name }
|
|
{ }
|
|
{ parameters: }
|
|
{ fop - operation code }
|
|
{ tp - base type }
|
|
{ name - named label }
|
|
|
|
var
|
|
lcode: icptr; {local copy of code}
|
|
|
|
begin {Gen0tName}
|
|
if codeGeneration then begin
|
|
lcode := code;
|
|
lcode^.lab := name;
|
|
lcode^.optype := tp;
|
|
Gen0(fop);
|
|
end; {if}
|
|
end; {Gen0tName}
|
|
|
|
|
|
procedure Gen1tName {fop: pcodes; fp1: integer; tp: baseTypeEnum;
|
|
name: stringPtr};
|
|
|
|
{ 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: stringPtr};
|
|
|
|
{ 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 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 one numeric operand }
|
|
{ }
|
|
{ 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 - second operand }
|
|
{ tp - base type }
|
|
|
|
var
|
|
lcode: icptr; {local copy of code}
|
|
|
|
begin {Gen3t}
|
|
if codeGeneration then begin
|
|
lcode := code;
|
|
lcode^.optype := tp;
|
|
lcode^.s := fp1;
|
|
lcode^.q := fp2;
|
|
lcode^.r := fp3;
|
|
Gen0(fop);
|
|
end; {if}
|
|
end; {Gen3t}
|
|
|
|
|
|
procedure GenPS {fop: pcodes; str: stringPtr};
|
|
|
|
{ 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^.optype := cgString;
|
|
lcode^.q := length(str^);
|
|
lcode^.str := pointer(ord4(str)-1);
|
|
Gen0(fop);
|
|
end; {if}
|
|
end; {GenPS}
|
|
|
|
|
|
procedure GenS {fop: pcodes; str: longstringPtr};
|
|
|
|
{ generate an instruction that uses a string operand }
|
|
{ }
|
|
{ parameters: }
|
|
{ fop - operation code }
|
|
{ str - pointer to string }
|
|
|
|
var
|
|
lcode: icptr; {local copy of code}
|
|
|
|
begin {GenS}
|
|
if codeGeneration then begin
|
|
lcode := code;
|
|
lcode^.optype := cgString;
|
|
lcode^.q := str^.length;
|
|
lcode^.str := str;
|
|
Gen0(fop);
|
|
end; {if}
|
|
end; {GenS}
|
|
|
|
|
|
procedure GenBS {fop: pcodes; data: ptr; len: longint};
|
|
|
|
{ generate an instruction that uses a byte sequence operand }
|
|
{ }
|
|
{ parameters: }
|
|
{ fop - operation code }
|
|
{ data - pointer to data }
|
|
{ len - length of data }
|
|
|
|
var
|
|
lcode: icptr; {local copy of code}
|
|
|
|
begin {GenBS}
|
|
if codeGeneration then begin
|
|
lcode := code;
|
|
lcode^.optype := cgString;
|
|
lcode^.isByteSeq := true;
|
|
lcode^.data := data;
|
|
lcode^.len := len;
|
|
Gen0(fop);
|
|
end; {if}
|
|
end; {GenBS}
|
|
|
|
|
|
procedure GenL1 {fop: pcodes; lval: longint; fp1: integer};
|
|
|
|
{ generate an instruction that uses a longint and an int }
|
|
{ }
|
|
{ parameters: }
|
|
{ lval - longint parameter }
|
|
{ fp1 - integer parameter }
|
|
|
|
var
|
|
lcode: icptr; {local copy of code}
|
|
|
|
begin {GenL1}
|
|
if codeGeneration then begin
|
|
lcode := code;
|
|
lcode^.optype := cgLong;
|
|
lcode^.lval := lval;
|
|
lcode^.q := fp1;
|
|
Gen0(fop);
|
|
end; {if}
|
|
end; {GenL1}
|
|
|
|
|
|
procedure GenQ1 {fop: pcodes; qval: longlong; fp1: integer};
|
|
|
|
{ generate an instruction that uses a longlong and an int }
|
|
{ }
|
|
{ parameters: }
|
|
{ qval - longlong parameter }
|
|
{ fp1 - integer parameter }
|
|
|
|
var
|
|
lcode: icptr; {local copy of code}
|
|
|
|
begin {GenQ1}
|
|
if codeGeneration then begin
|
|
lcode := code;
|
|
lcode^.optype := cgQuad;
|
|
lcode^.qval := qval;
|
|
lcode^.q := fp1;
|
|
Gen0(fop);
|
|
end; {if}
|
|
end; {GenQ1}
|
|
|
|
|
|
procedure GenR1t {fop: pcodes; rval: extended; fp1: integer; tp: baseTypeEnum};
|
|
|
|
{ generate an instruction that uses a real and an int }
|
|
{ }
|
|
{ parameters: }
|
|
{ rval - real parameter }
|
|
{ fp1 - integer parameter }
|
|
{ tp - base type }
|
|
|
|
var
|
|
lcode: icptr; {local copy of code}
|
|
|
|
begin {GenR1t}
|
|
if codeGeneration then begin
|
|
lcode := code;
|
|
lcode^.optype := tp;
|
|
lcode^.rval := rval;
|
|
lcode^.q := fp1;
|
|
Gen0(fop);
|
|
end; {if}
|
|
end; {GenR1t}
|
|
|
|
|
|
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;
|
|
lcode^.optype := cgLong;
|
|
lcode^.lval := lval;
|
|
Gen0(pc_ldc);
|
|
end; {if}
|
|
end; {GenLdcLong}
|
|
|
|
|
|
procedure GenLdcQuad {qval: longlong};
|
|
|
|
{ load a long long constant }
|
|
{ }
|
|
{ parameters: }
|
|
{ qval - value to load }
|
|
|
|
var
|
|
lcode: icptr; {local copy of code}
|
|
|
|
begin {GenLdcQuad}
|
|
if codeGeneration then begin
|
|
lcode := code;
|
|
lcode^.optype := cgQuad;
|
|
lcode^.qval := qval;
|
|
Gen0(pc_ldc);
|
|
end; {if}
|
|
end; {GenLdcQuad}
|
|
|
|
|
|
procedure GenTool {fop: pcodes; fp1, fp2: integer; dispatcher: longint};
|
|
|
|
{ generate a tool call }
|
|
{ }
|
|
{ parameters: }
|
|
{ fop - operation code }
|
|
{ fp1 - tool number }
|
|
{ fp2 - return size }
|
|
{ dispatcher - tool entry point }
|
|
|
|
var
|
|
lcode: icptr; {local copy of code}
|
|
|
|
begin {GenTool}
|
|
if codeGeneration then begin
|
|
lcode := code;
|
|
lcode^.q := fp1;
|
|
lcode^.r := fp2;
|
|
lcode^.optype := cgLong;
|
|
lcode^.lval := dispatcher;
|
|
Gen0(fop);
|
|
end; {if}
|
|
end; {GenTool}
|
|
|
|
|
|
procedure GenLdcReal {rval: extended};
|
|
|
|
{ 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}
|
|
|
|
|
|
function TypeSize {tp: baseTypeEnum): integer};
|
|
|
|
{ Find the size, in bytes, of a variable }
|
|
{ }
|
|
{ parameters: }
|
|
{ tp - base type of the variable }
|
|
|
|
begin {TypeSize}
|
|
case tp of
|
|
cgByte,cgUByte: TypeSize := cgByteSize;
|
|
cgWord,cgUWord: TypeSize := cgWordSize;
|
|
cgLong,cgULong: TypeSize := cgLongSize;
|
|
cgQuad,cgUQuad: TypeSize := cgQuadSize;
|
|
cgReal: TypeSize := cgRealSize;
|
|
cgDouble: TypeSize := cgDoubleSize;
|
|
cgComp: TypeSize := cgCompSize;
|
|
cgExtended: TypeSize := cgExtendedSize;
|
|
cgString: TypeSize := cgByteSize;
|
|
cgVoid,ccPointer: TypeSize := cgLongSize;
|
|
end; {case}
|
|
end; {TypeSize}
|
|
|
|
|
|
procedure LimitPrecision {rval: var extended; tp: baseTypeEnum};
|
|
|
|
{ limit the precision and range of a real value to the type. }
|
|
{ }
|
|
{ parameters: }
|
|
{ rval - real value }
|
|
{ tp - type to limit precision to }
|
|
|
|
var
|
|
d: double;
|
|
s: real;
|
|
c: comp;
|
|
|
|
begin {LimitPrecision}
|
|
case tp of
|
|
cgReal: begin
|
|
s := rval;
|
|
rval := s;
|
|
end;
|
|
cgDouble: begin
|
|
d := rval;
|
|
rval := d;
|
|
end;
|
|
cgComp: if rval < 0.0 then begin
|
|
{work around SANE comp conversion bug}
|
|
c := -rval;
|
|
rval := -c;
|
|
end {if}
|
|
else begin
|
|
c := rval;
|
|
rval := c;
|
|
end; {else}
|
|
cgExtended: ;
|
|
end; {case}
|
|
end; {LimitPrecision}
|
|
|
|
end.
|