mirror of
https://github.com/byteworksinc/ORCA-C.git
synced 2024-12-21 16:29:31 +00:00
9b31e7f72a
This converts comparisons like x > N (with constant N) to instead be evaluated as x >= N+1, since >= comparisons generate better code. This is possible as long as N is not the maximum value in the type, but in that case the comparison is always false. There are also a few other tweaks to the generated code in some cases.
1437 lines
52 KiB
ObjectPascal
1437 lines
52 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 left 8 bits}
|
|
shift16 = 2; {shift operand left 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}
|
|
|
|
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_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;
|
|
|
|
max_opcode = 263;
|
|
|
|
{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);
|
|
|
|
{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 : (str: longStringPtr);
|
|
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 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 := not cLineOptimize; {save/restore caller's stack around vararg}
|
|
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 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.
|