diff --git a/CCommon.pas b/CCommon.pas index 5eb8990..e587ccd 100644 --- a/CCommon.pas +++ b/CCommon.pas @@ -114,6 +114,7 @@ type {Misc.} {-----} long = record lsw,msw: integer; end; {for extracting words from longints} + longlong = record lo,hi: longint; end; {64-bit integer representation} cString = packed array [1..256] of char; {null terminated string} cStringPtr = ^cString; @@ -148,7 +149,7 @@ type baseTypeEnum = (cgByte,cgUByte,cgWord,cgUWord,cgLong,cgULong, cgReal,cgDouble,cgComp,cgExtended,cgString, - cgVoid,ccPointer); + cgVoid,cgQuad,cgUQuad,ccPointer); { Basic types (plus the void type) as defined by the C language. } { This differs from baseTypeEnum in that different types with the } @@ -157,7 +158,7 @@ type cTypeEnum = (ctChar, ctSChar, ctUChar, ctShort, ctUShort, ctInt, ctUInt, ctLong, ctULong, ctFloat, ctDouble, ctLongDouble, ctComp, - ctVoid, ctInt32, ctUInt32, ctBool); + ctVoid, ctInt32, ctUInt32, ctBool, ctLongLong, ctULongLong); {tokens} {------} @@ -166,7 +167,8 @@ type tokenEnum = ( {enumeration of the tokens} ident, {identifiers} {constants} - intconst,uintconst,longconst,ulongconst,doubleconst, + intconst,uintconst,longconst,ulongconst,longlongconst, + ulonglongconst,doubleconst, stringconst, {reserved words} _Alignassy,_Alignofsy,_Atomicsy,_Boolsy,_Complexsy, @@ -207,7 +209,7 @@ type tokenSet = set of tokenEnum; tokenClass = (reservedWord,reservedSymbol,identifier,intConstant,longConstant, - doubleConstant,stringConstant,macroParameter); + longlongConstant,doubleConstant,stringConstant,macroParameter); identPtr = ^identRecord; {^ to a symbol table entry} tokenType = record {a token} kind: tokenEnum; {kind of token} @@ -219,6 +221,7 @@ type symbolPtr: identPtr); intConstant : (ival: integer); longConstant : (lval: longint); + longlongConstant: (qval: longlong); doubleConstant: (rval: double); stringConstant: (sval: longstringPtr; ispstring: boolean); @@ -308,7 +311,7 @@ type isStructOrUnion: boolean; {is this a struct or union initializer?} case isConstant: boolean of {is this a constant initializer?} false: (iTree: tokenPtr); - true : ( + true : ( {Note: qVal.lo must overlap iVal} case itype: baseTypeEnum of cgByte, cgUByte, @@ -316,6 +319,8 @@ type cgUWord, cgLong, cgULong : (iVal: longint); + cgQuad, + cgUQuad : (qVal: longlong); cgString : (sVal: longstringPtr); cgReal, cgDouble, @@ -479,15 +484,19 @@ var partialFileGS: gsosOutString; {partial compile list} sourceFileGS: gsosOutString; {debug source file name} tempList: tempPtr; {list of temp work variables} + longlong0: longlong; {the value 0 as a longlong} + longlong1: longlong; {the value 1 as a longlong} {expression results} {------------------} doDispose: boolean; {dispose of the expression tree as we go?} realExpressionValue: double; {value of the last real constant expression} + llExpressionValue: longlong; {value of the last long long constant expression} expressionValue: longint; {value of the last constant expression} expressionType: typePtr; {the type of the expression} initializerTree: tokenPtr; {for non-constant initializers} isConstant: boolean; {is the initializer expression constant?} + expressionIsLongLong: boolean; {is the last constant expression long long?} {type specifier results} {----------------------} @@ -845,6 +854,10 @@ spinner[0] := '|'; {set up the spinner characters} spinner[1] := '/'; spinner[2] := '-'; spinner[3] := '\'; +longlong0.hi := 0; +longlong0.lo := 0; +longlong1.hi := 0; +longlong1.lo := 1; end; {InitCCommon} diff --git a/CGC.asm b/CGC.asm index 86bfd11..4b9867f 100644 --- a/CGC.asm +++ b/CGC.asm @@ -85,6 +85,128 @@ rec_cmp equ 18 disp to comp (SANE) value rtl end +**************************************************************** +* +* procedure CnvXLL (var result: longlong; val: extended); +* +* Convert floating point to long long +* +* Inputs: +* result - longlong to hold the converted value +* val - the real value +* +**************************************************************** + +CnvXLL start cg + + subroutine (4:result,10:val),0 + + pei (val+8) + pei (val+6) + pei (val+4) + pei (val+2) + pei (val) + jsl ~CnvRealLongLong + pl8 [result] + + return + end + +**************************************************************** +* +* procedure CnvXULL (var result: longlong; val: extended); +* +* Convert floating point to unsigned long long +* +* Inputs: +* result - longlong to hold the converted value +* val - the real value +* +**************************************************************** + +CnvXULL start cg + + subroutine (4:result,10:val),0 + + pei (val+8) + pei (val+6) + pei (val+4) + pei (val+2) + pei (val) + jsl ~CnvRealULongLong + pl8 [result] + + return + end + +**************************************************************** +* +* function CnvLLX (val: longlong): extended; +* +* convert a long long to a real number +* +* Inputs: +* val - the long long value +* +**************************************************************** + +CnvLLX start cg + + subroutine (4:val),0 + + ph8 [val] + jsl ~CnvLongLongReal + pla + sta >rval + pla + sta >rval+2 + pla + sta >rval+4 + pla + sta >rval+6 + pla + sta >rval+8 + + lla val,rval + return 4:val + +rval ds 10 + end + +**************************************************************** +* +* function CnvULLX (val: longlong): extended; +* +* convert an unsigned long long to a real number +* +* Inputs: +* val - the unsigned long long value +* +**************************************************************** + +CnvULLX start cg + + subroutine (4:val),0 + + ph8 [val] + jsl ~CnvULongLongReal + pla + sta >rval + pla + sta >rval+2 + pla + sta >rval+4 + pla + sta >rval+6 + pla + sta >rval+8 + + lla val,rval + return 4:val + +rval ds 10 + end + datachk off **************************************************************** * diff --git a/CGC.macros b/CGC.macros index 2a32ccc..4613e41 100644 --- a/CGC.macros +++ b/CGC.macros @@ -186,3 +186,252 @@ LDX #$090A JSL $E10000 MEND + macro +&l pl8 &n1 + lclc &c +&l anop + aif s:longa=1,.a + rep #%00100000 +.a +&c amid &n1,1,1 + aif "&c"<>"{",.b +&c amid &n1,l:&n1,1 + aif "&c"<>"}",.f +&n1 amid &n1,2,l:&n1-2 + pla + sta (&n1) + ldy #2 + pla + sta (&n1),y + ldy #4 + pla + sta (&n1),y + ldy #6 + pla + sta (&n1),y + ago .d +.b + aif "&c"<>"[",.c + pla + sta &n1 + ldy #2 + pla + sta &n1,y + ldy #4 + pla + sta &n1,y + ldy #6 + pla + sta &n1,y + ago .d +.c + pla + sta &n1 + pla + sta &n1+2 + pla + sta &n1+4 + pla + sta &n1+6 +.d + aif s:longa=1,.e + sep #%00100000 +.e + mexit +.f + mnote "Missing closing '}'",16 + mend + MACRO +&lab subroutine &parms,&work +&lab anop + aif c:&work,.a + lclc &work +&work setc 0 +.a + gbla &totallen + gbla &worklen +&worklen seta &work +&totallen seta 0 + aif c:&parms=0,.e + lclc &len + lclc &p + lcla &i +&i seta c:&parms +.b +&p setc &parms(&i) +&len amid &p,2,1 + aif "&len"=":",.c +&len amid &p,1,2 +&p amid &p,4,l:&p-3 + ago .d +.c +&len amid &p,1,1 +&p amid &p,3,l:&p-2 +.d +&p equ &totallen+3+&work +&totallen seta &totallen+&len +&i seta &i-1 + aif &i,^b +.e + tsc + sec + sbc #&work + tcs + inc a + phd + tcd + mend + MACRO +&lab return &r +&lab anop + lclc &len + aif c:&r,.a + lclc &r +&r setc 0 +&len setc 0 + ago .h +.a +&len amid &r,2,1 + aif "&len"=":",.b +&len amid &r,1,2 +&r amid &r,4,l:&r-3 + ago .c +.b +&len amid &r,1,1 +&r amid &r,3,l:&r-2 +.c + aif &len<>2,.d + ldy &r + ago .h +.d + aif &len<>4,.e + ldx &r+2 + ldy &r + ago .h +.e + aif &len<>10,.g + aif &totallen=0,.f + lda &worklen+1 + sta &worklen+&totallen+1 + lda &worklen + sta &worklen+&totallen +.f + pld + tsc + clc + adc #&worklen+&totallen + tcs + phb + plx + ply + lda &r+8 + pha + lda &r+6 + pha + lda &r+4 + pha + lda &r+2 + pha + lda &r + pha + phy + phx + plb + rtl + mexit +.g + mnote 'Not a valid return length',16 + mexit +.h + aif &totallen=0,.i + lda &worklen+1 + sta &worklen+&totallen+1 + lda &worklen + sta &worklen+&totallen +.i + pld + tsc + clc + adc #&worklen+&totallen + tcs + aif &len=0,.j + tya +.j + rtl + mend + macro +&l lla &ad1,&ad2 +&l anop + lcla &lb + lclb &la + aif s:longa,.a + rep #%00100000 + longa on +&la setb 1 +.a + lda #&ad2 +&lb seta c:&ad1 +.b + sta &ad1(&lb) +&lb seta &lb-1 + aif &lb,^b + lda #^&ad2 +&lb seta c:&ad1 +.c + sta 2+&ad1(&lb) +&lb seta &lb-1 + aif &lb,^c + aif &la=0,.d + sep #%00100000 + longa off +.d + mend + macro +&l ph8 &n1 + lclc &c +&l anop +&c amid &n1,1,1 + aif s:longa=1,.a + rep #%00100000 +.a + aif "&c"="#",.d + aif "&c"="[",.b + aif "&c"<>"{",.c +&c amid &n1,l:&n1,1 + aif "&c"<>"}",.g +&n1 amid &n1,2,l:&n1-2 +&n1 setc (&n1) +.b + ldy #6 +~&SYSCNT lda &n1,y + pha + dey + dey + bpl ~&SYSCNT + ago .e +.c + ldx #6 +~&SYSCNT lda &n1,x + pha + dex + dex + bpl ~&SYSCNT + ago .e +.d +&n1 amid &n1,2,l:&n1-1 + bra ~b&SYSCNT +~a&SYSCNT dc i8"&n1" +~b&SYSCNT ldx #6 +~c&SYSCNT lda ~a&SYSCNT,x + pha + dex + dex + bpl ~c&SYSCNT +.e + aif s:longa=1,.f + sep #%00100000 +.f + mexit +.g + mnote "Missing closing '}'",16 + mend diff --git a/CGC.pas b/CGC.pas index cd0a2e8..348e1ff 100644 --- a/CGC.pas +++ b/CGC.pas @@ -67,6 +67,40 @@ procedure CnvSX (rec: realrec); extern; { has space for the result } +procedure CnvXLL (var result: longlong; val: extended); extern; + +{ convert a real number to long long } +{ } +{ parameters: } +{ result - longlong to hold the converted value } +{ val - the real value } + + +procedure CnvXULL (var result: longlong; val: extended); extern; + +{ convert a real number to unsigned long long } +{ } +{ parameters: } +{ result - longlong to hold the converted value } +{ val - the real value } + + +function CnvLLX (val: longlong): extended; extern; + +{ convert a long long to a real number } +{ } +{ parameters: } +{ val - the long long value } + + +function CnvULLX (val: longlong): extended; extern; + +{ convert an unsigned long long to a real number } +{ } +{ parameters: } +{ val - the unsigned long long value } + + procedure InitLabels; extern; { initialize the labels array for a procedure } diff --git a/CGI.Comments b/CGI.Comments index 7bf4290..7142d91 100644 --- a/CGI.Comments +++ b/CGI.Comments @@ -3,13 +3,14 @@ { dc_cns - generate a constant value } { } { GenL1(dc_cns, lval, count); } +{ GenQ1(dc_cns, qval, count); } { GenR1t(dc_cns, rval, count, type); } { Gen2t(dc_cns, ival, count, type); } { GenS(dc_cns, sptr); } { } -{ Creates COUNT occurrences of the constant lval, rval or } -{ ival, based on the type. In Gen2t can accept byte or word } -{ types. In the case of GenS, the operand is a string } +{ Creates COUNT occurrences of the constant lval, qval, rval } +{ or ival, based on the type. In Gen2t can accept byte or } +{ word types. In the case of GenS, the operand is a string } { constant, and no repeat count is allowed. } { } { } @@ -90,10 +91,12 @@ { } { pc_adi - integer addition } { pc_adl - long addition } +{ pc_adq - long long addition } { pc_adr - real addition } { } { Gen0(pc_adi) cgByte,cgUByte,cgWord,cgUWord } { Gen0(pc_adl) cgLong,cgULong } +{ Gen0(pc_adq) cgQuad,cgUQuad } { Gen0(pc_adr) cgReal,cgDouble,cgComp,cgExtended } { } { The two values on the top of the evaluation stack are } @@ -117,9 +120,11 @@ { } { pc_bnd - bitwise and } { pc_bal - long bitwise and } +{ pc_baq - long long bitwise and } { } { Gen0(pc_bnd) cgByte,cgUByte,cgWord,cgUWord } { Gen0(pc_bal) cgLong,cgULong } +{ Gen0(pc_baq) cgQuad,cgUQuad } { } { The two values on the top of the evaluation stack are } { removed and anded. The result is placed back on the stack. } @@ -140,9 +145,11 @@ { } { pc_bnt - bitwise negation } { pc_bnl - long bitwise negation } +{ pc_bnq - long long bitwise negation } { } { Gen0(pc_bnt) cgByte,cgUByte,cgWord,cgUWord } { Gen0(pc_bnl) cgLong,cgULong } +{ Gen0(pc_bnq) cgQuad,cgUQuad } { } { The value on the top of the evaluation stack is removed, } { exclusive ored with $FFFF, and replaced. (One's compliment.)} @@ -150,9 +157,11 @@ { } { pc_bor - bitwise or } { pc_blr - long bitwise or } +{ pc_bqr - long long bitwise or } { } { Gen0(pc_bor) cgByte,cgUByte,cgWord,cgUWord } { Gen0(pc_blr) cgLong,cgULong } +{ Gen0(pc_bqr) cgQuad,cgUQuad } { } { The two values on the top of the evaluation stack are } { removed and ored. The result is placed back on the stack. } @@ -160,9 +169,11 @@ { } { pc_bxr - exclusive or } { pc_blx - long exclusive or } +{ pc_bqx - long long exclusive or } { } { Gen0(pc_bxr) cgByte,cgUByte,cgWord,cgUWord } { Gen0(pc_blx) cgLong,cgULong } +{ Gen0(pc_bqx) cgQuad,cgUQuad } { } { The two values on the top of the evaluation stack are } { removed and exclusive ored. The result is placed back on } @@ -264,12 +275,16 @@ { pc_udi - unsigned integer divide } { pc_dvl - long integer divide } { pc_udl - unsigned long divide } +{ pc_dvq - long long integer divide } +{ pc_udq - unsigned long long divide } { pc_dvr - real divide } { } { Gen0(pc_dvi) cgByte,cgWord } { Gen0(pc_udi) cgUByte,cgUWord } { Gen0(pc_dvl) cgLong } { Gen0(pc_udl) cgULong } +{ Gen0(pc_dvq) cgQuad } +{ Gen0(pc_udq) cgUQuad } { Gen0(pc_dvr) cgReal,cgDouble,cgComp,cgExtended } { } { The two values on the top of the evaluation stack are } @@ -406,9 +421,10 @@ { } { Gen1t(pc_ldc, val, type) } { GenLdcLong(val) } +{ GenLdcQuad(val) } { GenLdcReal(val) } { } -{ Loads a constant value. Special calls for long and real } +{ Loads a constant value. Special calls for long, quad & real } { values are provided due to the unique parameter requirements.} { } { } @@ -453,11 +469,15 @@ { pc_uim - unsigned integer modulus/remainder } { pc_mdl - long remainder } { pc_ulm - unsigned long modulus/remainder } +{ pc_mdq - long long remainder } +{ pc_uqm - unsigned long long modulus/remainder } { } { Gen0(pc_mod) cgByte,cgWord } { Gen0(pc_uim) cgUByte,cgUWord } { Gen0(pc_mdl) cgLong } { Gen0(pc_ulm) cgULong } +{ Gen0(pc_mdq) cgQuad } +{ Gen0(pc_uqm) cgUQuad } { } { The two values on the top of the evaluation stack are } { removed and the remainder after division is calculated. } @@ -469,12 +489,16 @@ { pc_umi - unsigned integer multiply } { pc_mpl - long integer multiply } { pc_uml - unsigned long multiply } +{ pc_mpq - long long integer multiply } +{ pc_umq - unsigned long long multiply } { pc_mpr - real multiply } { } { Gen0(pc_mpi) cgByte,cgWord } { Gen0(pc_umi) cgUByte,cgUWord } { Gen0(pc_mpl) cgLong } { Gen0(pc_uml) cgULong } +{ Gen0(pc_mpq) cgQuad } +{ Gen0(pc_umq) cgUQuad } { Gen0(pc_mpr) cgReal,cgDouble,cgComp,cgExtended } { } { The two values on the top of the evaluation stack are } @@ -484,10 +508,12 @@ { } { pc_ngi - integer negation } { pc_ngl - long negation } +{ pc_ngq - long long negation } { pc_ngr - real negation } { } { Gen0(pc_ngi) cgByte,cgUByte,cgWord,cgUWord } { Gen0(pc_ngl) cgLong,cgULong } +{ Gen0(pc_ngq) cgQuad,cgUQuad } { Gen0(pc_ngr) cgReal,cgDouble,cgComp,cgExtended } { } { The value on the top of the evaluation stack is removed, } @@ -537,10 +563,12 @@ { } { pc_sbi - integer subtraction } { pc_sbl - long subtraction } +{ pc_sbq - long long subtraction } { pc_sbr - real subtraction } { } { Gen0(pc_sbi) cgByte,cgUByte,cgWord,cgUWord } { Gen0(pc_sbl) cgLong,cgULong } +{ Gen0(pc_sbq) cgQuad,cgUQuad } { Gen0(pc_sbr) cgReal,cgDouble,cgComp,cgExtended } { } { The two values on the top of the evaluation stack are } @@ -549,25 +577,32 @@ { } { pc_shl - shift left } { pc_sll - shift left long } +{ pc_slq - shift left long long } { } { Gen0(pc_shl) cgByte,cgUByte,cgWord,cgUWord } { Gen0(pc_sll) cgLong,cgULong } +{ Gen0(pc_slq) cgQuad,cgUQuad (tos-1) / cgWord (tos) } { } { The value at tos-1 is shifted left by the number of bits } { specified by tos. The result is an integer, which replaces } { the operands on the stack. The right bit positions are } -{ filled with zeros. } +{ filled with zeros. For pc_slq, only the value at tos-1 is } +{ cgQuad/cgUQuad; the shift count at tos is cgWord or cgUWord. } { } { } { pc_shr - shift right } { pc_usr - unsigned shift right } { pc_slr - long shift right } { pc_vsr - unsigned long shift right } +{ pc_sqr - long long shift right } +{ pc_wsr - unsigned long long shift right } { } { Gen0(pc_shr) cgByte,cgWord } { Gen0(pc_usr) cgUByte,cgUWord } { Gen0(pc_slr) cgLong } { Gen0(pc_vsr) cgULong } +{ Gen0(pc_sqr) cgQuad (tos-1) / cgWord (tos) } +{ Gen0(pc_wsr) cgUQuad (tos-1) / cgWord (tos) } { } { The value at tos-1 is shifted right by the number of bits } { specified by tos. The result is an integer, which replaces } @@ -577,7 +612,9 @@ { } { Pc_usr is the unsigned form. The operation is the same, } { except that the leftmost bit is replaced with a zero. } -{ Pc_vsr is used for unsigned long operations. } +{ Pc_vsr is used for unsigned long operations, and pc_wsr is } +{ used for unsigned long long operations. } +{ } { } { pc_stk - stack an operand } { } diff --git a/CGI.Debug b/CGI.Debug index 82fcc08..fc52fe6 100644 --- a/CGI.Debug +++ b/CGI.Debug @@ -116,6 +116,17 @@ opt[dc_prm] := 'PRM'; opt[pc_nat] := 'nat'; opt[pc_bno] := 'bno'; opt[pc_nop] := 'nop'; +opt[pc_bqr] := 'bqr'; +opt[pc_bqx] := 'bqx'; +opt[pc_baq] := 'baq'; +opt[pc_bnq] := 'bnq'; +opt[pc_ngq] := 'ngq'; +opt[pc_mpq] := 'mpq'; +opt[pc_umq] := 'umq'; +opt[pc_dvq] := 'dvq'; +opt[pc_udq] := 'udq'; +opt[pc_mdq] := 'mdq'; +opt[pc_uqm] := 'uqm'; end; {InitWriteCode} @@ -239,6 +250,8 @@ var cgUWord: write('u'); cgLong: write('l'); cgULong: write('ul'); + cgQuad: write('q'); + cgUQuad: write('uq'); cgReal: write('r'); cgDouble: write('d'); cgComp: write('c'); @@ -259,7 +272,7 @@ with code^ do pc_uml,pc_adr,pc_dvr,pc_mpr,pc_adi,pc_sbi,pc_mpi,pc_dvi, pc_umi,pc_shl,pc_nop,pc_and,pc_lnd,pc_bnd,pc_lor,pc_ior,pc_bxr, pc_bnt,pc_blx,pc_bnl,pc_ngi,pc_ngl,pc_ngr,pc_ixa,pc_mdl, - pc_udi,pc_udl: ; + pc_udi,pc_udl,pc_bqr,pc_bqx,pc_baq: ; dc_prm: write(' ', q:1, ':', r:1, ':', s:1); @@ -331,6 +344,8 @@ with code^ do write(r:1); cgLong,cgULong: write(lval:1); + cgQuad,cgUQuad: + write('***'); cgReal,cgDouble,cgComp,cgExtended: write('***'); cgString: begin diff --git a/CGI.pas b/CGI.pas index 3a4b295..0046898 100644 --- a/CGI.pas +++ b/CGI.pas @@ -11,7 +11,7 @@ { passed on to the code generator for optimization and } { native code generation. } { } -{$copy 'cgi.comments'} +{ copy 'cgi.comments'} {---------------------------------------------------------------} unit CodeGeneratorInterface; @@ -49,10 +49,12 @@ const m_adc_dir = $65; m_adc_imm = $69; m_adc_s = $63; + m_adc_indl = $67; m_and_abs = $2D; m_and_dir = $25; m_and_imm = $29; m_and_s = $23; + m_and_indl = $27; m_asl_a = $0A; m_bcc = $90; m_bcs = $B0; @@ -71,6 +73,7 @@ const m_cmp_imm = $C9; m_cmp_long = $CF; m_cmp_s = $C3; + m_cmp_indl = $C7; m_cop = $02; m_cpx_abs = 236; m_cpx_dir = 228; @@ -86,6 +89,7 @@ const m_eor_dir = 69; m_eor_imm = 73; m_eor_s = 67; + m_eor_indl = $47; m_ina = 26; m_inc_abs = 238; m_inc_absX = $FE; @@ -122,6 +126,7 @@ const m_ora_long = 15; m_ora_longX = 31; m_ora_s = 3; + m_ora_indl = $07; m_pea = 244; m_pei_dir = 212; m_pha = 72; @@ -143,6 +148,7 @@ const m_sbc_dir = 229; m_sbc_imm = 233; m_sbc_s = 227; + m_sbc_indl = $E7; m_sec = 56; m_sep = 226; m_sta_abs = 141; @@ -204,6 +210,7 @@ const cgByteSize = 1; cgWordSize = 2; cgLongSize = 4; + cgQuadSize = 8; cgPointerSize = 4; cgRealSize = 4; cgDoubleSize = 8; @@ -227,7 +234,9 @@ type 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); + 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); {intermediate code} {-----------------} @@ -246,6 +255,8 @@ type cgUWord : (opnd: longint; llab,slab: integer); cgLong, cgULong : (lval: longint); + cgQuad, + cgUQuad : (qval: longlong); cgReal, cgDouble, cgComp, @@ -553,6 +564,15 @@ procedure GenL1 (fop: pcodes; lval: longint; fp1: integer); { 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: double; fp1: integer; tp: baseTypeEnum); { generate an instruction that uses a real and an int } @@ -571,6 +591,14 @@ procedure GenLdcLong (lval: longint); { lval - value to load } +procedure GenLdcQuad (qval: longlong); + +{ load a long long constant } +{ } +{ parameters: } +{ qval - value to load } + + procedure GenLdcReal (rval: double); { load a real constant } @@ -1191,6 +1219,28 @@ if codeGeneration then begin 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: double; fp1: integer; tp: baseTypeEnum}; { generate an instruction that uses a real and an int } @@ -1234,6 +1284,26 @@ if codeGeneration then begin 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 } @@ -1291,6 +1361,7 @@ 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; diff --git a/DAG.pas b/DAG.pas index ed27638..49e87ee 100644 --- a/DAG.pas +++ b/DAG.pas @@ -11,7 +11,7 @@ unit DAG; interface -{$segment 'CG'} +{$segment 'DAG'} {$LibPrefix '0/obj/'} @@ -49,6 +49,31 @@ function umod (x,y: longint): longint; extern; function umul (x,y: longint): longint; extern; +function lshr (x,y: longint): longint; extern; + +{-- External 64-bit math routines; imported from Expression.pas --} +{ Procedures for arithmetic and shifts compute "x := x OP y". } + +procedure umul64 (var x: longlong; y: longlong); extern; + +procedure udiv64 (var x: longlong; y: longlong); extern; + +procedure div64 (var x: longlong; y: longlong); extern; + +procedure umod64 (var x: longlong; y: longlong); extern; + +procedure rem64 (var x: longlong; y: longlong); extern; + +procedure add64 (var x: longlong; y: longlong); extern; + +procedure sub64 (var x: longlong; y: longlong); extern; + +procedure shl64 (var x: longlong; y: integer); extern; + +procedure ashr64 (var x: longlong; y: integer); extern; + +procedure lshr64 (var x: longlong; y: integer); extern; + {---------------------------------------------------------------} function CodesMatch (op1, op2: icptr; exact: boolean): boolean; @@ -110,7 +135,8 @@ function CodesMatch (op1, op2: icptr; exact: boolean): boolean; pc_adi, pc_adl, pc_adr, pc_and, pc_lnd, pc_bnd, pc_bal, pc_bor, pc_blr, pc_bxr, pc_blx, pc_equ, pc_neq, pc_ior, pc_lor, pc_mpi, - pc_umi, pc_mpl, pc_uml, pc_mpr: begin + pc_umi, pc_mpl, pc_uml, pc_mpr, pc_bqr, pc_bqx, pc_baq, pc_adq, + pc_mpq, pc_umq: begin if op1^.left = op2^.left then if op1^.right = op2^.right then result := true; @@ -166,6 +192,10 @@ else if (op1 <> nil) and (op2 <> nil) then cgLong, cgULong: if op1^.lval = op2^.lval then CodesMatch := true; + cgQuad, cgUQuad: + if op1^.qval.lo = op2^.qval.lo then + if op1^.qval.hi = op2^.qval.hi then + CodesMatch := true; cgReal, cgDouble, cgComp, cgExtended: if op1^.rval = op2^.rval then CodesMatch := true; @@ -219,8 +249,8 @@ if opt1 = cgByte then begin opt1 := cgWord; end {if} else if opt1 = cgUByte then begin - op1^.optype := cgUWord; - opt1 := cgUWord; + op1^.optype := cgWord; + opt1 := cgWord; end {else if} else if opt1 in [cgReal, cgDouble, cgComp] then begin op1^.optype := cgExtended; @@ -231,8 +261,8 @@ if opt2 = cgByte then begin opt2 := cgWord; end {if} else if opt2 = cgUByte then begin - op2^.optype := cgUWord; - opt2 := cgUWord; + op2^.optype := cgWord; + opt2 := cgWord; end {else if} else if opt2 in [cgReal, cgDouble, cgComp] then begin op2^.optype := cgExtended; @@ -871,6 +901,21 @@ case op^.opcode of {check for optimizations of this node} end; {else} end; {case pc_adr} + pc_adq: begin {pc_adq} + if (op^.right^.opcode = pc_ldc) and (op^.left^.opcode = pc_ldc) then begin + add64(op^.left^.qval, op^.right^.qval); + opv := op^.left; + end {if} + else begin + if op^.left^.opcode = pc_ldc then + ReverseChildren(op); + if op^.right^.opcode = pc_ldc then begin + if (op^.right^.qval.lo = 0) and (op^.right^.qval.hi = 0) then + opv := op^.left; + end; {if} + end; {else} + end; {case pc_adq} + pc_and: begin {pc_and} if op^.right^.opcode = pc_ldc then begin if op^.left^.opcode = pc_ldc then begin @@ -905,6 +950,24 @@ case op^.opcode of {check for optimizations of this node} end; {else if} end; {case pc_bal} + pc_baq: begin {pc_baq} + if op^.left^.opcode = pc_ldc then + ReverseChildren(op); + if op^.left^.opcode = pc_ldc then begin + op^.left^.qval.hi := op^.left^.qval.hi & op^.right^.qval.hi; + op^.left^.qval.lo := op^.left^.qval.lo & op^.right^.qval.lo; + opv := op^.left; + end {if} + else if op^.right^.opcode = pc_ldc then begin + if (op^.right^.qval.lo = 0) and (op^.right^.qval.hi = 0) then begin + if not SideEffects(op^.left) then + opv := op^.right; + end {if} + else if (op^.right^.qval.lo = -1) and (op^.right^.qval.hi = -1) then + opv := op^.left; + end; {else if} + end; {case pc_baq} + pc_blr: begin {pc_blr} if op^.left^.opcode = pc_ldc then ReverseChildren(op); @@ -922,6 +985,24 @@ case op^.opcode of {check for optimizations of this node} end; {else if} end; {case pc_blr} + pc_bqr: begin {pc_bqr} + if op^.left^.opcode = pc_ldc then + ReverseChildren(op); + if op^.left^.opcode = pc_ldc then begin + op^.left^.qval.hi := op^.left^.qval.hi | op^.right^.qval.hi; + op^.left^.qval.lo := op^.left^.qval.lo | op^.right^.qval.lo; + opv := op^.left; + end {if} + else if op^.right^.opcode = pc_ldc then begin + if (op^.right^.qval.hi = -1) and (op^.right^.qval.lo = -1) then begin + if not SideEffects(op^.left) then + opv := op^.right; + end {if} + else if (op^.right^.qval.hi = 0) and (op^.right^.qval.lo = 0) then + opv := op^.left; + end; {else if} + end; {case pc_bqr} + pc_blx: begin {pc_blx} if op^.left^.opcode = pc_ldc then ReverseChildren(op); @@ -939,6 +1020,24 @@ case op^.opcode of {check for optimizations of this node} end; {else if} end; {case pc_blx} + pc_bqx: begin {pc_bqx} + if op^.left^.opcode = pc_ldc then + ReverseChildren(op); + if op^.left^.opcode = pc_ldc then begin + op^.left^.qval.hi := op^.left^.qval.hi ! op^.right^.qval.hi; + op^.left^.qval.lo := op^.left^.qval.lo ! op^.right^.qval.lo; + opv := op^.left; + end {if} + else if op^.right^.opcode = pc_ldc then begin + if (op^.right^.qval.lo = 0) and (op^.right^.qval.hi = 0) then + opv := op^.left + else if (op^.right^.qval.lo = -1) and (op^.right^.qval.hi = -1) then begin + op^.opcode := pc_bnq; + op^.right := nil; + end; {else if} + end; {else if} + end; {case pc_bqx} + pc_bnd: begin {pc_bnd} if op^.left^.opcode = pc_ldc then ReverseChildren(op); @@ -963,6 +1062,14 @@ case op^.opcode of {check for optimizations of this node} end; {if} end; {case pc_bnl} + pc_bnq: begin {pc_bnq} + if op^.left^.opcode = pc_ldc then begin + op^.left^.qval.hi := op^.left^.qval.hi ! $FFFFFFFF; + op^.left^.qval.lo := op^.left^.qval.lo ! $FFFFFFFF; + opv := op^.left; + end; {if} + end; {case pc_bnq} + pc_bno: begin {pc_bno} {Invalid optimization disabled} {if op^.left^.opcode = pc_str then @@ -1021,6 +1128,7 @@ case op^.opcode of {check for optimizations of this node} op^.q := (op^.q & $FF0F) | (fromtype.i << 4); end; {if} if op^.left^.opcode = pc_ldc then begin + doit := true; case fromtype.optype of cgByte,cgWord: case totype.optype of @@ -1030,6 +1138,14 @@ case op^.opcode of {check for optimizations of this node} op^.left^.q := 0; op^.left^.lval := lval; end; + cgQuad,cgUQuad: begin + op^.left^.qval.lo := op^.left^.q; + if op^.left^.qval.lo < 0 then + op^.left^.qval.hi := -1 + else + op^.left^.qval.hi := 0; + op^.left^.q := 0; + end; cgReal,cgDouble,cgComp,cgExtended: begin rval := op^.left^.q; op^.left^.q := 0; @@ -1045,6 +1161,11 @@ case op^.opcode of {check for optimizations of this node} op^.left^.q := 0; op^.left^.lval := lval; end; + cgQuad,cgUQuad: begin + op^.left^.qval.lo := ord4(op^.left^.q) & $0000FFFF; + op^.left^.qval.hi := 0; + op^.left^.q := 0; + end; cgReal,cgDouble,cgComp,cgExtended: begin rval := ord4(op^.left^.q) & $0000FFFF; op^.left^.q := 0; @@ -1060,6 +1181,13 @@ case op^.opcode of {check for optimizations of this node} op^.left^.q := q; end; cgLong, cgULong: ; + cgQuad,cgUQuad: begin + op^.left^.qval.lo := op^.left^.lval; + if op^.left^.qval.lo < 0 then + op^.left^.qval.hi := -1 + else + op^.left^.qval.hi := 0; + end; cgReal,cgDouble,cgComp,cgExtended: begin rval := op^.left^.lval; op^.left^.lval := 0; @@ -1075,6 +1203,10 @@ case op^.opcode of {check for optimizations of this node} op^.left^.q := q; end; cgLong, cgULong: ; + cgQuad,cgUQuad: begin + op^.left^.qval.lo := op^.left^.lval; + op^.left^.qval.hi := 0; + end; cgReal,cgDouble,cgComp,cgExtended: begin lval := op^.left^.lval; op^.left^.lval := 0; @@ -1086,6 +1218,60 @@ case op^.opcode of {check for optimizations of this node} end; otherwise: ; end; {case} + cgQuad: + case totype.optype of + cgByte,cgUByte,cgWord,cgUWord: begin + q := long(op^.left^.qval.lo).lsw; + op^.left^.qval := longlong0; + op^.left^.q := q; + end; + cgLong, cgULong: begin + lval := op^.left^.qval.lo; + op^.left^.qval := longlong0; + op^.left^.lval := lval; + end; + cgQuad,cgUQuad: ; + cgDouble,cgExtended: begin + {only convert values exactly representable in double} + rval := CnvLLX(op^.left^.qval); + if rval = CnvLLX(op^.left^.qval) then begin + op^.left^.qval := longlong0; + op^.left^.rval := rval; + end {if} + else + doit := false; + end; + cgReal,cgComp: + doit := false; + otherwise: ; + end; {case} + cgUQuad: + case totype.optype of + cgByte,cgUByte,cgWord,cgUWord: begin + q := long(op^.left^.qval.lo).lsw; + op^.left^.qval := longlong0; + op^.left^.q := q; + end; + cgLong, cgULong: begin + lval := op^.left^.qval.lo; + op^.left^.qval := longlong0; + op^.left^.lval := lval; + end; + cgQuad,cgUQuad: ; + cgDouble,cgExtended: begin + {only convert values exactly representable in double} + rval := CnvULLX(op^.left^.qval); + if rval = CnvULLX(op^.left^.qval) then begin + op^.left^.qval := longlong0; + op^.left^.rval := rval; + end {if} + else + doit := false; + end; + cgReal,cgComp: + doit := false; + otherwise: ; + end; {case} cgReal,cgDouble,cgComp,cgExtended: begin rval := op^.left^.rval; case totype.optype of @@ -1153,27 +1339,32 @@ case op^.opcode of {check for optimizations of this node} op^.left^.rval := 0.0; op^.left^.lval := lval; end; + cgQuad: + CnvXLL(op^.left^.qval, rval); + cgUQuad: + CnvXULL(op^.left^.qval, rval); cgReal,cgDouble,cgComp,cgExtended: ; otherwise: ; end; end; {case} otherwise: ; end; {case} - if fromtype.optype in - [cgByte,cgUByte,cgWord,cgUWord,cgLong,cgULong,cgReal,cgDouble, - cgComp,cgExtended] then - if totype.optype in - [cgByte,cgUByte,cgWord,cgUWord,cgLong,cgULong,cgReal,cgDouble, - cgComp,cgExtended] then begin - op^.left^.optype := totype.optype; - if totype.optype in [cgByte,cgUByte] then begin - op^.left^.q := op^.left^.q & $00FF; - if totype.optype = cgByte then - if (op^.left^.q & $0080) <> 0 then - op^.left^.q := op^.left^.q | $FF00; + if doit then + if fromtype.optype in + [cgByte,cgUByte,cgWord,cgUWord,cgLong,cgULong,cgQuad,cgUQuad, + cgReal,cgDouble,cgComp,cgExtended] then + if totype.optype in + [cgByte,cgUByte,cgWord,cgUWord,cgLong,cgULong,cgQuad,cgUQuad, + cgReal,cgDouble,cgComp,cgExtended] then begin + op^.left^.optype := totype.optype; + if totype.optype in [cgByte,cgUByte] then begin + op^.left^.q := op^.left^.q & $00FF; + if totype.optype = cgByte then + if (op^.left^.q & $0080) <> 0 then + op^.left^.q := op^.left^.q | $FF00; + end; {if} + opv := op^.left; end; {if} - opv := op^.left; - end; {if} end {if} else if op^.left^.opcode = pc_cnv then begin doit := false; @@ -1216,6 +1407,13 @@ case op^.opcode of {check for optimizations of this node} op^.left^.optype := totype.optype; opv := op^.left; end; {if} + if fromtype.optype in [cgQuad,cgUQuad] then + if totype.optype in + [cgByte,cgUByte,cgWord,cgUWord,cgLong,cgULong,cgQuad,cgUQuad] + then begin + op^.left^.optype := totype.optype; + opv := op^.left; + end; {if} end {else if} else if op^.q in [$40,$41,$50,$51] then begin {any long type to byte type} @@ -1302,6 +1500,19 @@ case op^.opcode of {check for optimizations of this node} end; {if} end; {case pc_dvl} + pc_dvq: begin {pc_dvq} + if op^.right^.opcode = pc_ldc then begin + if op^.left^.opcode = pc_ldc then begin + if (op^.right^.qval.lo <> 0) or (op^.right^.qval.hi <> 0) then begin + div64(op^.left^.qval, op^.right^.qval); + opv := op^.left; + end; {if} + end {if} + else if (op^.right^.qval.lo = 1) and (op^.right^.qval.hi = 0) then + opv := op^.left; + end; {if} + end; {case pc_dvq} + pc_dvr: begin {pc_dvr} if op^.right^.opcode = pc_ldc then begin if op^.left^.opcode = pc_ldc then begin @@ -1334,6 +1545,13 @@ case op^.opcode of {check for optimizations of this node} op^.left := nil; op^.right := nil; end; + cgQuad,cgUQuad: begin + op^.opcode := pc_ldc; + op^.q := ord((op^.left^.qval.lo = op^.right^.qval.lo) and + (op^.left^.qval.hi = op^.right^.qval.hi)); + op^.left := nil; + op^.right := nil; + end; cgReal,cgDouble,cgComp,cgExtended: begin op^.opcode := pc_ldc; op^.q := ord(op^.left^.rval = op^.right^.rval); @@ -1657,6 +1875,21 @@ case op^.opcode of {check for optimizations of this node} end; {if} end; {case pc_mdl} + pc_mdq: begin {pc_mdq} + if op^.right^.opcode = pc_ldc then + if (op^.right^.qval.lo = 1) and (op^.right^.qval.hi = 0) then begin + if not SideEffects(op^.left) then begin + op^.right^.qval := longlong0; + opv := op^.right; + end; {if} + end {if} + else if op^.left^.opcode = pc_ldc then + if (op^.right^.qval.lo <> 0) or (op^.right^.qval.hi <> 0) then begin + rem64(op^.left^.qval, op^.right^.qval); + opv := op^.left; + end; {if} + end; {case pc_mdq} + pc_mod: begin {pc_mod} if op^.right^.opcode = pc_ldc then if op^.right^.q = 1 then begin @@ -1737,6 +1970,31 @@ case op^.opcode of {check for optimizations of this node} end; {else} end; {case pc_mpl, pc_uml} + pc_mpq, pc_umq: begin {pc_mpq, pc_umq} + if (op^.right^.opcode = pc_ldc) and (op^.left^.opcode = pc_ldc) then begin + umul64(op^.left^.qval, op^.right^.qval); + opv := op^.left; + end {if} + else begin + if op^.left^.opcode = pc_ldc then + ReverseChildren(op); + if op^.right^.opcode = pc_ldc then begin + if (op^.right^.qval.lo = 1) and (op^.right^.qval.hi = 0) then + opv := op^.left + else if (op^.right^.qval.lo = 0) and (op^.right^.qval.hi = 0) then + begin + if not SideEffects(op^.left) then + opv := op^.right; + end {else if} + else if (op^.right^.qval.lo = -1) and (op^.right^.qval.hi = -1) then + if op^.opcode = pc_mpq then begin + op^.opcode := pc_ngq; + op^.right := nil; + end; {if} + end; {if} + end; {else} + end; {case pc_mpq, pc_umq} + pc_mpr: begin {pc_mpr} if (op^.right^.opcode = pc_ldc) and (op^.left^.opcode = pc_ldc) then begin op^.left^.rval := op^.left^.rval*op^.right^.rval; @@ -1775,6 +2033,13 @@ case op^.opcode of {check for optimizations of this node} op^.left := nil; op^.right := nil; end; + cgQuad,cgUQuad: begin + op^.opcode := pc_ldc; + op^.q := ord((op^.left^.qval.lo <> op^.right^.qval.lo) or + (op^.left^.qval.hi <> op^.right^.qval.hi)); + op^.left := nil; + op^.right := nil; + end; cgReal,cgDouble,cgComp,cgExtended: begin op^.opcode := pc_ldc; op^.q := ord(op^.left^.rval <> op^.right^.rval); @@ -1825,6 +2090,19 @@ case op^.opcode of {check for optimizations of this node} end; {if} end; {case pc_ngl} + pc_ngq: begin {pc_ngq} + if op^.left^.opcode = pc_ldc then begin + with op^.left^.qval do begin + lo := ~lo; + hi := ~hi; + lo := lo + 1; + if lo = 0 then + hi := hi + 1; + end; {with} + opv := op^.left; + end; {if} + end; {case pc_ngq} + pc_ngr: begin {pc_ngr} if op^.left^.opcode = pc_ldc then begin op^.left^.rval := -op^.left^.rval; @@ -1841,7 +2119,12 @@ case op^.opcode of {check for optimizations of this node} end {if} else if op^.left^.optype in [cgLong,cgULong] then begin q := ord(op^.left^.lval = 0); - lval := 0; + op^.left^.q := q; + op^.left^.optype := cgWord; + opv := op^.left; + end {else if} + else if op^.left^.optype in [cgQuad,cgUQuad] then begin + q := ord((op^.left^.qval.lo = 0) and (op^.left^.qval.hi = 0)); op^.left^.q := q; op^.left^.optype := cgWord; opv := op^.left; @@ -2014,10 +2297,32 @@ case op^.opcode of {check for optimizations of this node} end; {if} end; {case pc_sbr} + pc_sbq: begin {pc_sbq} + if op^.left^.opcode = pc_ldc then begin + if op^.right^.opcode = pc_ldc then begin + sub64(op^.left^.qval, op^.right^.qval); + opv := op^.left; + end {if} + else if (op^.left^.qval.lo = 0) and (op^.left^.qval.hi = 0) then begin + op^.opcode := pc_ngq; + op^.left := op^.right; + op^.right := nil; + end; {else if} + end {if} + else if op^.right^.opcode = pc_ldc then begin + if (op^.right^.qval.lo = 0) and (op^.right^.qval.hi = 0) then + opv := op^.left; + end; {if} + end; {case pc_sbq} + pc_shl: begin {pc_shl} if op^.right^.opcode = pc_ldc then begin opcode := op^.left^.opcode; - if opcode = pc_shl then begin + if opcode = pc_ldc then begin + op^.left^.q := op^.left^.q << op^.right^.q; + opv := op^.left; + end {if} + else if opcode = pc_shl then begin if op^.left^.right^.opcode = pc_ldc then begin op^.right^.q := op^.right^.q + op^.left^.right^.q; op^.left := op^.left^.left; @@ -2030,10 +2335,56 @@ case op^.opcode of {check for optimizations of this node} op2^.left := op; opv := op2; PeepHoleOptimization(op2^.left); - end; {else if} + end {else if} + else if op^.right^.q = 0 then + opv := op^.left; end; {if} end; {case pc_shl} + pc_shr: begin {pc_shr} + if op^.right^.opcode = pc_ldc then begin + if op^.left^.opcode = pc_ldc then begin + op^.left^.q := op^.left^.q >> op^.right^.q; + opv := op^.left; + end {if} + else if op^.right^.q = 0 then + opv := op^.left; + end; {if} + end; {case pc_shr} + + pc_sll: begin {pc_sll} + if op^.right^.opcode = pc_ldc then begin + if op^.left^.opcode = pc_ldc then begin + op^.left^.lval := op^.left^.lval << op^.right^.lval; + opv := op^.left; + end {if} + else if op^.right^.lval = 0 then + opv := op^.left; + end; {if} + end; {case pc_sll} + + pc_slr: begin {pc_slr} + if op^.right^.opcode = pc_ldc then begin + if op^.left^.opcode = pc_ldc then begin + op^.left^.lval := op^.left^.lval >> op^.right^.lval; + opv := op^.left; + end {if} + else if op^.right^.lval = 0 then + opv := op^.left; + end; {if} + end; {case pc_slr} + + pc_slq: begin {pc_slq} + if op^.right^.opcode = pc_ldc then begin + if op^.left^.opcode = pc_ldc then begin + shl64(op^.left^.qval, op^.right^.q); + opv := op^.left; + end {if} + else if op^.right^.q = 0 then + opv := op^.left; + end; {if} + end; {case pc_slq} + pc_sro, pc_str: begin {pc_sro, pc_str} if op^.optype in [cgReal,cgDouble,cgExtended] then RealStoreOptimizations(op, op^.left); @@ -2058,6 +2409,17 @@ case op^.opcode of {check for optimizations of this node} end; {if} end; {case pc_sto} + pc_sqr: begin {pc_sqr} + if op^.right^.opcode = pc_ldc then begin + if op^.left^.opcode = pc_ldc then begin + ashr64(op^.left^.qval, op^.right^.q); + opv := op^.left; + end {if} + else if op^.right^.q = 0 then + opv := op^.left; + end; {if} + end; {case pc_sqr} + pc_tjp: begin {pc_tjp} opcode := op^.left^.opcode; if opcode = pc_ldc then begin @@ -2161,6 +2523,19 @@ case op^.opcode of {check for optimizations of this node} end; {if} end; {case pc_udl} + pc_udq: begin {pc_udq} + if op^.right^.opcode = pc_ldc then begin + if op^.left^.opcode = pc_ldc then begin + if (op^.right^.qval.lo <> 0) or (op^.right^.qval.hi <> 0) then begin + udiv64(op^.left^.qval, op^.right^.qval); + opv := op^.left; + end; {if} + end {if} + else if (op^.right^.qval.lo = 1) and (op^.right^.qval.hi = 0) then + opv := op^.left; + end; {if} + end; {case pc_udq} + pc_uim: begin {pc_uim} if op^.right^.opcode = pc_ldc then if op^.right^.q = 1 then begin @@ -2207,6 +2582,55 @@ case op^.opcode of {check for optimizations of this node} end; {if} end; {case pc_ulm} + pc_uqm: begin {pc_uqm} + if op^.right^.opcode = pc_ldc then + if (op^.right^.qval.lo = 1) and (op^.right^.qval.hi = 0) then begin + if not SideEffects(op^.left) then begin + op^.right^.qval := longlong0; + opv := op^.right; + end; {if} + end {if} + else if op^.left^.opcode = pc_ldc then + if (op^.right^.qval.lo <> 0) or (op^.right^.qval.hi <> 0) then begin + umod64(op^.left^.qval, op^.right^.qval); + opv := op^.left; + end; {if} + end; {case pc_uqm} + + pc_usr: begin {pc_usr} + if op^.right^.opcode = pc_ldc then begin + if op^.left^.opcode = pc_ldc then begin + lval := lshr(op^.left^.q & $0000FFFF, op^.right^.q); + op^.left^.q := long(lval).lsw; + opv := op^.left; + end {if} + else if op^.right^.q = 0 then + opv := op^.left; + end; {if} + end; {case pc_usr} + + pc_vsr: begin {pc_vsr} + if op^.right^.opcode = pc_ldc then begin + if op^.left^.opcode = pc_ldc then begin + op^.left^.lval := lshr(op^.left^.lval, op^.right^.lval); + opv := op^.left; + end {if} + else if op^.right^.lval = 0 then + opv := op^.left; + end; {if} + end; {case pc_vsr} + + pc_wsr: begin {pc_wsr} + if op^.right^.opcode = pc_ldc then begin + if op^.left^.opcode = pc_ldc then begin + lshr64(op^.left^.qval, op^.right^.q); + opv := op^.left; + end {if} + else if op^.right^.q = 0 then + opv := op^.left; + end; {if} + end; {case pc_wsr} + otherwise: ; end; {case} end; {PeepHoleOptimization} @@ -2300,6 +2724,13 @@ case op^.opcode of pc_udl, pc_ulm, pc_uml, pc_vsr: TypeOf := cgULong; + pc_bnq, pc_ngq, pc_bqr, pc_bqx, pc_baq, pc_adq, pc_sbq, pc_mpq, + pc_dvq, pc_mdq, pc_slq, pc_sqr: + TypeOf := cgQuad; + + pc_umq, pc_udq, pc_uqm, pc_wsr: + TypeOf := cgUQuad; + pc_ngr, pc_adr, pc_dvr, pc_mpr, pc_sbr: TypeOf := cgExtended; @@ -4092,7 +4523,9 @@ var pc_ixa,pc_lad,pc_lao,pc_lca,pc_lda,pc_ldc,pc_mod,pc_uim, pc_mdl,pc_ulm,pc_mpi,pc_umi,pc_mpl,pc_uml,pc_mpr,pc_ngi, pc_ngl,pc_ngr,pc_not,pc_pop,pc_sbi,pc_sbl,pc_sbr, - pc_shl,pc_sll,pc_shr,pc_usr,pc_slr,pc_vsr,pc_tri] + pc_shl,pc_sll,pc_shr,pc_usr,pc_slr,pc_vsr,pc_tri, + 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] then begin op^.parents := icount; icount := icount+1; @@ -4960,7 +5393,7 @@ case code^.opcode of pc_bnt, pc_bnl, pc_cnv, pc_dec, pc_inc, pc_ind, pc_lbf, pc_lbu, pc_ngi, pc_ngl, pc_ngr, pc_not, pc_stk, pc_cop, pc_cpo, pc_tl1, pc_sro, pc_str, pc_fjp, pc_tjp, pc_xjp, pc_cup, pc_pop, pc_iil, - pc_ili, pc_idl, pc_ild: + pc_ili, pc_idl, pc_ild, pc_bnq, pc_ngq: begin code^.left := Pop; Push(code); @@ -4972,7 +5405,9 @@ case code^.opcode of pc_les, pc_neq, pc_ior, pc_lor, pc_ixa, pc_mod, pc_uim, pc_mdl, pc_ulm, pc_mpi, pc_umi, pc_mpl, pc_uml, pc_mpr, pc_psh, pc_sbi, pc_sbl, pc_sbr, pc_shl, pc_sll, pc_shr, pc_usr, pc_slr, pc_vsr, - pc_tri, pc_sbf, pc_sto, pc_cui: + pc_tri, pc_sbf, pc_sto, pc_cui, pc_bqr, pc_bqx, pc_baq, pc_adq, + pc_sbq, pc_mpq, pc_umq, pc_dvq, pc_udq, pc_mdq, pc_uqm, pc_slq, + pc_sqr, pc_wsr: begin code^.right := Pop; code^.left := Pop; diff --git a/Debugger.md b/Debugger.md index bb88635..d9aa97e 100644 --- a/Debugger.md +++ b/Debugger.md @@ -105,14 +105,14 @@ The following table shows the format used to store the variable’s current valu 7 Pascal-style string 8 character 9 boolean - 10 SANE COMP number + 10 SANE COMP number or 8-byte integer 11 pointer 12 structure, union or record 13 derived type 14 object -One-byte integers default to unsigned, while two-byte and four-byte integers default to signed format. `OR`ing the format code with `$40` reverses this default, giving signed one-byte integers or unsigned four-byte integers. (The signed flag is not supported by PRIZM 1.1.3.) +One-byte integers default to unsigned, while two-byte, four-byte, and eight-byte integers default to signed format. `OR`ing the format code with `$40` reverses this default, giving signed one-byte integers or unsigned four-byte integers. (The signed flag is not supported by PRIZM 1.1.3.) A pointer to a scalar type (1-10) is indicated by `OR`ing the value’s format code with `$80`. For example, `$82` would be a pointer to a 4-byte integer. diff --git a/Exp.macros b/Exp.macros index 8d451b7..5b97682 100644 --- a/Exp.macros +++ b/Exp.macros @@ -162,3 +162,107 @@ LONGI OFF .I MEND + macro +&l ph8 &n1 + lclc &c +&l anop +&c amid &n1,1,1 + aif s:longa=1,.a + rep #%00100000 +.a + aif "&c"="#",.d + aif "&c"="[",.b + aif "&c"<>"{",.c +&c amid &n1,l:&n1,1 + aif "&c"<>"}",.g +&n1 amid &n1,2,l:&n1-2 +&n1 setc (&n1) +.b + ldy #6 +~&SYSCNT lda &n1,y + pha + dey + dey + bpl ~&SYSCNT + ago .e +.c + ldx #6 +~&SYSCNT lda &n1,x + pha + dex + dex + bpl ~&SYSCNT + ago .e +.d +&n1 amid &n1,2,l:&n1-1 + bra ~b&SYSCNT +~a&SYSCNT dc i8"&n1" +~b&SYSCNT ldx #6 +~c&SYSCNT lda ~a&SYSCNT,x + pha + dex + dex + bpl ~c&SYSCNT +.e + aif s:longa=1,.f + sep #%00100000 +.f + mexit +.g + mnote "Missing closing '}'",16 + mend + macro +&l pl8 &n1 + lclc &c +&l anop + aif s:longa=1,.a + rep #%00100000 +.a +&c amid &n1,1,1 + aif "&c"<>"{",.b +&c amid &n1,l:&n1,1 + aif "&c"<>"}",.f +&n1 amid &n1,2,l:&n1-2 + pla + sta (&n1) + ldy #2 + pla + sta (&n1),y + ldy #4 + pla + sta (&n1),y + ldy #6 + pla + sta (&n1),y + ago .d +.b + aif "&c"<>"[",.c + pla + sta &n1 + ldy #2 + pla + sta &n1,y + ldy #4 + pla + sta &n1,y + ldy #6 + pla + sta &n1,y + ago .d +.c + pla + sta &n1 + pla + sta &n1+2 + pla + sta &n1+4 + pla + sta &n1+6 +.d + aif s:longa=1,.e + sep #%00100000 +.e + mexit +.f + mnote "Missing closing '}'",16 + mend diff --git a/Expression.asm b/Expression.asm index 378ff8d..e85b36c 100644 --- a/Expression.asm +++ b/Expression.asm @@ -382,3 +382,559 @@ ml6 ror a shift the answer ; ml7 return 4:ans fix the stack end + +**************************************************************** +* +* procedure umul64 (var x: longlong; y: longlong); +* +* Inputs: +* x,y - operands +* +* Outputs: +* x - result +* +**************************************************************** +* +umul64 start exp + + subroutine (4:x,4:y),0 + + ph8 [x] + ph8 [y] + jsl ~UMUL8 + pl8 [x] + + return + end + +**************************************************************** +* +* procedure udiv64 (var x: longlong; y: longlong); +* +* Inputs: +* x,y - operands +* +* Outputs: +* x - result +* +**************************************************************** +* +udiv64 start exp + + subroutine (4:x,4:y),0 + + ph8 [x] + ph8 [y] + jsl ~UDIV8 + pl8 [x] + pla + pla + pla + pla + + return + end + +**************************************************************** +* +* procedure div64 (var x: longlong; y: longlong); +* +* Inputs: +* x,y - operands +* +* Outputs: +* x - result +* +**************************************************************** +* +div64 start exp + + subroutine (4:x,4:y),0 + + ph8 [x] + ph8 [y] + jsl ~CDIV8 + pl8 [x] + pla + pla + pla + pla + + return + end + +**************************************************************** +* +* procedure umod64 (var x: longlong; y: longlong); +* +* Inputs: +* x,y - operands +* +* Outputs: +* x - result +* +**************************************************************** +* +umod64 start exp + + subroutine (4:x,4:y),0 + + ph8 [x] + ph8 [y] + jsl ~UDIV8 + pla + pla + pla + pla + pl8 [x] + + return + end + +**************************************************************** +* +* procedure rem64 (var x: longlong; y: longlong); +* +* Inputs: +* x,y - operands +* +* Outputs: +* x - result +* +**************************************************************** +* +rem64 start exp + + subroutine (4:x,4:y),0 + + ph8 [x] + ph8 [y] + jsl ~CDIV8 + pla + pla + pla + pla + pl8 [x] + + return + end + +**************************************************************** +* +* procedure add64 (var x: longlong; y: longlong); +* +* Inputs: +* x,y - operands +* +* Outputs: +* x - result +* +**************************************************************** +* +add64 start exp + + subroutine (4:x,4:y),0 + + ph8 [x] + ph8 [y] + jsl ~ADD8 + pl8 [x] + + return + end + +**************************************************************** +* +* procedure sub64 (var x: longlong; y: longlong); +* +* Inputs: +* x,y - operands +* +* Outputs: +* x - result +* +**************************************************************** +* +sub64 start exp + + subroutine (4:x,4:y),0 + + ph8 [x] + ph8 [y] + jsl ~SUB8 + pl8 [x] + + return + end + +**************************************************************** +* +* procedure shl64 (var x: longlong; y: integer); +* +* Inputs: +* x,y - operands +* +* Outputs: +* x - result +* +**************************************************************** +* +shl64 start exp + + subroutine (4:x,2:y),0 + + ph8 [x] + lda y + jsl ~SHL8 + pl8 [x] + + return + end + +**************************************************************** +* +* procedure ashr64 (var x: longlong; y: integer); +* +* Inputs: +* x,y - operands +* +* Outputs: +* x - result +* +**************************************************************** +* +ashr64 start exp + + subroutine (4:x,2:y),0 + + ph8 [x] + lda y + jsl ~ASHR8 + pl8 [x] + + return + end + +**************************************************************** +* +* procedure lshr64 (var x: longlong; y: integer); +* +* Inputs: +* x,y - operands +* +* Outputs: +* x - result +* +**************************************************************** +* +lshr64 start exp + + subroutine (4:x,2:y),0 + + ph8 [x] + lda y + jsl ~LSHR8 + pl8 [x] + + return + end + +**************************************************************** +* +* function ult64(a,b: longlong): integer; +* +**************************************************************** +* +ult64 start exp +result equ 0 + + subroutine (4:a,4:b),2 + + stz result + ldy #6 + lda [a],y + cmp [b],y + bne lb1 + dey + dey + lda [a],y + cmp [b],y + bne lb1 + dey + dey + lda [a],y + cmp [b],y + bne lb1 + lda [a] + cmp [b] +lb1 bge lb2 + inc result + +lb2 return 2:result + end + +**************************************************************** +* +* function uge64(a,b: longlong): integer; +* +**************************************************************** +* +uge64 start exp +result equ 0 + + subroutine (4:a,4:b),2 + + stz result + ldy #6 + lda [a],y + cmp [b],y + bne lb1 + dey + dey + lda [a],y + cmp [b],y + bne lb1 + dey + dey + lda [a],y + cmp [b],y + bne lb1 + lda [a] + cmp [b] +lb1 blt lb2 + inc result + +lb2 return 2:result + end + +**************************************************************** +* +* function ule64(a,b: longlong): integer; +* +**************************************************************** +* +ule64 start exp +result equ 0 + + subroutine (4:a,4:b),2 + + stz result + ldy #6 + lda [a],y + cmp [b],y + bne lb1 + dey + dey + lda [a],y + cmp [b],y + bne lb1 + dey + dey + lda [a],y + cmp [b],y + bne lb1 + lda [a] + cmp [b] +lb1 bgt lb2 + inc result + +lb2 return 2:result + end + +**************************************************************** +* +* function ugt64(a,b: longlong): integer; +* +**************************************************************** +* +ugt64 start exp +result equ 0 + + subroutine (4:a,4:b),2 + + stz result + ldy #6 + lda [a],y + cmp [b],y + bne lb1 + dey + dey + lda [a],y + cmp [b],y + bne lb1 + dey + dey + lda [a],y + cmp [b],y + bne lb1 + lda [a] + cmp [b] +lb1 ble lb2 + inc result + +lb2 return 2:result + end + +**************************************************************** +* +* function slt64(a,b: longlong): integer; +* +**************************************************************** +* +slt64 start exp +result equ 0 + + subroutine (4:a,4:b),2 + + stz result + ldy #6 + lda [a],y + eor [b],y + bpl lb0 + lda [b],y + cmp [a],y + bra lb1 + +lb0 lda [a],y + cmp [b],y + bne lb1 + dey + dey + lda [a],y + cmp [b],y + bne lb1 + dey + dey + lda [a],y + cmp [b],y + bne lb1 + lda [a] + cmp [b] +lb1 bge lb2 + inc result + +lb2 return 2:result + end + +**************************************************************** +* +* function sge64(a,b: longlong): integer; +* +**************************************************************** +* +sge64 start exp +result equ 0 + + subroutine (4:a,4:b),2 + + stz result + ldy #6 + lda [a],y + eor [b],y + bpl lb0 + lda [b],y + cmp [a],y + bra lb1 + +lb0 lda [a],y + cmp [b],y + bne lb1 + dey + dey + lda [a],y + cmp [b],y + bne lb1 + dey + dey + lda [a],y + cmp [b],y + bne lb1 + lda [a] + cmp [b] +lb1 blt lb2 + inc result + +lb2 return 2:result + end + +**************************************************************** +* +* function sle64(a,b: longlong): integer; +* +**************************************************************** +* +sle64 start exp +result equ 0 + + subroutine (4:a,4:b),2 + + stz result + ldy #6 + lda [a],y + eor [b],y + bpl lb0 + lda [b],y + cmp [a],y + bra lb1 + +lb0 lda [a],y + cmp [b],y + bne lb1 + dey + dey + lda [a],y + cmp [b],y + bne lb1 + dey + dey + lda [a],y + cmp [b],y + bne lb1 + lda [a] + cmp [b] +lb1 bgt lb2 + inc result + +lb2 return 2:result + end + +**************************************************************** +* +* function sgt64(a,b: longlong): integer; +* +**************************************************************** +* +sgt64 start exp +result equ 0 + + subroutine (4:a,4:b),2 + + stz result + ldy #6 + lda [a],y + eor [b],y + bpl lb0 + lda [b],y + cmp [a],y + bra lb1 + +lb0 lda [a],y + cmp [b],y + bne lb1 + dey + dey + lda [a],y + cmp [b],y + bne lb1 + dey + dey + lda [a],y + cmp [b],y + bne lb1 + lda [a] + cmp [b] +lb1 ble lb2 + inc result + +lb2 return 2:result + end diff --git a/Expression.pas b/Expression.pas index e0814e4..0140c62 100644 --- a/Expression.pas +++ b/Expression.pas @@ -216,6 +216,11 @@ function UsualUnaryConversions: baseTypeEnum; { outputs: } { expressionType - set to result type } +procedure GetLLExpressionValue (var val: longlong); + +{ get the value of the last integer constant expression as a } +{ long long (whether it had long long type or not). } + {---------------------------------------------------------------} implementation @@ -269,6 +274,55 @@ function umod (x,y: longint): longint; extern; function umul (x,y: longint): longint; extern; +{-- External 64-bit math routines ------------------------------} +{ Procedures for arithmetic and shifts compute "x := x OP y". } + +procedure umul64 (var x: longlong; y: longlong); extern; + +procedure udiv64 (var x: longlong; y: longlong); extern; + +procedure div64 (var x: longlong; y: longlong); extern; + +procedure umod64 (var x: longlong; y: longlong); extern; + +procedure rem64 (var x: longlong; y: longlong); extern; + +procedure add64 (var x: longlong; y: longlong); extern; + +procedure sub64 (var x: longlong; y: longlong); extern; + +procedure shl64 (var x: longlong; y: integer); extern; + +procedure ashr64 (var x: longlong; y: integer); extern; + +procedure lshr64 (var x: longlong; y: integer); extern; + +function ult64(a,b: longlong): integer; extern; + +function uge64(a,b: longlong): integer; extern; + +function ule64(a,b: longlong): integer; extern; + +function ugt64(a,b: longlong): integer; extern; + +function slt64(a,b: longlong): integer; extern; + +function sge64(a,b: longlong): integer; extern; + +function sle64(a,b: longlong): integer; extern; + +function sgt64(a,b: longlong): integer; extern; + +{-- External conversion functions; imported from CGC.pas -------} + +procedure CnvXLL (var result: longlong; val: extended); extern; + +procedure CnvXULL (var result: longlong; val: extended); extern; + +function CnvLLX (val: longlong): extended; extern; + +function CnvULLX (val: longlong): extended; extern; + {---------------------------------------------------------------} function Unary(tp: baseTypeEnum): baseTypeEnum; @@ -337,17 +391,41 @@ if (lType^.kind = scalarType) and (rType^.kind = scalarType) then begin rt := Unary(rType^.baseType); if lt <> rt then begin if lt = cgExtended then begin - if rt in [cgWord,cgUWord,cgLong,cgULong] then + if rt in [cgWord,cgUWord,cgLong,cgULong,cgQuad,cgUQuad] then Gen2(pc_cnv, ord(rt), ord(cgExtended)); UsualBinaryConversions := cgExtended; expressionType := extendedPtr; end {if} else if rt = cgExtended then begin - if lt in [cgWord,cgUWord,cgLong,cgULong] then + if lt in [cgWord,cgUWord,cgLong,cgULong,cgQuad,cgUQuad] then Gen2(pc_cnn, ord(lt), ord(cgExtended)); UsualBinaryConversions := cgExtended; expressionType := extendedPtr; end {else if} + else if lt = cgUQuad then begin + if rt in [cgWord,cgUWord,cgLong,cgULong] then + Gen2(pc_cnv, ord(rt), ord(cgUQuad)); + UsualBinaryConversions := cgUQuad; + expressionType := uLongLongPtr; + end {else if} + else if rt = cgUQuad then begin + if lt in [cgWord,cgUWord,cgLong,cgULong] then + Gen2(pc_cnn, ord(lt), ord(cgUQuad)); + UsualBinaryConversions := cgUQuad; + expressionType := uLongLongPtr; + end {else if} + else if lt = cgQuad then begin + if rt in [cgWord,cgUWord,cgLong,cgULong] then + Gen2(pc_cnv, ord(rt), ord(cgQuad)); + UsualBinaryConversions := cgQuad; + expressionType := longLongPtr; + end {else if} + else if rt = cgQuad then begin + if lt in [cgWord,cgUWord,cgLong,cgULong] then + Gen2(pc_cnn, ord(lt), ord(cgQuad)); + UsualBinaryConversions := cgQuad; + expressionType := longLongPtr; + end {else if} else if lt = cgULong then begin if rt in [cgWord,cgUWord] then Gen2(pc_cnv, ord(rt), ord(cgULong)); @@ -820,8 +898,9 @@ var {in the preprocessor, all identifiers (post macro replacement) become 0} if kind = preprocessorExpression then begin - stack^.token.kind := longconst; - stack^.token.lval := 0; + stack^.token.class := longlongConstant; + stack^.token.kind := longlongconst; + stack^.token.qval := longlong0; end {if} {if the id is not declared, create a function returning integer} @@ -866,7 +945,7 @@ var { do an operation } - label 1; + label 1,2,3; var baseType: baseTypeEnum; {base type of value to cast} @@ -877,6 +956,8 @@ var op: tokenPtr; {work pointer} op1,op2: longint; {for evaluating constant expressions} rop1,rop2: double; {for evaluating double expressions} + llop1, llop2: longlong; {for evaluating long long expressions} + extop1: extended; {temporary for conversions} tp: typePtr; {cast type} unsigned: boolean; {is the term unsigned?} @@ -903,7 +984,7 @@ var end; {Pop} - function RealVal (token: tokenType): double; + function RealVal (token: tokenType): extended; { convert an operand to a real value } @@ -924,6 +1005,10 @@ var else RealVal := token.lval; end {else if} + else if token.kind = longlongconst then + RealVal := CnvLLX(token.qval) + else if token.kind = ulonglongconst then + RealVal := CnvULLX(token.qval) else RealVal := token.rval; end; {RealVal} @@ -945,15 +1030,48 @@ var end; {IntVal} + procedure GetLongLongVal (var result: longlong; token: tokenType); + + { convert an operand to a long long value } + + begin {LongLongVal} + if token.kind = intconst then begin + result.lo := token.ival; + if result.lo < 0 then + result.hi := -1 + else + result.hi := 0; + end {if} + else if token.kind = uintconst then begin + result.lo := token.ival & $0000FFFF; + result.hi := 0; + end {else if} + else if token.kind = longconst then begin + result.lo := token.lval; + if result.lo < 0 then + result.hi := -1 + else + result.hi := 0; + end {else if} + else if token.kind = ulongconst then begin + result.lo := token.lval; + result.hi := 0; + end {else if} + else {if token.kind in [longlongconst,ulonglongconst] then} begin + result := token.qval; + end; {else} + end; {LongLongVal} + + function PPKind (token: tokenType): tokenEnum; { adjust kind of token for use in preprocessor expression } begin {PPKind} - if token.kind = intconst then - PPKind := longconst - else if token.kind = uintconst then - PPKind := ulongconst + if token.kind in [intconst,longconst] then + PPKind := longlongconst + else if token.kind in [uintconst,ulongconst] then + PPKind := ulonglongconst else PPKind := token.kind; end; {PPKind} @@ -988,13 +1106,14 @@ var op^.right := Pop; op^.middle := Pop; op^.left := Pop; - if op^.right^.token.kind in - [intconst,uintconst,longconst,ulongconst] then - if op^.left^.token.kind in - [intconst,uintconst,longconst,ulongconst] then - if op^.middle^.token.kind in - [intconst,uintconst,longconst,ulongconst] then begin - if IntVal(op^.left^.token) <> 0 then + if op^.right^.token.kind in [intconst,uintconst, + longconst,ulongconst,longlongconst,ulonglongconst] then + if op^.left^.token.kind in [intconst,uintconst, + longconst,ulongconst,longlongconst,ulonglongconst] then + if op^.middle^.token.kind in [intconst,uintconst, + longconst,ulongconst,longlongconst,ulonglongconst] then begin + GetLongLongVal(llop1, op^.left^.token); + if (llop1.lo <> 0) or (llop1.hi <> 0) then op^.token := op^.middle^.token else op^.token := op^.right^.token; @@ -1036,10 +1155,8 @@ var kindLeft := op^.left^.token.kind; if kindRight in [intconst,uintconst,longconst,ulongconst] then begin if kindLeft in [intconst,uintconst,longconst,ulongconst] then begin - if kind = preprocessorExpression then begin - kindLeft := PPKind(op^.left^.token); - kindRight := PPKind(op^.right^.token); - end; {if} + if kind = preprocessorExpression then + goto 2; {do the usual binary conversions} if (kindRight = ulongconst) or (kindLeft = ulongconst) then @@ -1172,14 +1289,174 @@ var goto 1; end; {if} end; {if} - if op^.right^.token.kind in - [intconst,uintconst,longconst,ulongconst,doubleconst] then - if op^.left^.token.kind in - [intconst,uintconst,longconst,ulongconst,doubleconst] then +2: + if kindRight in [intconst,uintconst,longconst,ulongconst, + longlongconst,ulonglongconst] then begin + if kindLeft in [intconst,uintconst,longconst,ulongconst, + longlongconst,ulonglongconst] then begin + + if kind = preprocessorExpression then begin + kindLeft := PPKind(op^.left^.token); + kindRight := PPKind(op^.right^.token); + end; {if} + + {do the usual binary conversions} + if (kindRight = ulonglongconst) or (kindLeft = ulonglongconst) then + ekind := ulonglongconst + else + ekind := longlongconst; + + unsigned := ekind = ulonglongconst; + GetLongLongVal(llop1, op^.left^.token); + GetLongLongVal(llop2, op^.right^.token); + + case op^.token.kind of + barbarop : begin {||} + llop1.hi := 0; + llop1.lo := + ord((llop1.lo <> 0) or (llop1.hi <> 0) or + (llop2.lo <> 0) or (llop2.hi <> 0)); + ekind := intconst; + end; + andandop : begin {&&} + llop1.hi := 0; + llop1.lo := + ord(((llop1.lo <> 0) or (llop1.hi <> 0)) and + ((llop2.lo <> 0) or (llop2.hi <> 0))); + ekind := intconst; + end; + carotch : begin {^} + llop1.lo := llop1.lo ! llop2.lo; + llop1.hi := llop1.hi ! llop2.hi; + end; + barch : begin {|} + llop1.lo := llop1.lo | llop2.lo; + llop1.hi := llop1.hi | llop2.hi; + end; + andch : begin {&} + llop1.lo := llop1.lo & llop2.lo; + llop1.hi := llop1.hi & llop2.hi; + end; + eqeqop : begin {==} + llop1.hi := 0; + llop1.lo := ord((llop1.lo = llop2.lo) and + (llop1.hi = llop2.hi)); + ekind := intconst; + end; + exceqop : begin {!=} + llop1.hi := 0; + llop1.lo := ord((llop1.lo <> llop2.lo) or + (llop1.hi <> llop2.hi)); + ekind := intconst; + end; + ltch : begin {<} + if unsigned then + llop1.lo := ult64(llop1, llop2) + else + llop1.lo := slt64(llop1, llop2); + llop1.hi := 0; + ekind := intconst; + end; + gtch : begin {>} + if unsigned then + llop1.lo := ugt64(llop1, llop2) + else + llop1.lo := sgt64(llop1, llop2); + llop1.hi := 0; + ekind := intconst; + end; + lteqop : begin {<=} + if unsigned then + llop1.lo := ule64(llop1, llop2) + else + llop1.lo := sle64(llop1, llop2); + llop1.hi := 0; + ekind := intconst; + end; + gteqop : begin {>=} + if unsigned then + llop1.lo := uge64(llop1, llop2) + else + llop1.lo := sge64(llop1, llop2); + llop1.hi := 0; + ekind := intconst; + end; + ltltop : begin {<<} + shl64(llop1, long(llop2.lo).lsw); + ekind := kindLeft; + end; + gtgtop : begin {>>} + if kindleft = ulonglongconst then + lshr64(llop1, long(llop2.lo).lsw) + else + ashr64(llop1, long(llop2.lo).lsw); + ekind := kindLeft; + end; + plusch : add64(llop1, llop2); {+} + minusch : sub64(llop1, llop2); {-} + asteriskch : umul64(llop1, llop2); {*} + slashch : begin {/} + if (llop2.lo = 0) and (llop2.hi = 0) then begin + Error(109); + llop2 := longlong1; + end; {if} + if unsigned then + udiv64(llop1, llop2) + else + div64(llop1, llop2); + end; + percentch : begin {%} + if (llop2.lo = 0) and (llop2.hi = 0) then begin + Error(109); + llop2 := longlong1; + end; {if} + if unsigned then + umod64(llop1, llop2) + else + rem64(llop1, llop2); + end; + otherwise: Error(57); + end; {case} + + dispose(op^.right); + op^.right := nil; + dispose(op^.left); + op^.left := nil; + op^.token.kind := ekind; + if ekind in [longlongconst,ulonglongconst] then begin + op^.token.qval := llop1; + op^.token.class := longlongConstant; + end {if} + else if ekind in [longconst,ulongconst] then begin + op^.token.lval := llop1.lo; + op^.token.class := longConstant; + end {if} + else begin + op^.token.ival := long(llop1.lo).lsw; + op^.token.class := intConstant; + end; {else} + goto 1; + end; {if} + end; {if} + + if op^.right^.token.kind in [intconst,uintconst,longconst,ulongconst, + longlongconst,ulonglongconst,doubleconst] then + if op^.left^.token.kind in [intconst,uintconst,longconst,ulongconst, + longlongconst,ulonglongconst,doubleconst] then begin ekind := doubleconst; {evaluate a constant operation} - rop1 := RealVal(op^.left^.token); - rop2 := RealVal(op^.right^.token); + extop1 := RealVal(op^.left^.token); + rop1 := extop1; + if op^.left^.token.kind in [longlongconst,ulonglongconst] then + if rop1 <> extop1 then + if not (op^.token.kind in [barbarop,andandop]) then + goto 1; + extop1 := RealVal(op^.right^.token); + rop2 := extop1; + if op^.right^.token.kind in [longlongconst,ulonglongconst] then + if rop2 <> extop1 then + if not (op^.token.kind in [barbarop,andandop]) then + goto 1; dispose(op^.right); op^.right := nil; dispose(op^.left); @@ -1282,27 +1559,32 @@ var else if op^.token.kind = castoper then begin class := op^.left^.token.class; - if class in [intConstant,longConstant,doubleConstant] then begin + if class in [intConstant,longConstant,longlongconstant, + doubleConstant] then begin tp := op^.castType; while tp^.kind = definedType do tp := tp^.dType; if tp^.kind = scalarType then begin baseType := tp^.baseType; - if baseType < cgString then begin + if (baseType < cgString) or (baseType in [cgQuad,cgUQuad]) + then begin if class = doubleConstant then begin rop1 := RealVal(op^.left^.token); - op1 := trunc(rop1); - end {if} - else {if class in [intConstant,longConstant] then} begin - op1 := IntVal(op^.left^.token); - if op1 >= 0 then - rop1 := op1 - else if op^.left^.token.kind = uintConst then - rop1 := (op1 & $7FFF) + 32768.0 - else if op^.left^.token.kind = ulongConst then - rop1 := (op1 & $7FFFFFFF) + 2147483648.0 + if baseType = cgUQuad then + CnvXULL(llop1, rop1) else - rop1 := op1; + CnvXLL(llop1, rop1); + end {if} + else begin {handle integer constants} + GetLongLongVal(llop1, op^.left^.token); + if op^.left^.token.kind = ulonglongconst then + extop1 := CnvULLX(llop1) + else + extop1 := CnvLLX(llop1); + rop1 := extop1; + if baseType in [cgExtended,cgComp] then + if rop1 <> extop1 then + goto 3; end; {else if} dispose(op^.left); op^.left := nil; @@ -1312,7 +1594,7 @@ var if tp^.cType = ctBool then op^.token.ival := ord(rop1 <> 0.0) else - op^.token.ival := long(op1).lsw; + op^.token.ival := long(llop1.lo).lsw; if baseType = cgByte then with op^.token do begin ival := ival & $00FF; @@ -1323,23 +1605,33 @@ var else if baseType = cgUWord then begin op^.token.kind := uintConst; op^.token.class := intConstant; - op^.token.ival := long(op1).lsw; + op^.token.ival := long(llop1.lo).lsw; end {else if} else if baseType = cgUByte then begin op^.token.kind := intConst; op^.token.class := intConstant; - op^.token.ival := long(op1).lsw; + op^.token.ival := long(llop1.lo).lsw; op^.token.ival := op^.token.ival & $00FF; end {else if} else if baseType = cgLong then begin op^.token.kind := longConst; op^.token.class := longConstant; - op^.token.lval := op1; + op^.token.lval := llop1.lo; end {else if} else if baseType = cgULong then begin op^.token.kind := ulongConst; op^.token.class := longConstant; - op^.token.lval := op1; + op^.token.lval := llop1.lo; + end {else if} + else if baseType = cgQuad then begin + op^.token.kind := longlongConst; + op^.token.class := longlongConstant; + op^.token.qval := llop1; + end {else if} + else if baseType = cgUQuad then begin + op^.token.kind := ulonglongConst; + op^.token.class := longlongConstant; + op^.token.qval := llop1; end {else if} else begin op^.token.kind := doubleConst; @@ -1347,20 +1639,18 @@ var op^.token.rval := rop1; end; {else if} end; {if} - end; {if} +3: end; {if} end; {if} end {else if castoper} else if not (op^.token.kind in [typedef,plusplusop,minusminusop,opplusplus,opminusminus,uand]) then begin - if (op^.left^.token.kind + if (kind <> preprocessorExpression) and (op^.left^.token.kind in [intconst,uintconst,longconst,ulongconst]) then begin {evaluate a constant operation} ekind := op^.left^.token.kind; - if kind = preprocessorExpression then - ekind := PPKind(op^.left^.token); op1 := IntVal(op^.left^.token); dispose(op^.left); op^.left := nil; @@ -1384,6 +1674,45 @@ var op^.token.ival := long(op1).lsw; end; {else} end {if} + else if op^.left^.token.kind in [longlongconst,ulonglongconst, + intconst,uintconst,longconst,ulongconst] then begin + + {evaluate a constant operation with long long operand} + ekind := op^.left^.token.kind; + if kind = preprocessorExpression then + ekind := PPKind(op^.left^.token); + GetLongLongVal(llop1, op^.left^.token); + dispose(op^.left); + op^.left := nil; + case op^.token.kind of + tildech : begin {~} + llop1.lo := ~llop1.lo; + llop1.hi := ~llop1.hi; + end; + excch : begin {!} + op1 := ord((llop1.hi = 0) and (llop1.lo = 0)); + ekind := intconst; + end; + uminus : begin {unary -} + llop1.lo := ~llop1.lo; + llop1.hi := ~llop1.hi; + llop1.lo := llop1.lo + 1; + if llop1.lo = 0 then + llop1.hi := llop1.hi + 1; + end; + uasterisk : Error(79); {unary *} + otherwise: Error(57); + end; {case} + op^.token.kind := ekind; + if ekind in [longlongconst,ulonglongconst] then begin + op^.token.class := longlongConstant; + op^.token.qval := llop1; + end {if} + else begin + op^.token.class := intConstant; + op^.token.ival := long(op1).lsw; + end; {else} + end {else if} else if op^.left^.token.kind = doubleconst then begin ekind := doubleconst; {evaluate a constant operation} rop1 := RealVal(op^.left^.token); @@ -1477,8 +1806,8 @@ if token.kind in startExpression then begin if op^.token.kind = castoper then if op^.casttype^.kind = scalarType then if op^.casttype^.baseType in [cgByte,cgUByte, - cgWord,cgUWord,cgLong,cgULong] then - goto 3; + cgWord,cgUWord,cgLong,cgULong,cgQuad,cgUQuad] + then goto 3; while op <> nil do begin if op^.token.kind = sizeofsy then goto 3; @@ -1733,6 +2062,8 @@ if expressionType^.kind = scalarType then begin Gen1t(pc_ldc, 0, cgWord); cgLong,cgULong: GenLdcLong(0); + cgQuad,cgUQuad: + GenLdcQuad(longlong0); cgReal,cgDouble,cgComp,cgExtended: GenLdcReal(0.0); otherwise: @@ -2089,10 +2420,12 @@ case tp of Gen0(op); end; end; - cgLong,cgULong: begin + cgLong,cgULong,cgQuad,cgUQuad: begin + if tp in [cgQuad,cgUQuad] then + Gen2(pc_cnv, ord(tp), ord(cgLong)); if size <> 1 then begin GenLdcLong(size); - if tp = cgLong then + if tp in [cgLong,cgQuad] then Gen0(pc_mpl) else Gen0(pc_uml); @@ -2340,6 +2673,14 @@ var Gen0(pc_sbl); end; + cgQuad,cgUQuad: begin + GenLdcQuad(longlong1); + if inc then + Gen0(pc_adq) + else + Gen0(pc_sbq); + end; + cgReal,cgDouble,cgComp,cgExtended: begin GenLdcReal(1.0); if inc then @@ -2382,7 +2723,7 @@ var if iType^.kind = scalarType then begin iSize := 1; baseType := iType^.baseType; - if (baseType in [cgReal,cgDouble,cgComp,cgExtended]) + if (baseType in [cgReal,cgDouble,cgComp,cgExtended,cgQuad,cgUQuad]) or (iType^.cType = ctBool) then begin {do real or bool inc or dec} @@ -2414,6 +2755,10 @@ var IncOrDec(pc_l = pc_lld); if iType^.cType = ctBool then expressionType := boolPtr + else if baseType = cgQuad then + expressionType := longLongPtr + else if baseType = cgUQuad then + expressionType := ulongLongPtr else expressionType := doublePtr; goto 1; @@ -2783,9 +3128,12 @@ var begin {CheckDivByZero} if opType^.kind = scalarType then - if opType^.baseType in [cgByte,cgWord,cgUByte,cgUWord,cgLong,cgULong] then + if opType^.baseType in + [cgByte,cgWord,cgUByte,cgUWord,cgLong,cgULong,cgQuad,cgUQuad] then if ((divisor.class = intConstant) and (divisor.ival = 0)) or ((divisor.class = longConstant) and (divisor.lval = 0)) + or ((divisor.class = longlongConstant) + and (divisor.qval.lo = 0) and (divisor.qval.hi = 0)) or ((divisor.class = doubleConstant) and (divisor.rval = 0.0)) then Error(129); end; {CheckDivByZero} @@ -2807,6 +3155,12 @@ var shiftCount := shiftCountTok.ival else if shiftCountTok.class = longConstant then shiftCount := shiftCountTok.lval + else if shiftCountTok.class = longlongConstant then begin + if shiftCountTok.qval.hi = 0 then + shiftCount := shiftCountTok.qval.lo + else + shiftCount := -1; + end {else if} else shiftCount := 0; @@ -2817,6 +3171,9 @@ var if opType^.baseType in [cgLong,cgULong] then if (shiftCount < 0) or (shiftCount > 31) then Error(130); + if opType^.baseType in [cgQuad,cgUQuad] then + if (shiftCount < 0) or (shiftCount > 63) then + Error(130); end; {if} end; {CheckShiftOverflow} @@ -2887,6 +3244,18 @@ case tree^.token.kind of lastconst := tree^.token.lval; end; {case longConst} + longlongConst,ulonglongConst: begin + GenLdcQuad(tree^.token.qval); + if tree^.token.kind = longlongConst then + expressionType := longlongPtr + else + expressionType := ulonglongPtr; + if (tree^.token.qval.hi = 0) and (tree^.token.qval.lo >= 0) then begin + lastwasconst := true; + lastconst := tree^.token.qval.lo; + end; {if} + end; {case longlongConst} + doubleConst: begin GenLdcReal(tree^.token.rval); expressionType := doublePtr; @@ -3019,10 +3388,17 @@ case tree^.token.kind of [cgReal,cgDouble,cgComp,cgExtended,cgVoid] then Error(66); et := UsualUnaryConversions; - if et <> Unary(ltype^.baseType) then begin - Gen2(pc_cnv, et, ord(Unary(ltype^.baseType))); + if ltype^.baseType in [cgQuad,cgUQuad] then begin + if not (et in [cgWord,cgUWord]) then begin + Gen2(pc_cnv, et, ord(cgWord)); + end; {if} expressionType := lType; - end; {if} + end {if} + else + if et <> Unary(ltype^.baseType) then begin + Gen2(pc_cnv, et, ord(Unary(ltype^.baseType))); + expressionType := lType; + end; {if} end; {if} if kind <> pointerType then et := UsualBinaryConversions(lType) @@ -3039,6 +3415,8 @@ case tree^.token.kind of Gen0(pc_adi) else if et in [cgLong,cgULong] then Gen0(pc_adl) + else if et in [cgQuad,cgUQuad] then + Gen0(pc_adq) else if et = cgExtended then Gen0(pc_adr) else @@ -3053,6 +3431,8 @@ case tree^.token.kind of Gen0(pc_sbi) else if et in [cgLong,cgULong] then Gen0(pc_sbl) + else if et in [cgQuad,cgUQuad] then + Gen0(pc_sbq) else if et = cgExtended then Gen0(pc_sbr) else @@ -3067,6 +3447,10 @@ case tree^.token.kind of Gen0(pc_mpl) else if et = cgULong then Gen0(pc_uml) + else if et = cgQuad then + Gen0(pc_mpq) + else if et = cgUQuad then + Gen0(pc_umq) else if et = cgExtended then Gen0(pc_mpr) else @@ -3081,6 +3465,10 @@ case tree^.token.kind of Gen0(pc_dvl) else if et = cgULong then Gen0(pc_udl) + else if et = cgQuad then + Gen0(pc_dvq) + else if et = cgUQuad then + Gen0(pc_udq) else if et = cgExtended then Gen0(pc_dvr) else @@ -3095,6 +3483,10 @@ case tree^.token.kind of Gen0(pc_mdl) else if et = cgULong then Gen0(pc_ulm) + else if et = cgQuad then + Gen0(pc_mdq) + else if et = cgUQuad then + Gen0(pc_uqm) else Error(66); @@ -3103,6 +3495,8 @@ case tree^.token.kind of Gen0(pc_shl) else if et in [cgLong,cgULong] then Gen0(pc_sll) + else if et in [cgQuad,cgUQuad] then + Gen0(pc_slq) else Error(66); @@ -3115,6 +3509,10 @@ case tree^.token.kind of Gen0(pc_slr) else if et = cgULong then Gen0(pc_vsr) + else if et = cgQuad then + Gen0(pc_sqr) + else if et = cgUQuad then + Gen0(pc_wsr) else Error(66); @@ -3123,6 +3521,8 @@ case tree^.token.kind of Gen0(pc_bnd) else if et in [cgLong,cgULong] then Gen0(pc_bal) + else if et in [cgQuad,cgUQuad] then + Gen0(pc_baq) else Error(66); @@ -3131,6 +3531,8 @@ case tree^.token.kind of Gen0(pc_bxr) else if et in [cgLong,cgULong] then Gen0(pc_blx) + else if et in [cgQuad,cgUQuad] then + Gen0(pc_bqx) else Error(66); @@ -3139,6 +3541,8 @@ case tree^.token.kind of Gen0(pc_bor) else if et in [cgLong,cgULong] then Gen0(pc_blr) + else if et in [cgQuad,cgUQuad] then + Gen0(pc_bqr) else Error(66); @@ -3189,20 +3593,36 @@ case tree^.token.kind of GenerateCode(tree^.left); if expressionType^.kind in [pointerType,arrayType] then expressionType := uLongPtr - else if UsualUnaryConversions = cgExtended then begin - GenLdcReal(0.0); - Gen0t(pc_neq, cgExtended); - expressionType := intPtr; - end; {if} + else begin + et := UsualUnaryConversions; + if et = cgExtended then begin + GenLdcReal(0.0); + Gen0t(pc_neq, cgExtended); + expressionType := intPtr; + end {if} + else if et in [cgQuad,cgUQuad] then begin + GenLdcQuad(longlong0); + Gen0t(pc_neq, et); + expressionType := intPtr; + end; {else if} + end; {else} lType := expressionType; GenerateCode(tree^.right); if expressionType^.kind in [pointerType,arrayType] then expressionType := uLongPtr - else if UsualUnaryConversions = cgExtended then begin - GenLdcReal(0.0); - Gen0t(pc_neq, cgExtended); - expressionType := intPtr; - end; {if} + else begin + et := UsualUnaryConversions; + if et = cgExtended then begin + GenLdcReal(0.0); + Gen0t(pc_neq, cgExtended); + expressionType := intPtr; + end {if} + else if et in [cgQuad,cgUQuad] then begin + GenLdcQuad(longlong0); + Gen0t(pc_neq, et); + expressionType := intPtr; + end; {else if} + end; {else} case UsualBinaryConversions(lType) of cgByte,cgUByte,cgWord,cgUWord: Gen0(pc_ior); @@ -3218,20 +3638,36 @@ case tree^.token.kind of GenerateCode(tree^.left); if expressionType^.kind in [pointerType,arrayType] then expressionType := uLongPtr - else if UsualUnaryConversions = cgExtended then begin - GenLdcReal(0.0); - Gen0t(pc_neq, cgExtended); - expressionType := intPtr; - end; {if} + else begin + et := UsualUnaryConversions; + if et = cgExtended then begin + GenLdcReal(0.0); + Gen0t(pc_neq, cgExtended); + expressionType := intPtr; + end {if} + else if et in [cgQuad,cgUQuad] then begin + GenLdcQuad(longlong0); + Gen0t(pc_neq, et); + expressionType := intPtr; + end; {else if} + end; {else} lType := expressionType; GenerateCode(tree^.right); if expressionType^.kind in [pointerType,arrayType] then expressionType := uLongPtr - else if UsualUnaryConversions = cgExtended then begin - GenLdcReal(0.0); - Gen0t(pc_neq, cgExtended); - expressionType := intPtr; - end; {if} + else begin + et := UsualUnaryConversions; + if et = cgExtended then begin + GenLdcReal(0.0); + Gen0t(pc_neq, cgExtended); + expressionType := intPtr; + end {if} + else if et in [cgQuad,cgUQuad] then begin + GenLdcQuad(longlong0); + Gen0t(pc_neq, et); + expressionType := intPtr; + end; {else if} + end; {else} case UsualBinaryConversions(lType) of cgByte,cgUByte,cgWord,cgUWord: Gen0(pc_and); @@ -3254,6 +3690,8 @@ case tree^.token.kind of Gen0(pc_bxr); cgLong,cgULong: Gen0(pc_blx); + cgQuad,cgUQuad: + Gen0(pc_bqx); otherwise: error(66); end; {case} @@ -3270,6 +3708,8 @@ case tree^.token.kind of Gen0(pc_bor); cgLong,cgULong: Gen0(pc_blr); + cgQuad,cgUQuad: + Gen0(pc_bqr); otherwise: error(66); end; {case} @@ -3286,6 +3726,8 @@ case tree^.token.kind of Gen0(pc_bnd); cgLong,cgULong: Gen0(pc_bal); + cgQuad,cgUQuad: + Gen0(pc_baq); otherwise: error(66); end; {case} @@ -3300,15 +3742,22 @@ case tree^.token.kind of GenerateCode(tree^.right); if (expressionType^.kind <> scalarType) or not (expressionType^.baseType in - [cgByte,cgUByte,cgWord,cgUWord,cgLong,cgULong]) then + [cgByte,cgUByte,cgWord,cgUWord,cgLong,cgULong,cgQuad,cgUQuad]) then error(66); - if expressionType^.baseType <> et then - Gen2(pc_cnv, ord(expressionType^.baseType), ord(et)); + if et in [cgQuad,cgUQuad] then begin + if not (expressionType^.baseType in [cgWord,cgUWord]) then + Gen2(pc_cnv, ord(expressionType^.baseType), ord(cgWord)); + end {if} + else + if expressionType^.baseType <> et then + Gen2(pc_cnv, ord(expressionType^.baseType), ord(et)); case et of cgByte,cgUByte,cgWord,cgUWord: Gen0(pc_shl); cgLong,cgULong: Gen0(pc_sll); + cgQuad,cgUQuad: + Gen0(pc_slq); otherwise: error(66); end; {case} @@ -3326,10 +3775,15 @@ case tree^.token.kind of GenerateCode(tree^.right); if (expressionType^.kind <> scalarType) or not (expressionType^.baseType in - [cgByte,cgUByte,cgWord,cgUWord,cgLong,cgULong]) then + [cgByte,cgUByte,cgWord,cgUWord,cgLong,cgULong,cgQuad,cgUQuad]) then error(66); - if expressionType^.baseType <> et then - Gen2(pc_cnv, ord(expressionType^.baseType), ord(et)); + if et in [cgQuad,cgUQuad] then begin + if not (expressionType^.baseType in [cgWord,cgUWord]) then + Gen2(pc_cnv, ord(expressionType^.baseType), ord(cgWord)); + end {if} + else + if expressionType^.baseType <> et then + Gen2(pc_cnv, ord(expressionType^.baseType), ord(et)); case et of cgByte,cgWord: Gen0(pc_shr); @@ -3339,6 +3793,10 @@ case tree^.token.kind of Gen0(pc_slr); cgULong: Gen0(pc_vsr); + cgQuad: + Gen0(pc_sqr); + cgUQuad: + Gen0(pc_wsr); otherwise: error(66); end; {case} @@ -3386,6 +3844,8 @@ case tree^.token.kind of Gen0(pc_adi); cgLong,cgULong: Gen0(pc_adl); + cgQuad,cgUQuad: + Gen0(pc_adq); cgExtended: Gen0(pc_adr); otherwise: @@ -3442,6 +3902,8 @@ case tree^.token.kind of Gen0(pc_sbi); cgLong,cgULong: Gen0(pc_sbl); + cgQuad,cgUQuad: + Gen0(pc_sbq); cgExtended: Gen0(pc_sbr); otherwise: @@ -3465,6 +3927,10 @@ case tree^.token.kind of Gen0(pc_mpl); cgULong: Gen0(pc_uml); + cgQuad: + Gen0(pc_mpq); + cgUQuad: + Gen0(pc_umq); cgExtended: Gen0(pc_mpr); otherwise: @@ -3487,6 +3953,10 @@ case tree^.token.kind of Gen0(pc_dvl); cgULong: Gen0(pc_udl); + cgQuad: + Gen0(pc_dvq); + cgUQuad: + Gen0(pc_udq); cgExtended: Gen0(pc_dvr); otherwise: @@ -3511,6 +3981,10 @@ case tree^.token.kind of Gen0(pc_mdl); cgULong: Gen0(pc_ulm); + cgQuad: + Gen0(pc_mdq); + cgUQuad: + Gen0(pc_uqm); otherwise: error(66); end; {case} @@ -3561,6 +4035,8 @@ case tree^.token.kind of Gen0(pc_ngi); cgLong,cgULong: Gen0(pc_ngl); + cgQuad,cgUQuad: + Gen0(pc_ngq); cgExtended: Gen0(pc_ngr); otherwise: @@ -3577,6 +4053,8 @@ case tree^.token.kind of Gen0(pc_bnt); cgLong,cgULong: Gen0(pc_bnl); + cgQuad,cgUQuad: + Gen0(pc_bnq); otherwise: error(66); end; {case} @@ -3596,6 +4074,11 @@ case tree^.token.kind of Gen0t(pc_equ, cgLong); end; + cgQuad,cgUQuad: begin + GenLdcQuad(longlong0); + Gen0t(pc_equ, cgQuad); + end; + cgExtended: begin GenLdcReal(0.0); Gen0t(pc_equ, cgExtended); @@ -3817,6 +4300,9 @@ if kind = normalExpression then begin {generate code from the expression tree} else begin {record the expression for an initializer} initializerTree := tree; isConstant := false; + llExpressionValue.lo := 0; + llExpressionValue.hi := 0; + expressionIsLongLong := false; if errorFound then begin DisposeTree(initializerTree); initializerTree := nil; @@ -3872,6 +4358,29 @@ else begin {record the expression for an initialize expressionType := ulongPtr; isConstant := true; end {else if} + else if tree^.token.kind = longlongconst then begin + llExpressionValue := tree^.token.qval; + expressionIsLongLong := true; + if ((llExpressionValue.hi = 0) and (llExpressionValue.lo >= 0)) + or ((llExpressionValue.hi = -1) and (llExpressionValue.lo < 0)) then + expressionValue := llExpressionValue.lo + else if llExpressionValue.hi < 0 then + expressionValue := $80000000 + else + expressionValue := $7fffffff; + expressionType := longLongPtr; + isConstant := true; + end {else if} + else if tree^.token.kind = ulonglongconst then begin + llExpressionValue := tree^.token.qval; + expressionIsLongLong := true; + if llExpressionValue.hi = 0 then + expressionValue := llExpressionValue.lo + else + expressionValue := $FFFFFFFF; + expressionType := ulongLongPtr; + isConstant := true; + end {else if} else if tree^.token.kind = doubleconst then begin realExpressionValue := tree^.token.rval; expressionType := extendedPtr; @@ -3902,13 +4411,32 @@ else begin {record the expression for an initialize end; {Expression} +procedure GetLLExpressionValue {var val: longlong}; + +{ get the value of the last integer constant expression as a } +{ long long (whether it had long long type or not). } + +begin {GetLLExpressionValue} + if expressionIsLongLong then + val := llExpressionValue + else begin + val.lo := expressionValue; + val.hi := 0; + if expressionValue < 0 then + if expressionType^.kind = scalarType then + if expressionType^.baseType in [cgByte,cgWord,cgLong] then + val.hi := -1; + end; +end; {GetLLExpressionValue} + + procedure InitExpression; { initialize the expression handler } begin {InitExpression} -startTerm := [ident,intconst,uintconst,longconst,ulongconst,doubleconst, - stringconst,_Genericsy]; +startTerm := [ident,intconst,uintconst,longconst,ulongconst,longlongconst, + ulonglongconst,doubleconst,stringconst,_Genericsy]; startExpression:= startTerm + [lparench,asteriskch,andch,plusch,minusch,excch,tildech,sizeofsy, plusplusop,minusminusop,typedef,_Alignofsy]; diff --git a/Gen.pas b/Gen.pas index 88e1c68..ab572ef 100644 --- a/Gen.pas +++ b/Gen.pas @@ -39,12 +39,15 @@ procedure Gen (blk: blockPtr); implementation const - A_X = 1; {longword locations} + {longword/quadword locations} + A_X = 1; {longword only} onStack = 2; inPointer = 4; localAddress = 8; globalLabel = 16; constant = 32; + nowhere = 64; + inStackLoc = 128; {stack frame locations} {---------------------} @@ -53,20 +56,32 @@ const type {possible locations for 4 byte values} longType = record {description of current four byte value} - preference: integer; {where you want the value} + preference: integer; {where you want the value (bitmask)} where: integer; {where the value is at} fixedDisp: boolean; {is the displacement a fixed value?} isLong: boolean; {is long addr required for named labs?} disp: integer; {fixed displacement/local addr} lval: longint; {value} lab: stringPtr; {global label name} + end; + {possible locations for 8 byte values} + {note: these always have fixed disp} + quadType = record {description of current 8 byte value} + preference: integer; {where you want the value (single value)} + where: integer; {where the value is at} + disp: integer; {fixed displacement/local addr} + lval: longlong; {value} + lab: stringPtr; {global label name} end; var gLong: longType; {info about last long value} + gQuad: quadType; {info about last quad value} namePushed: boolean; {has a name been pushed in this proc?} skipLoad: boolean; {skip load for a pc_lli, etc?} stackSaveDepth: integer; {nesting depth of saved stack positions} + argsSize: integer; {total size of argument to a function} + isQuadFunction: boolean; {is the return type cg(U)Quad?} {stack frame locations} {---------------------} @@ -224,6 +239,207 @@ else {if icode^.opcode in [pc_ldo, pc_sro] then} end; {DoOp} +procedure OpOnWordOfQuad (mop: integer; op: icptr; offset: integer); + +{ Do an operation that has addr modes equivalent to LDA on the } +{ subword at specified offset of the location specified by op. } +{ } +{ The generated code may modify X, and may set Y to offset. } +{ } +{ parameters: } +{ mop - machine opcode } +{ op - node to generate the leaf for } +{ offset - offset of the word to access (0, 2, 4, or 6) } + +var + loc: integer; {stack frame position} + val: integer; {immediate value} + +begin {OpOnWordOfQuad} +case op^.opcode of + + pc_ldo: begin + case mop of + m_lda_imm: mop := m_lda_abs; + m_cmp_imm: mop := m_cmp_abs; + m_adc_imm: mop := m_adc_abs; + m_and_imm: mop := m_and_abs; + m_ora_imm: mop := m_ora_abs; + m_sbc_imm: mop := m_sbc_abs; + m_eor_imm: mop := m_eor_abs; + otherwise: Error(cge1); + end; {case} + if smallMemoryModel then + GenNative(mop, absolute, op^.q+offset, op^.lab, 0) + else + GenNative(mop+2, longAbs, op^.q+offset, op^.lab, 0); + end; {case pc_ldo} + + pc_lod: begin + case mop of + m_lda_imm: mop := m_lda_dir; + m_cmp_imm: mop := m_cmp_dir; + m_adc_imm: mop := m_adc_dir; + m_and_imm: mop := m_and_dir; + m_ora_imm: mop := m_ora_dir; + m_sbc_imm: mop := m_sbc_dir; + m_eor_imm: mop := m_eor_dir; + otherwise: Error(cge1); + end; {case} + loc := LabelToDisp(op^.r) + op^.q + offset; + if loc < 256 then + GenNative(mop, direct, loc, nil, 0) + else begin + GenNative(m_ldx_imm, immediate, loc, nil, 0); + GenNative(mop+$10, direct, 0, nil, 0); + end; {else} + end; {case pc_lod} + + pc_ldc: begin + case offset of + 0: val := long(op^.qval.lo).lsw; + 2: val := long(op^.qval.lo).msw; + 4: val := long(op^.qval.hi).lsw; + 6: val := long(op^.qval.hi).msw; + otherwise: Error(cge1); + end; {case} + GenNative(mop, immediate, val, nil, 0); + end; {case pc_ldc} + + pc_ind: begin + case mop of + m_lda_imm: mop := m_lda_indl; + m_cmp_imm: mop := m_cmp_indl; + m_adc_imm: mop := m_adc_indl; + m_and_imm: mop := m_and_indl; + m_ora_imm: mop := m_ora_indl; + m_sbc_imm: mop := m_sbc_indl; + m_eor_imm: mop := m_eor_indl; + otherwise: Error(cge1); + end; {case} + if op^.left^.opcode = pc_lod then + loc := LabelToDisp(op^.left^.r) + op^.left^.q; + if (op^.left^.opcode <> pc_lod) or (loc > 255) then + Error(cge1); + if offset = 0 then + GenNative(mop, direct, loc, nil, 0) + else begin + GenNative(m_ldy_imm, immediate, offset, nil, 0); + GenNative(mop+$10, direct, loc, nil, 0); + end; {else} + end; {case pc_ind} + + otherwise: + Error(cge1); + end; {case} +end; {OpOnWordOfQuad} + + +function SimpleQuadLoad(op: icptr): boolean; + +{ Is op a simple load operation on a cg(U)Quad, which can be } +{ broken up into word operations handled by OpOnWordOfQuad? } +{ } +{ parameters: } +{ op - node to check } + +begin {SimpleQuadLoad} +case op^.opcode of + pc_ldo,pc_lod,pc_ldc: + SimpleQuadLoad := true; + + pc_ind: + SimpleQuadLoad := + (op^.left^.opcode = pc_lod) + and (LabelToDisp(op^.left^.r) + op^.left^.q < 256); + + otherwise: + SimpleQuadLoad := false; + end; {case} +end; {SimpleQuadLoad} + + +function SimplestQuadLoad(op: icptr): boolean; + +{ Is op a simple load operation on a cg(U)Quad, which can be } +{ broken up into word operations handled by OpOnWordOfQuad } +{ and for which those operations will not modify X or Y. } +{ } +{ parameters: } +{ op - node to check } + +begin {SimplestQuadLoad} +case op^.opcode of + pc_ldo,pc_ldc: + SimplestQuadLoad := true; + + pc_lod: + SimplestQuadLoad := LabelToDisp(op^.r) + op^.q < 250; + + pc_ind,otherwise: + SimplestQuadLoad := false; + end; {case} +end; {SimplestQuadLoad} + + +procedure StoreWordOfQuad(offset: integer); + +{ Store one word of a quad value to the location specified by } +{ gQuad.preference. The word value to store must be in A. } +{ } +{ The generated code may modify X, and may set Y to offset. } +{ It does not modify A or the carry flag. } +{ } +{ parameters: } +{ offset - offset of the word to store (0, 2, 4, or 6) } +{ } +{ Note: If gQuad.preference is onStack, this just generates a } +{ PHA. That is suitable if loading a value starting from } +{ the most significant word, but not in other cases. For } +{ other gQuad.preference values, any order is okay. } + +begin {StoreWordOfQuad} +case gQuad.preference of + localAddress: begin + if gQuad.disp+offset <= 255 then + GenNative(m_sta_dir, direct, gQuad.disp+offset, nil, 0) + else begin + GenNative(m_ldx_imm, immediate, gQuad.disp+offset, nil, 0); + GenNative(m_sta_dirX, direct, 0, nil, 0); + end; {else} + end; + + globalLabel: begin + if smallMemoryModel then + GenNative(m_sta_abs, absolute, gQuad.disp+offset, gQuad.lab, 0) + else + GenNative(m_sta_long, longabsolute, gQuad.disp+offset, gQuad.lab, 0); + end; + + inPointer: begin + if (gQuad.disp > 255) or (gQuad.disp < 0) then + Error(cge1); + if offset = 0 then + GenNative(m_sta_indl, direct, gQuad.disp, nil, 0) + else begin + GenNative(m_ldy_imm, immediate, offset, nil, 0); + GenNative(m_sta_indly, direct, gQuad.disp, nil, 0); + end; {else} + end; + + inStackLoc: + GenNative(m_sta_s, direct, gQuad.disp+offset, nil, 0); + + onStack: + GenImplied(m_pha); + + nowhere: ; {discard the value} + + otherwise: Error(cge1); + end; {case} +end; {StoreWordOfQuad} + + procedure GetPointer (op: icptr); { convert a tree into a usable pointer for indirect } @@ -679,6 +895,109 @@ else begin end; {GenAdlSbl} +procedure GenAdqSbq (op: icptr); + +{ generate code for pc_adq, pc_sbq } +{ } +{ parameters: } +{ op - pc_adq or pc_sbq operation } + +begin {GenAdqSbq} +if op^.opcode = pc_adq then begin + if SimpleQuadLoad(op^.left) and SimpleQuadLoad(op^.right) then begin + gQuad.where := gQuad.preference; + if gQuad.preference = onStack then begin + GenImplied(m_tsc); + GenImplied(m_sec); + GenNative(m_sbc_imm, immediate, 8, nil, 0); + GenImplied(m_tcs); + gQuad.preference := inStackLoc; + gQuad.disp := 1; + end; {if} + GenImplied(m_clc); + OpOnWordOfQuad(m_lda_imm, op^.left, 0); + OpOnWordOfQuad(m_adc_imm, op^.right, 0); + StoreWordOfQuad(0); + OpOnWordOfQuad(m_lda_imm, op^.left, 2); + OpOnWordOfQuad(m_adc_imm, op^.right, 2); + StoreWordOfQuad(2); + OpOnWordOfQuad(m_lda_imm, op^.left, 4); + OpOnWordOfQuad(m_adc_imm, op^.right, 4); + StoreWordOfQuad(4); + OpOnWordOfQuad(m_lda_imm, op^.left, 6); + OpOnWordOfQuad(m_adc_imm, op^.right, 6); + StoreWordOfQuad(6); + end {if} + else begin + gQuad.preference := onStack; + GenTree(op^.right); + gQuad.preference := onStack; + GenTree(op^.left); + GenImplied(m_clc); + GenImplied(m_pla); + GenNative(m_adc_s, direct, 7, nil, 0); + GenNative(m_sta_s, direct, 7, nil, 0); + GenImplied(m_pla); + GenNative(m_adc_s, direct, 7, nil, 0); + GenNative(m_sta_s, direct, 7, nil, 0); + GenImplied(m_pla); + GenNative(m_adc_s, direct, 7, nil, 0); + GenNative(m_sta_s, direct, 7, nil, 0); + GenImplied(m_pla); + GenNative(m_adc_s, direct, 7, nil, 0); + GenNative(m_sta_s, direct, 7, nil, 0); + gQuad.where := onStack; + end; {else} + end {if} +else {if op^.opcode = pc_sbq then} begin + if SimpleQuadLoad(op^.left) and SimpleQuadLoad(op^.right) then begin + gQuad.where := gQuad.preference; + if gQuad.preference = onStack then begin + GenImplied(m_tsc); + GenImplied(m_sec); + GenNative(m_sbc_imm, immediate, 8, nil, 0); + GenImplied(m_tcs); + gQuad.preference := inStackLoc; + gQuad.disp := 1; + end; {if} + GenImplied(m_sec); + OpOnWordOfQuad(m_lda_imm, op^.left, 0); + OpOnWordOfQuad(m_sbc_imm, op^.right, 0); + StoreWordOfQuad(0); + OpOnWordOfQuad(m_lda_imm, op^.left, 2); + OpOnWordOfQuad(m_sbc_imm, op^.right, 2); + StoreWordOfQuad(2); + OpOnWordOfQuad(m_lda_imm, op^.left, 4); + OpOnWordOfQuad(m_sbc_imm, op^.right, 4); + StoreWordOfQuad(4); + OpOnWordOfQuad(m_lda_imm, op^.left, 6); + OpOnWordOfQuad(m_sbc_imm, op^.right, 6); + StoreWordOfQuad(6); + end {if} + else begin + gQuad.preference := onStack; + GenTree(op^.right); + gQuad.preference := onStack; + GenTree(op^.left); + GenImplied(m_sec); + GenImplied(m_pla); + GenNative(m_sbc_s, direct, 7, nil, 0); + GenNative(m_sta_s, direct, 7, nil, 0); + GenImplied(m_pla); + GenNative(m_sbc_s, direct, 7, nil, 0); + GenNative(m_sta_s, direct, 7, nil, 0); + GenImplied(m_pla); + GenNative(m_sbc_s, direct, 7, nil, 0); + GenNative(m_sta_s, direct, 7, nil, 0); + GenImplied(m_pla); + GenNative(m_sbc_s, direct, 7, nil, 0); + GenNative(m_sta_s, direct, 7, nil, 0); + gQuad.where := onStack; + end; {else} + end; {else} +end; {GenAdqSbq} + + procedure GenCmp (op: icptr; rOpcode: pcodes; lb: integer); { generate code for pc_les, pc_leq, pc_grt or pc_geq } @@ -696,6 +1015,7 @@ var i: integer; {loop variable} lab1,lab2,lab3,lab4: integer; {label numbers} num: integer; {constant to compare to} + simple: boolean; {is this a simple case?} procedure Switch; @@ -1115,6 +1435,115 @@ else end; {if} end; {case optype of cgLong} + cgQuad: begin + if op^.opcode = pc_geq then begin + gQuad.preference := onStack; + GenTree(op^.left); + gQuad.preference := onStack; + GenTree(op^.right); + end {if} + else {if op^.opcode = pc_grt then} begin + gQuad.preference := onStack; + GenTree(op^.right); + gQuad.preference := onStack; + GenTree(op^.left); + end; {else} + GenCall(88); + if (rOpcode = pc_fjp) or (rOpcode = pc_tjp) then begin + lab1 := GenLabel; + if (rOpcode = pc_fjp) <> (op^.opcode = pc_grt) then + GenNative(m_bcs, relative, lab1, nil, 0) + else + GenNative(m_bcc, relative, lab1, nil, 0); + GenNative(m_brl, longrelative, lb, nil, 0); + GenLab(lab1); + end {if} + else begin + lab1 := GenLabel; + GenNative(m_lda_imm, immediate, 1, nil, 0); + if op^.opcode = pc_geq then + GenNative(m_bcs, relative, lab1, nil, 0) + else + GenNative(m_bcc, relative, lab1, nil, 0); + GenImplied(m_dea); + GenLab(lab1); + end; {else} + end; {case optype of cgQuad} + + cgUQuad: begin + simple := + SimplestQuadLoad(op^.left) and SimplestQuadLoad(op^.right) + and not volatile; + if not simple then begin + gQuad.preference := onStack; + GenTree(op^.left); + gQuad.preference := onStack; + GenTree(op^.right); + end; {if} + if op^.opcode = pc_geq then + GenNative(m_ldx_imm, immediate, 1, nil, 0) + else {if op^.opcode = pc_grt then} + GenNative(m_ldx_imm, immediate, 0, nil, 0); + lab1 := GenLabel; + lab2 := GenLabel; + if simple then begin + OpOnWordOfQuad(m_lda_imm, op^.left, 6); + OpOnWordOfQuad(m_cmp_imm, op^.right, 6); + GenNative(m_bne, relative, lab1, nil, 0); + OpOnWordOfQuad(m_lda_imm, op^.left, 4); + OpOnWordOfQuad(m_cmp_imm, op^.right, 4); + GenNative(m_bne, relative, lab1, nil, 0); + OpOnWordOfQuad(m_lda_imm, op^.left, 2); + OpOnWordOfQuad(m_cmp_imm, op^.right, 2); + GenNative(m_bne, relative, lab1, nil, 0); + OpOnWordOfQuad(m_lda_imm, op^.left, 0); + OpOnWordOfQuad(m_cmp_imm, op^.right, 0); + end {if} + else begin + GenNative(m_lda_s, direct, 15, nil, 0); + GenNative(m_cmp_s, direct, 7, nil, 0); + GenNative(m_bne, relative, lab1, nil, 0); + GenNative(m_lda_s, direct, 13, nil, 0); + GenNative(m_cmp_s, direct, 5, nil, 0); + GenNative(m_bne, relative, lab1, nil, 0); + GenNative(m_lda_s, direct, 11, nil, 0); + GenNative(m_cmp_s, direct, 3, nil, 0); + GenNative(m_bne, relative, lab1, nil, 0); + GenNative(m_lda_s, direct, 9, nil, 0); + GenNative(m_cmp_s, direct, 1, nil, 0); + end; {else} + GenLab(lab1); + if op^.opcode = pc_geq then begin + GenNative(m_bcs, relative, lab2, nil, 0); + GenImplied(m_dex); + end {if} + else begin {if op^.opcode = pc_grt then} + GenNative(m_bcc, relative, lab2, nil, 0); + GenNative(m_beq, relative, lab2, nil, 0); + GenImplied(m_inx); + end; {else} + GenLab(lab2); + if not simple then begin + GenImplied(m_tsc); + GenImplied(m_clc); + GenNative(m_adc_imm, immediate, 16, nil, 0); + GenImplied(m_tcs); + end; {if} + GenImplied(m_txa); + if rOpcode = pc_fjp then begin + lab3 := GenLabel; + GenNative(m_bne, relative, lab3, nil, 0); + GenNative(m_brl, longrelative, lb, nil, 0); + GenLab(lab3); + end {if} + else if rOpcode = pc_tjp then begin + lab3 := GenLabel; + GenNative(m_beq, relative, lab3, nil, 0); + GenNative(m_brl, longrelative, lb, nil, 0); + GenLab(lab3); + end; {else if} + end; {case optype of cgUQuad} + otherwise: Error(cge1); end; {case} @@ -1132,33 +1561,45 @@ const {note: these constants list all legal } cComp = $08; cExtended = $09; cVoid = $0B; + cLong = $04; + cULong = $05; byteToWord = $02; byteToUword = $03; byteToLong = $04; byteToUlong = $05; + byteToQuad = $0C; + byteToUQuad = $0D; byteToReal = $06; byteToDouble = $07; ubyteToLong = $14; ubyteToUlong = $15; + ubyteToQuad = $1C; + ubyteToUQuad = $1D; ubyteToReal = $16; ubyteToDouble = $17; wordToByte = $20; wordToUByte = $21; wordToLong = $24; wordToUlong = $25; + wordToQuad = $2C; + wordToUQuad = $2D; wordToReal = $26; wordToDouble = $27; uwordToByte = $30; uwordToUByte = $31; uwordToLong = $34; uwordToUlong = $35; + uwordToQuad = $3C; + uwordToUQuad = $3D; uwordToReal = $36; uwordToDouble = $37; longTobyte = $40; longToUbyte = $41; longToWord = $42; longToUword = $43; + longToQuad = $4C; + longToUQuad = $4D; longToReal = $46; longToDouble = $47; longToVoid = $4B; @@ -1166,6 +1607,8 @@ const {note: these constants list all legal } ulongToUbyte = $51; ulongToWord = $52; ulongToUword = $53; + ulongToQuad = $5C; + ulongToUQuad = $5D; ulongToReal = $56; ulongToDouble = $57; ulongToVoid = $5B; @@ -1175,6 +1618,8 @@ const {note: these constants list all legal } realToUword = $63; realToLong = $64; realToUlong = $65; + realToQuad = $6C; + realToUQuad = $6D; realToVoid = $6B; doubleTobyte = $70; doubleToUbyte = $71; @@ -1182,6 +1627,26 @@ const {note: these constants list all legal } doubleToUword = $73; doubleToLong = $74; doubleToUlong = $75; + doubleToQuad = $7C; + doubleToUQuad = $7D; + quadToByte = $C0; + quadToUByte = $C1; + quadToWord = $C2; + quadToUword = $C3; + quadToLong = $C4; + quadToULong = $C5; + quadToReal = $C6; + quadToDouble = $C7; + quadToVoid = $CB; + uquadToByte = $D0; + uquadToUByte = $D1; + uquadToWord = $D2; + uquadToUword = $D3; + uquadToLong = $D4; + uquadToULong = $D5; + uquadToReal = $D6; + uquadToDouble = $D7; + uquadToVoid = $DB; var fromReal: boolean; {are we converting from a real?} @@ -1192,6 +1657,10 @@ begin {GenCnv} lLong := gLong; gLong.preference := onStack+A_X+constant; gLong.where := onStack; +if op^.q in [quadToVoid,uQuadToVoid] then + gQuad.preference := nowhere +else + gQuad.preference := onStack; if ((op^.q & $00F0) >> 4) in [cDouble,cExtended,cComp] then begin op^.q := (op^.q & $000F) | (cReal * 16); fromReal := true; @@ -1231,14 +1700,14 @@ else if op^.q in [byteToLong,byteToUlong] then begin GenImplied(m_phx); GenImplied(m_pha); end; {else} - end {if} + end {else if} else if op^.q in [byteToWord,byteToUword] then begin lab1 := GenLabel; GenNative(m_bit_imm, immediate, $0080, nil, 0); GenNative(m_beq, relative, lab1, nil, 0); GenNative(m_ora_imm, immediate, $FF00, nil, 0); GenLab(lab1); - end {if} + end {else if} else if op^.q in [ubyteToLong,ubyteToUlong,uwordToLong,uwordToUlong] then begin if (lLong.preference & A_X) <> 0 then begin @@ -1316,8 +1785,8 @@ else if op^.q in [longToReal,uLongToReal] then begin GenCall(12) else GenCall(13); - end {else} -else if op^.q =realToWord then + end {else if} +else if op^.q = realToWord then GenCall(14) else if op^.q = realToUbyte then begin GenCall(14); @@ -1360,19 +1829,171 @@ else if op^.q in [longToVoid,ulongToVoid] then begin gLong.where := A_X; end; {if} end {else if} -else if (op^.q & $000F) = cVoid then - {do nothing} -else if lLong.preference & gLong.where = 0 then begin - if gLong.where = constant then begin - GenNative(m_pea, immediate, long(gLong.lval).msw, nil, 0); - GenNative(m_pea, immediate, long(gLong.lval).lsw, nil, 0); - end {if} - else if gLong.where = A_X then begin +else if op^.q in [ubyteToQuad,ubyteToUQuad,uwordToQuad,uwordToUQuad] then begin + GenNative(m_ldy_imm, immediate, 0, nil, 0); + GenImplied(m_phy); + GenImplied(m_phy); + GenImplied(m_phy); + GenImplied(m_pha); + gQuad.where := onStack; + end {else if} +else if op^.q in [byteToQuad,byteToUQuad] then begin + lab1 := GenLabel; + GenNative(m_ldx_imm, immediate, 0, nil, 0); + GenNative(m_bit_imm, immediate, $0080, nil, 0); + GenNative(m_beq, relative, lab1, nil, 0); + GenImplied(m_dex); + GenNative(m_ora_imm, immediate, $FF00, nil, 0); + GenLab(lab1); + GenImplied(m_phx); + GenImplied(m_phx); + GenImplied(m_phx); + GenImplied(m_pha); + gQuad.where := onStack; + end {else if} +else if op^.q in [wordToQuad,wordToUQuad] then begin + lab1 := GenLabel; + GenNative(m_ldx_imm, immediate, 0, nil, 0); + GenImplied(m_tay); + GenNative(m_bpl, relative, lab1, nil, 0); + GenImplied(m_dex); + GenLab(lab1); + GenImplied(m_phx); + GenImplied(m_phx); + GenImplied(m_phx); + GenImplied(m_pha); + gQuad.where := onStack; + end {else if} +else if op^.q in [ulongToQuad,ulongToUQuad] then begin + if gLong.where = A_X then begin + GenNative(m_pea, immediate, 0, nil, 0); + GenNative(m_pea, immediate, 0, nil, 0); GenImplied(m_phx); GenImplied(m_pha); - end; {else if} - gLong.where := onStack; - end; {else if} + end {if} + else if gLong.where = constant then begin + GenNative(m_pea, immediate, 0, nil, 0); + GenNative(m_pea, immediate, 0, nil, 0); + GenNative(m_pea, immediate, long(gLong.lval).msw, nil, 0); + GenNative(m_pea, immediate, long(gLong.lval).lsw, nil, 0); + end {else if} + else {if gLong.where = onStack then} begin + GenImplied(m_pla); + GenImplied(m_plx); + GenNative(m_pea, immediate, 0, nil, 0); + GenNative(m_pea, immediate, 0, nil, 0); + GenImplied(m_phx); + GenImplied(m_pha); + end; {else} + gQuad.where := onStack; + end {else if} +else if op^.q in [longToQuad,longToUQuad] then begin + if gLong.where = constant then begin + if glong.lval < 0 then begin + GenNative(m_pea, immediate, -1, nil, 0); + GenNative(m_pea, immediate, -1, nil, 0); + GenNative(m_pea, immediate, long(gLong.lval).msw, nil, 0); + GenNative(m_pea, immediate, long(gLong.lval).lsw, nil, 0); + end {if} + else begin + GenNative(m_pea, immediate, 0, nil, 0); + GenNative(m_pea, immediate, 0, nil, 0); + GenNative(m_pea, immediate, long(gLong.lval).msw, nil, 0); + GenNative(m_pea, immediate, long(gLong.lval).lsw, nil, 0); + end; {else} + end {if} + else begin + GenNative(m_ldy_imm, immediate, 0, nil, 0); + if gLong.where = onStack then begin + GenImplied(m_pla); + GenImplied(m_plx); + end {if} + else {if gLong.where = A_X then} + GenNative(m_cpx_imm, immediate, 0, nil, 0); + lab1 := GenLabel; + GenNative(m_bpl, relative, lab1, nil, 0); + GenImplied(m_dey); + GenLab(lab1); + GenImplied(m_phy); + GenImplied(m_phy); + GenImplied(m_phx); + GenImplied(m_pha); + end; {else} + gQuad.where := onStack; + end {else if} +else if op^.q = realToQuad then begin + GenCall(89); + gQuad.where := onStack; + end {else if} +else if op^.q = realToUQuad then begin + GenCall(90); + gQuad.where := onStack; + end {else if} +else if op^.q in [quadToWord,uquadToWord,quadToUWord,uquadToUWord] then begin + GenImplied(m_pla); + GenImplied(m_plx); + GenImplied(m_ply); + GenImplied(m_ply); + GenImplied(m_tay); + end {else if} +else if op^.q in [quadToUByte,uquadToUByte] then begin + GenImplied(m_pla); + GenImplied(m_plx); + GenImplied(m_ply); + GenImplied(m_ply); + GenNative(m_and_imm, immediate, $00FF, nil, 0); + end {else if} +else if op^.q in [quadToByte,uquadToByte] then begin + GenImplied(m_pla); + GenImplied(m_plx); + GenImplied(m_ply); + GenImplied(m_ply); + GenNative(m_and_imm, immediate, $00FF, nil, 0); + lab1 := GenLabel; + GenNative(m_bit_imm, immediate, $0080, nil, 0); + GenNative(m_beq, relative, lab1, nil, 0); + GenNative(m_ora_imm, immediate, $FF00, nil, 0); + GenLab(lab1); + end {else if} +else if op^.q in [quadToLong,uquadToLong,quadToULong,uquadToULong] then begin + GenImplied(m_pla); + GenImplied(m_plx); + GenImplied(m_ply); + GenImplied(m_ply); + if (lLong.preference & A_X) <> 0 then + gLong.where := A_X + else begin + gLong.where := onStack; + GenImplied(m_phx); + GenImplied(m_pha); + end; {else} + end {else if} +else if op^.q in [quadToVoid,uquadToVoid] then begin + if gQuad.where = onStack then begin + GenImplied(m_tsc); + GenImplied(m_clc); + GenNative(m_adc_imm, immediate, 8, nil, 0); + GenImplied(m_tcs); + end; {if} + end {else if} +else if op^.q = quadToReal then + GenCall(83) +else if op^.q = uquadToReal then + GenCall(84) +else if (op^.q & $000F) = cVoid then + {do nothing} +else if (op^.q & $000F) in [cLong,cULong] then + if (lLong.preference & gLong.where) = 0 then begin + if gLong.where = constant then begin + GenNative(m_pea, immediate, long(gLong.lval).msw, nil, 0); + GenNative(m_pea, immediate, long(gLong.lval).lsw, nil, 0); + end {if} + else if gLong.where = A_X then begin + GenImplied(m_phx); + GenImplied(m_pha); + end; {else if} + gLong.where := onStack; + end; {if} end; {GenCnv} @@ -1391,7 +2012,7 @@ procedure GenEquNeq (op: icptr; opcode: pcodes; lb: integer); var nd: icptr; {work node} num: integer; {constant to compare to} - lab1,lab2: integer; {label numbers} + lab1,lab2,lab3: integer; {label numbers} bne: integer; {instruction for a pc_equ bne branch} beq: integer; {instruction for a pc_equ beq branch} lLong: longType; {local long value information} @@ -1684,7 +2305,89 @@ else end {if} else if op^.opcode = pc_neq then GenNative(m_eor_imm, immediate, 1, nil, 0); - end; {case optype of cgReal..cgExtended,cgSet,cgString} + end; {case optype of cgReal..cgExtended} + + cgQuad,cgUQuad: begin + if SimpleQuadLoad(op^.left) and (op^.right^.opcode = pc_ldc) + and (op^.right^.qval.hi = 0) and (op^.right^.qval.lo = 0) then begin + lab1 := GenLabel; + OpOnWordOfQuad(m_lda_imm, op^.left, 0); + if not volatile then + GenNative(m_bne, relative, lab1, nil, 0); + OpOnWordOfQuad(m_ora_imm, op^.left, 2); + OpOnWordOfQuad(m_ora_imm, op^.left, 4); + OpOnWordOfQuad(m_ora_imm, op^.left, 6); + GenLab(lab1); + end {if} + else if SimpleQuadLoad(op^.left) and SimpleQuadLoad(op^.right) + and not volatile then begin + lab1 := GenLabel; + OpOnWordOfQuad(m_lda_imm, op^.left, 0); + OpOnWordOfQuad(m_eor_imm, op^.right, 0); + GenNative(m_bne, relative, lab1, nil, 0); + OpOnWordOfQuad(m_lda_imm, op^.left, 2); + OpOnWordOfQuad(m_eor_imm, op^.right, 2); + GenNative(m_bne, relative, lab1, nil, 0); + OpOnWordOfQuad(m_lda_imm, op^.left, 4); + OpOnWordOfQuad(m_eor_imm, op^.right, 4); + GenNative(m_bne, relative, lab1, nil, 0); + OpOnWordOfQuad(m_lda_imm, op^.left, 6); + OpOnWordOfQuad(m_eor_imm, op^.right, 6); + GenLab(lab1); + end {if} + else begin + gQuad.preference := onStack; + GenTree(op^.left); + gQuad.preference := onStack; + GenTree(op^.right); + + lab1 := GenLabel; + lab2 := GenLabel; + GenImplied(m_pla); + GenImplied(m_plx); + GenImplied(m_ply); + GenNative(m_eor_s, direct, 3, nil, 0); + GenNative(m_bne, relative, lab1, nil, 0); + GenImplied(m_txa); + GenNative(m_eor_s, direct, 5, nil, 0); + GenNative(m_bne, relative, lab1, nil, 0); + GenImplied(m_tya); + GenNative(m_eor_s, direct, 7, nil, 0); + GenNative(m_bne, relative, lab1, nil, 0); + GenImplied(m_pla); + GenNative(m_eor_s, direct, 7, nil, 0); + GenNative(m_bra, relative, lab2, nil, 0); + GenLab(lab1); + GenImplied(m_plx); + GenLab(lab2); + GenImplied(m_tax); + + GenImplied(m_tsc); + GenImplied(m_clc); + GenNative(m_adc_imm, immediate, 8, nil, 0); + GenImplied(m_tcs); + + GenImplied(m_txa); + end; {else} + + if opcode in [pc_fjp,pc_tjp] then begin + lab3 := GenLabel; + if opcode = pc_fjp then + GenNative(beq, relative, lab3, nil, 0) + else + GenNative(bne, relative, lab3, nil, 0); + GenNative(m_brl, longrelative, lb, nil, 0); + GenLab(lab3); + end {if} + else begin + lab3 := GenLabel; + GenNative(m_beq, relative, lab3, nil, 0); + GenNative(m_lda_imm, immediate, 1, nil, 0); + GenLab(lab3); + if op^.opcode = pc_equ then + GenNative(m_eor_imm, immediate, 1, nil, 0); + end; {else} + end; {case optype of cgQuad,cgUQuad} otherwise: Error(cge1); @@ -2191,7 +2894,9 @@ else if op^.optype in [cgLong,cgULong] then begin end; {else} end; {else} end; {else} - end; {else if} + end {else if} +else + Error(cge1); end; {GenIncDec} @@ -2202,6 +2907,7 @@ procedure GenInd (op: icptr); var lab1: integer; {label} lLong: longType; {requested address type} + lQuad: quadType; {requested quad address type} optype: baseTypeEnum; {op^.optype} q: integer; {op^.q} @@ -2412,7 +3118,190 @@ case optype of end; {if} end; {case cgByte,cgUByte,cgWord,cgUWord} - otherwise: ; + cgQuad,cgUQuad: begin + lQuad := gQuad; + GetPointer(op^.left); + gQuad := lQuad; + gQuad.where := gQuad.preference; {unless overridden later} + if gLong.where = inPointer then begin + if q = 0 then begin + if gLong.fixedDisp then begin + GenNative(m_ldy_imm, immediate, 6, nil, 0); + GenNative(m_lda_indly, direct, gLong.disp, nil, 0); + StoreWordOfQuad(6); + GenImplied(m_dey); + GenImplied(m_dey); + GenNative(m_lda_indly, direct, gLong.disp, nil, 0); + StoreWordOfQuad(4); + GenImplied(m_dey); + GenImplied(m_dey); + GenNative(m_lda_indly, direct, gLong.disp, nil, 0); + StoreWordOfQuad(2); + GenNative(m_lda_indl, direct, gLong.disp, nil, 0); + StoreWordOfQuad(0); + end {if} + else begin + GenImplied(m_tya); + GenImplied(m_clc); + GenNative(m_adc_imm, immediate, 6, nil, 0); + GenImplied(m_tay); + GenNative(m_lda_indly, direct, gLong.disp, nil, 0); + StoreWordOfQuad(6); + GenImplied(m_dey); + GenImplied(m_dey); + GenNative(m_lda_indly, direct, gLong.disp, nil, 0); + StoreWordOfQuad(4); + GenImplied(m_dey); + GenImplied(m_dey); + GenNative(m_lda_indly, direct, gLong.disp, nil, 0); + StoreWordOfQuad(2); + GenImplied(m_dey); + GenImplied(m_dey); + GenNative(m_lda_indly, direct, gLong.disp, nil, 0); + StoreWordOfQuad(0); + end; {else} + end {if q = 0} + else begin + if gLong.fixedDisp then begin + GenNative(m_ldy_imm, immediate, q+6, nil, 0); + GenNative(m_lda_indly, direct, gLong.disp, nil, 0); + StoreWordOfQuad(6); + GenImplied(m_dey); + GenImplied(m_dey); + GenNative(m_lda_indly, direct, gLong.disp, nil, 0); + StoreWordOfQuad(4); + GenImplied(m_dey); + GenImplied(m_dey); + GenNative(m_lda_indly, direct, gLong.disp, nil, 0); + StoreWordOfQuad(2); + GenImplied(m_dey); + GenImplied(m_dey); + GenNative(m_lda_indly, direct, gLong.disp, nil, 0); + StoreWordOfQuad(0); + end {if} + else begin + GenImplied(m_tya); + GenImplied(m_clc); + GenNative(m_adc_imm, immediate, q+6, nil, 0); + GenImplied(m_tay); + GenNative(m_lda_indly, direct, gLong.disp, nil, 0); + StoreWordOfQuad(6); + GenImplied(m_dey); + GenImplied(m_dey); + GenNative(m_lda_indly, direct, gLong.disp, nil, 0); + StoreWordOfQuad(4); + GenImplied(m_dey); + GenImplied(m_dey); + GenNative(m_lda_indly, direct, gLong.disp, nil, 0); + StoreWordOfQuad(2); + GenImplied(m_dey); + GenImplied(m_dey); + GenNative(m_lda_indly, direct, gLong.disp, nil, 0); + StoreWordOfQuad(0); + end; {else} + end; {else} + end {if glong.where = inPointer} + else if gLong.where = localAddress then begin + gLong.disp := gLong.disp+q; + if gLong.fixedDisp then + if (gLong.disp < 250) and (gLong.disp >= 0) then begin + if gQuad.preference = onStack then begin + GenNative(m_pei_dir, direct, gLong.disp+6, nil, 0); + GenNative(m_pei_dir, direct, gLong.disp+4, nil, 0); + GenNative(m_pei_dir, direct, gLong.disp+2, nil, 0); + GenNative(m_pei_dir, direct, gLong.disp, nil, 0); + end {if} + else begin + GenNative(m_lda_dir, direct, gLong.disp+6, nil, 0); + StoreWordOfQuad(6); + GenNative(m_lda_dir, direct, gLong.disp+4, nil, 0); + StoreWordOfQuad(4); + GenNative(m_lda_dir, direct, gLong.disp+2, nil, 0); + StoreWordOfQuad(2); + GenNative(m_lda_dir, direct, gLong.disp, nil, 0); + StoreWordOfQuad(0); + end; {else} + end {if} + else begin + gQuad.where := onStack; + GenNative(m_ldx_imm, immediate, gLong.disp, nil, 0); + GenNative(m_lda_dirX, direct, 6, nil, 0); + GenImplied(m_pha); + GenNative(m_lda_dirX, direct, 4, nil, 0); + GenImplied(m_pha); + GenNative(m_lda_dirX, direct, 2, nil, 0); + GenImplied(m_pha); + GenNative(m_lda_dirX, direct, 0, nil, 0); + GenImplied(m_pha); + end {else} + else begin + gQuad.where := onStack; + if (gLong.disp >= 250) or (gLong.disp < 0) then begin + GenImplied(m_txa); + GenImplied(m_clc); + GenNative(m_adc_imm, immediate, gLong.disp, nil, 0); + GenImplied(m_tax); + gLong.disp := 0; + end; {if} + GenNative(m_lda_dirX, direct, gLong.disp+6, nil, 0); + GenImplied(m_pha); + GenNative(m_lda_dirX, direct, gLong.disp+4, nil, 0); + GenImplied(m_pha); + GenNative(m_lda_dirX, direct, gLong.disp+2, nil, 0); + GenImplied(m_pha); + GenNative(m_lda_dirX, direct, gLong.disp, nil, 0); + GenImplied(m_pha); + end; {else} + end {else if gLong.where = localAddress} + else {if gLong.where = globalLabel then} begin + gLong.disp := gLong.disp+q; + if gLong.fixedDisp then + if smallMemoryModel then begin + GenNative(m_lda_abs, absolute, gLong.disp+6, gLong.lab, 0); + StoreWordOfQuad(6); + GenNative(m_lda_abs, absolute, gLong.disp+4, gLong.lab, 0); + StoreWordOfQuad(4); + GenNative(m_lda_abs, absolute, gLong.disp+2, gLong.lab, 0); + StoreWordOfQuad(2); + GenNative(m_lda_abs, absolute, gLong.disp, gLong.lab, 0); + StoreWordOfQuad(0); + end {if} + else begin + GenNative(m_lda_long, longAbs, gLong.disp+6, gLong.lab, 0); + StoreWordOfQuad(6); + GenNative(m_lda_long, longAbs, gLong.disp+4, gLong.lab, 0); + StoreWordOfQuad(4); + GenNative(m_lda_long, longAbs, gLong.disp+2, gLong.lab, 0); + StoreWordOfQuad(2); + GenNative(m_lda_long, longAbs, gLong.disp, gLong.lab, 0); + StoreWordOfQuad(6); + end {else} + else + if smallMemoryModel then begin + gQuad.where := onStack; + GenNative(m_lda_absX, absolute, gLong.disp+6, gLong.lab, 0); + GenImplied(m_pha); + GenNative(m_lda_absX, absolute, gLong.disp+4, gLong.lab, 0); + GenImplied(m_pha); + GenNative(m_lda_absX, absolute, gLong.disp+2, gLong.lab, 0); + GenImplied(m_pha); + GenNative(m_lda_absX, absolute, gLong.disp, gLong.lab, 0); + GenImplied(m_pha); + end {if} + else begin + gQuad.where := onStack; + GenNative(m_lda_longX, longAbs, gLong.disp+6, gLong.lab, 0); + GenImplied(m_pha); + GenNative(m_lda_longX, longAbs, gLong.disp+4, gLong.lab, 0); + GenImplied(m_pha); + GenNative(m_lda_longX, longAbs, gLong.disp+2, gLong.lab, 0); + GenImplied(m_pha); + GenNative(m_lda_longX, longAbs, gLong.disp, gLong.lab, 0); + GenImplied(m_pha); + end; {else} + end; {else} + end; {case cgQuad,cgUQuad} + otherwise: Error(cge1); end; {case} end; {GenInd} @@ -3251,6 +4140,51 @@ case optype of end; {case} end; {else} end; {case CGLong, cgULong} + + cgQuad, cgUQuad: begin + if opcode = pc_sro then begin + gQuad.preference := globalLabel; + gQuad.lab := lab; + gQuad.disp := q; + end {if} + else {if opcode = pc_cpo then} + gQuad.preference := onStack; + GenTree(op^.left); + if gQuad.where = onStack then begin + if opcode = pc_sro then + GenImplied(m_pla) + else {if opcode = pc_cpo then} + GenNative(m_lda_s, direct, 1, nil, 0); + if smallMemoryModel then + GenNative(m_sta_abs, absolute, q, lab, 0) + else + GenNative(m_sta_long, longabsolute, q, lab, 0); + if opcode = pc_sro then + GenImplied(m_pla) + else {if opcode = pc_cpo then} + GenNative(m_lda_s, direct, 3, nil, 0); + if smallMemoryModel then + GenNative(m_sta_abs, absolute, q+2, lab, 0) + else + GenNative(m_sta_long, longabsolute, q+2, lab, 0); + if opcode = pc_sro then + GenImplied(m_pla) + else {if opcode = pc_cpo then} + GenNative(m_lda_s, direct, 5, nil, 0); + if smallMemoryModel then + GenNative(m_sta_abs, absolute, q+4, lab, 0) + else + GenNative(m_sta_long, longabsolute, q+4, lab, 0); + if opcode = pc_sro then + GenImplied(m_pla) + else {if opcode = pc_cpo then} + GenNative(m_lda_s, direct, 7, nil, 0); + if smallMemoryModel then + GenNative(m_sta_abs, absolute, q+6, lab, 0) + else + GenNative(m_sta_long, longabsolute, q+6, lab, 0); + end; {if} + end; {case cgQuad, cgUQuad} end; {case} end; {GenSroCpo} @@ -3363,6 +4297,56 @@ case optype of end; {else} end; {case cgReal,cgDouble,cgComp,cgExtended} + cgQuad,cgUQuad: begin + gQuad.preference := onStack; + if opcode = pc_sto then + if op^.left^.opcode = pc_lod then begin + disp := LabelToDisp(op^.left^.r) + op^.left^.q; + if disp <= 255 then begin + gQuad.preference := inPointer; + gQuad.disp := disp; + end; {if} + end; {if} + GenTree(op^.right); + if gQuad.where = onStack then begin + gLong.preference := A_X; + GenTree(op^.left); + if gLong.where = onStack then begin + GenImplied(m_pla); + GenImplied(m_plx); + end; {if} + GenNative(m_sta_dir, direct, dworkLoc, nil, 0); + GenNative(m_stx_dir, direct, dworkLoc+2, nil, 0); + if opcode = pc_sto then + GenImplied(m_pla) + else {if op^.opcode = pc_cpi then} + GenNative(m_lda_s, direct, 1, nil, 0); + GenNative(m_sta_indl, direct, dworkLoc, nil, 0); + GenNative(m_ldy_imm, immediate, 2, nil, 0); + if opcode = pc_sto then + GenImplied(m_pla) + else {if op^.opcode = pc_cpi then} + GenNative(m_lda_s, direct, 3, nil, 0); + GenNative(m_sta_indly, direct, dworkLoc, nil, 0); + GenImplied(m_iny); + GenImplied(m_iny); + if opcode = pc_sto then + GenImplied(m_pla) + else {if op^.opcode = pc_cpi then} + GenNative(m_lda_s, direct, 5, nil, 0); + GenNative(m_sta_indly, direct, dworkLoc, nil, 0); + GenImplied(m_iny); + GenImplied(m_iny); + if opcode = pc_sto then + GenImplied(m_pla) + else {if op^.opcode = pc_cpi then} + GenNative(m_lda_s, direct, 7, nil, 0); + GenNative(m_sta_indly, direct, dworkLoc, nil, 0); + if op^.opcode = pc_cpi then + gQuad.where := onStack; + end; {if} + end; {case cgQuad,cgUQuad} + cgLong,cgULong: begin if opcode = pc_sto then gLong.preference := onStack+constant @@ -3860,7 +4844,64 @@ case optype of end; {else} end; - otherwise: ; + cgQuad, cgUQuad: begin + if op^.opcode = pc_str then begin + gQuad.preference := localAddress; + gQuad.disp := disp; + end {if} + else {if op^.opcode = pc_cop then} + gQuad.preference := onStack; + GenTree(op^.left); + if gQuad.where = onStack then begin + if disp < 250 then begin + if op^.opcode = pc_str then + GenImplied(m_pla) + else {if op^.opcode = pc_cop then} + GenNative(m_lda_s, direct, 1, nil, 0); + GenNative(m_sta_dir, direct, disp, nil, 0); + if op^.opcode = pc_str then + GenImplied(m_pla) + else {if op^.opcode = pc_cop then} + GenNative(m_lda_s, direct, 3, nil, 0); + GenNative(m_sta_dir, direct, disp+2, nil, 0); + if op^.opcode = pc_str then + GenImplied(m_pla) + else {if op^.opcode = pc_cop then} + GenNative(m_lda_s, direct, 5, nil, 0); + GenNative(m_sta_dir, direct, disp+4, nil, 0); + if op^.opcode = pc_str then + GenImplied(m_pla) + else {if op^.opcode = pc_cop then} + GenNative(m_lda_s, direct, 7, nil, 0); + GenNative(m_sta_dir, direct, disp+6, nil, 0); + end {else if} + else begin + GenNative(m_ldx_imm, immediate, disp, nil, 0); + if op^.opcode = pc_str then + GenImplied(m_pla) + else {if op^.opcode = pc_cop then} + GenNative(m_lda_s, direct, 1, nil, 0); + GenNative(m_sta_dirX, direct, 0, nil, 0); + if op^.opcode = pc_str then + GenImplied(m_pla) + else {if op^.opcode = pc_cop then} + GenNative(m_lda_s, direct, 3, nil, 0); + GenNative(m_sta_dirX, direct, 2, nil, 0); + if op^.opcode = pc_str then + GenImplied(m_pla) + else {if op^.opcode = pc_cop then} + GenNative(m_lda_s, direct, 5, nil, 0); + GenNative(m_sta_dirX, direct, 4, nil, 0); + if op^.opcode = pc_str then + GenImplied(m_pla) + else {if op^.opcode = pc_cop then} + GenNative(m_lda_s, direct, 7, nil, 0); + GenNative(m_sta_dirX, direct, 6, nil, 0); + end; {else} + end; {if} + end; + + otherwise: Error(cge1); end; {case} end; {GenStrCop} @@ -3898,6 +4939,99 @@ gLong.where := onStack; {the result is on the stack} end; {GenUnaryLong} +procedure GenUnaryQuad (op: icptr); + +{ generate a pc_bnq or pc_ngq } + +begin {GenUnaryQuad} +case op^.opcode of {do the operation} + + pc_bnq: begin + if SimpleQuadLoad(op^.left) then begin + OpOnWordOfQuad(m_lda_imm, op^.left, 6); + GenNative(m_eor_imm, immediate, $FFFF, nil, 0); + StoreWordOfQuad(6); + OpOnWordOfQuad(m_lda_imm, op^.left, 4); + GenNative(m_eor_imm, immediate, $FFFF, nil, 0); + StoreWordOfQuad(4); + OpOnWordOfQuad(m_lda_imm, op^.left, 2); + GenNative(m_eor_imm, immediate, $FFFF, nil, 0); + StoreWordOfQuad(2); + OpOnWordOfQuad(m_lda_imm, op^.left, 0); + GenNative(m_eor_imm, immediate, $FFFF, nil, 0); + StoreWordOfQuad(0); + gQuad.where := gQuad.preference; + end {if} + else begin + gQuad.preference := onStack; + GenTree(op^.left); + GenNative(m_lda_s, direct, 1, nil, 0); + GenNative(m_eor_imm, immediate, $FFFF, nil, 0); + GenNative(m_sta_s, direct, 1, nil, 0); + GenNative(m_lda_s, direct, 3, nil, 0); + GenNative(m_eor_imm, immediate, $FFFF, nil, 0); + GenNative(m_sta_s, direct, 3, nil, 0); + GenNative(m_lda_s, direct, 5, nil, 0); + GenNative(m_eor_imm, immediate, $FFFF, nil, 0); + GenNative(m_sta_s, direct, 5, nil, 0); + GenNative(m_lda_s, direct, 7, nil, 0); + GenNative(m_eor_imm, immediate, $FFFF, nil, 0); + GenNative(m_sta_s, direct, 7, nil, 0); + gQuad.where := onStack; + end; {else} + end; {case pc_bnq} + + pc_ngq: begin + if SimpleQuadLoad(op^.left) then begin + gQuad.where := gQuad.preference; + if gQuad.preference = onStack then begin + GenImplied(m_tsc); + GenImplied(m_sec); + GenNative(m_sbc_imm, immediate, 8, nil, 0); + GenImplied(m_tcs); + gQuad.preference := inStackLoc; + gQuad.disp := 1; + end; {if} + GenImplied(m_sec); + GenNative(m_lda_imm, immediate, 0, nil, 0); + OpOnWordOfQuad(m_sbc_imm, op^.left, 0); + StoreWordOfQuad(0); + GenNative(m_lda_imm, immediate, 0, nil, 0); + OpOnWordOfQuad(m_sbc_imm, op^.left, 2); + StoreWordOfQuad(2); + GenNative(m_lda_imm, immediate, 0, nil, 0); + OpOnWordOfQuad(m_sbc_imm, op^.left, 4); + StoreWordOfQuad(4); + GenNative(m_lda_imm, immediate, 0, nil, 0); + OpOnWordOfQuad(m_sbc_imm, op^.left, 6); + StoreWordOfQuad(6); + end {if} + else begin + gQuad.preference := onStack; + GenTree(op^.left); + GenImplied(m_sec); + GenNative(m_ldy_imm, immediate, 0, nil, 0); + GenImplied(m_tya); + GenNative(m_sbc_s, direct, 1, nil, 0); + GenNative(m_sta_s, direct, 1, nil, 0); + GenImplied(m_tya); + GenNative(m_sbc_s, direct, 3, nil, 0); + GenNative(m_sta_s, direct, 3, nil, 0); + GenImplied(m_tya); + GenNative(m_sbc_s, direct, 5, nil, 0); + GenNative(m_sta_s, direct, 5, nil, 0); + GenImplied(m_tya); + GenNative(m_sbc_s, direct, 7, nil, 0); + GenNative(m_sta_s, direct, 7, nil, 0); + gQuad.where := onStack; + end; {else} + end; {case pc_ngq} + end; {case} +end; {GenUnaryQuad} + + +{$segment 'gen2'} + procedure GenTree {op: icptr}; { generate code for op and its children } @@ -4061,6 +5195,134 @@ procedure GenTree {op: icptr}; end; {GenBinLong} + procedure GenBinQuad (op: icptr); + + { generate one of: pc_bqr, pc_bqx, pc_baq, pc_mpq, pc_umq, } + { pc_dvq, pc_udq, pc_mdq, pc_uqm } + + procedure GenBitwiseOp; + + { generate a 64-bit binary bitwise operation } + { } + { parameters: } + { ops - stack version of operation } + + var + mop: integer; {machine opcode} + + begin {GenBitwiseOp} + if SimpleQuadLoad(op^.left) and SimpleQuadLoad(op^.right) then begin + case op^.opcode of + pc_bqr: mop := m_ora_imm; + pc_bqx: mop := m_eor_imm; + pc_baq: mop := m_and_imm; + end; {case} + OpOnWordOfQuad(m_lda_imm, op^.left, 6); + OpOnWordOfQuad(mop, op^.right, 6); + StoreWordOfQuad(6); + OpOnWordOfQuad(m_lda_imm, op^.left, 4); + OpOnWordOfQuad(mop, op^.right, 4); + StoreWordOfQuad(4); + OpOnWordOfQuad(m_lda_imm, op^.left, 2); + OpOnWordOfQuad(mop, op^.right, 2); + StoreWordOfQuad(2); + OpOnWordOfQuad(m_lda_imm, op^.left, 0); + OpOnWordOfQuad(mop, op^.right, 0); + StoreWordOfQuad(0); + gQuad.where := gQuad.preference; + end {if} + else begin + case op^.opcode of + pc_bqr: mop := m_ora_s; + pc_bqx: mop := m_eor_s; + pc_baq: mop := m_and_s; + end; {case} + gQuad.preference := onStack; + GenTree(op^.left); + gQuad.preference := onStack; + GenTree(op^.right); + GenImplied(m_pla); + GenNative(mop, direct, 7, nil, 0); + GenNative(m_sta_s, direct, 7, nil, 0); + GenImplied(m_pla); + GenNative(mop, direct, 7, nil, 0); + GenNative(m_sta_s, direct, 7, nil, 0); + GenImplied(m_pla); + GenNative(mop, direct, 7, nil, 0); + GenNative(m_sta_s, direct, 7, nil, 0); + GenImplied(m_pla); + GenNative(mop, direct, 7, nil, 0); + GenNative(m_sta_s, direct, 7, nil, 0); + gQuad.where := onStack; + end; {else} + end; {GenBitwiseOp} + + begin {GenBinQuad} + if op^.opcode in [pc_bqr,pc_bqx,pc_baq] then + GenBitwiseOp + else begin + gQuad.preference := onStack; + GenTree(op^.left); + gQuad.preference := onStack; + GenTree(op^.right); + case op^.opcode of + pc_mpq: GenCall(79); + + pc_umq: GenCall(80); + + pc_dvq: begin + GenCall(81); {do division} + GenImplied(m_pla); {get quotient, discarding remainder} + GenNative(m_sta_s, direct, 7, nil, 0); + GenImplied(m_pla); + GenNative(m_sta_s, direct, 7, nil, 0); + GenImplied(m_pla); + GenNative(m_sta_s, direct, 7, nil, 0); + GenImplied(m_pla); + GenNative(m_sta_s, direct, 7, nil, 0); + end; + + pc_udq: begin + GenCall(82); {do division} + GenImplied(m_pla); {get quotient, discarding remainder} + GenNative(m_sta_s, direct, 7, nil, 0); + GenImplied(m_pla); + GenNative(m_sta_s, direct, 7, nil, 0); + GenImplied(m_pla); + GenNative(m_sta_s, direct, 7, nil, 0); + GenImplied(m_pla); + GenNative(m_sta_s, direct, 7, nil, 0); + end; + + pc_mdq: begin + GenCall(81); {do division} + GenImplied(m_tsc); {discard quotient, leaving remainder} + GenImplied(m_clc); + GenNative(m_adc_imm, immediate, 8, nil, 0); + GenImplied(m_tcs); + end; + + pc_uqm: begin + GenCall(82); {do division} + GenImplied(m_tsc); {discard quotient, leaving remainder} + GenImplied(m_clc); + GenNative(m_adc_imm, immediate, 8, nil, 0); + GenImplied(m_tcs); + end; + + pc_slq: GenCall(85); + + pc_sqr: GenCall(86); + + pc_wsr: GenCall(87); + + otherwise: Error(cge1); + end; {case} + gQuad.where := onStack; + end; {else} + end; {GenBinQuad} + + procedure GenBno (op: icptr); { Generate code for a pc_bno } @@ -4113,13 +5375,30 @@ procedure GenTree {op: icptr}; var lab1: integer; {return point} lLong: longType; {used to reserve gLong} + lQuad: quadType; {saved copy of gQuad} + lArgsSize: integer; {saved copy of argsSize} + extraStackSize: integer; {size of extra stuff pushed on stack} begin {GenCui} + lArgsSize := argsSize; + argsSize := 0; + extraStackSize := 0; + + {For functions returning cg(U)Quad, make space for result} + if op^.optype in [cgQuad,cgUQuad] then + if gQuad.preference <> localAddress then begin + GenImplied(m_tsc); + GenImplied(m_sec); + GenNative(m_sbc_imm, immediate, 8, nil, 0); + GenImplied(m_tcs); + end; {if} + {save the stack register} if saveStack or checkStack or (op^.q <> 0) then begin if stackSaveDepth <> 0 then begin GenNative(m_ldx_dir, direct, stackLoc, nil, 0); GenImplied(m_phx); + extraStackSize := 2; end; {if} GenImplied(m_tsx); GenNative(m_stx_dir, direct, stackLoc, nil, 0); @@ -4128,6 +5407,7 @@ procedure GenTree {op: icptr}; {generate parameters} {place the operands on the stack} + lQuad := gQuad; lLong := gLong; GenTree(op^.left); @@ -4135,6 +5415,22 @@ procedure GenTree {op: icptr}; gLong.preference := onStack; GenTree(op^.right); gLong := lLong; + gQuad := lQuad; + + {For functions returning cg(U)Quad, x = address to store result in} + if op^.optype in [cgQuad,cgUQuad] then + if gQuad.preference = localAddress then begin + GenImplied(m_tdc); + GenImplied(m_clc); + GenNative(m_adc_imm, immediate, gQuad.disp, nil, 0); + GenImplied(m_tax); + end {if} + else begin + GenImplied(m_tsc); + GenImplied(m_clc); + GenNative(m_adc_imm, immediate, argsSize+extraStackSize+4+1, nil, 0); + GenImplied(m_tax); + end; {else} {create a return label} lab1 := GenLabel; @@ -4168,11 +5464,13 @@ procedure GenTree {op: icptr}; end {if} else if saveStack or (op^.q <> 0) then begin stackSaveDepth := stackSaveDepth - 1; - if not (op^.optype in [cgVoid,cgByte,cgUByte,cgWord,cgUWord]) then + if not (op^.optype in [cgVoid,cgByte,cgUByte,cgWord,cgUWord,cgQuad,cgUQuad]) + then GenImplied(m_txy); GenNative(m_ldx_dir, direct, stackLoc, nil, 0); GenImplied(m_txs); - if not (op^.optype in [cgVoid,cgByte,cgUByte,cgWord,cgUWord]) then + if not (op^.optype in [cgVoid,cgByte,cgUByte,cgWord,cgUWord,cgQuad,cgUQuad]) + then GenImplied(m_tyx); if stackSaveDepth <> 0 then begin GenImplied(m_ply); @@ -4182,7 +5480,12 @@ procedure GenTree {op: icptr}; {save the returned value} gLong.where := A_X; + if gQuad.preference = localAddress then + gQuad.where := localAddress + else + gQuad.where := onStack; SaveRetValue(op^.optype); + argsSize := lArgsSize; end; {GenCui} @@ -4191,14 +5494,31 @@ procedure GenTree {op: icptr}; { Generate code for a pc_cup } var - lLong: longType; {used to reserve gLong} + lLong: longType; {used to reserve gLong} + lQuad: quadType; {saved copy of gQuad} + lArgsSize: integer; {saved copy of argsSize} + extraStackSize: integer; {size of extra stuff pushed on stack} begin {GenCup} + lArgsSize := argsSize; + argsSize := 0; + extraStackSize := 0; + + {For functions returning cg(U)Quad, make space for result} + if op^.optype in [cgQuad,cgUQuad] then + if gQuad.preference <> localAddress then begin + GenImplied(m_tsc); + GenImplied(m_sec); + GenNative(m_sbc_imm, immediate, 8, nil, 0); + GenImplied(m_tcs); + end; {if} + {save the stack register} if saveStack or checkStack or (op^.q <> 0) then begin if stackSaveDepth <> 0 then begin GenNative(m_ldx_dir, direct, stackLoc, nil, 0); GenImplied(m_phx); + extraStackSize := 2; end; {if} GenImplied(m_tsx); GenNative(m_stx_dir, direct, stackLoc, nil, 0); @@ -4206,9 +5526,35 @@ procedure GenTree {op: icptr}; end; {if} {generate parameters} + lQuad := gQuad; lLong := gLong; GenTree(op^.left); gLong := lLong; + gQuad := lQuad; + + {For functions returning cg(U)Quad, x = address to store result in} + if op^.optype in [cgQuad,cgUQuad] then + if gQuad.preference = localAddress then begin + GenImplied(m_tdc); + GenImplied(m_clc); + GenNative(m_adc_imm, immediate, gQuad.disp, nil, 0); + GenImplied(m_tax); + end {if} + else if argsSize + extraStackSize in [0,1,2] then begin + GenImplied(m_tsx); + GenImplied(m_inx); + if argsSize + extraStackSize in [1,2] then begin + GenImplied(m_inx); + if argsSize + extraStackSize = 2 then + GenImplied(m_inx); + end; {if} + end {if} + else begin + GenImplied(m_tsc); + GenImplied(m_clc); + GenNative(m_adc_imm, immediate, argsSize+extraStackSize+1, nil, 0); + GenImplied(m_tax); + end; {else} {generate the jsl} GenNative(m_jsl, longAbs, 0, op^.lab, 0); @@ -4226,11 +5572,13 @@ procedure GenTree {op: icptr}; end {if} else if saveStack or (op^.q <> 0) then begin stackSaveDepth := stackSaveDepth - 1; - if not (op^.optype in [cgVoid,cgByte,cgUByte,cgWord,cgUWord]) then + if not (op^.optype in [cgVoid,cgByte,cgUByte,cgWord,cgUWord,cgQuad,cgUQuad]) + then GenImplied(m_txy); GenNative(m_ldx_dir, direct, stackLoc, nil, 0); GenImplied(m_txs); - if not (op^.optype in [cgVoid,cgByte,cgUByte,cgWord,cgUWord]) then + if not (op^.optype in [cgVoid,cgByte,cgUByte,cgWord,cgUWord,cgQuad,cgUQuad]) + then GenImplied(m_tyx); if stackSaveDepth <> 0 then begin GenImplied(m_ply); @@ -4240,7 +5588,12 @@ procedure GenTree {op: icptr}; {save the returned value} gLong.where := A_X; + if gQuad.preference = localAddress then + gQuad.where := localAddress + else + gQuad.where := onStack; SaveRetValue(op^.optype); + argsSize := lArgsSize; end; {GenCup} @@ -4340,6 +5693,11 @@ procedure GenTree {op: icptr}; GenImplied(m_tcd); end; {if} + if isQuadFunction then begin {save return location for cg(U)Quad} + GenNative(m_stx_dir, direct, funloc, nil, 0); + GenNative(m_stz_dir, direct, funloc+2, nil, 0); + end; {if} + if dataBank then begin {preserve and set data bank} GenImplied(m_phb); GenImplied(m_phb); @@ -4555,6 +5913,26 @@ procedure GenTree {op: icptr}; GenNative(m_pea, immediate, long(op^.lval).lsw, nil, 0); end; + cgQuad,cgUQuad: begin + if gQuad.preference = onStack then begin + GenNative(m_pea, immediate, long(op^.qval.hi).msw, nil, 0); + GenNative(m_pea, immediate, long(op^.qval.hi).lsw, nil, 0); + GenNative(m_pea, immediate, long(op^.qval.lo).msw, nil, 0); + GenNative(m_pea, immediate, long(op^.qval.lo).lsw, nil, 0); + end {if} + else begin + GenNative(m_lda_imm, immediate, long(op^.qval.hi).msw, nil, 0); + StoreWordOfQuad(6); + GenNative(m_lda_imm, immediate, long(op^.qval.hi).lsw, nil, 0); + StoreWordOfQuad(4); + GenNative(m_lda_imm, immediate, long(op^.qval.lo).msw, nil, 0); + StoreWordOfQuad(2); + GenNative(m_lda_imm, immediate, long(op^.qval.lo).lsw, nil, 0); + StoreWordOfQuad(0); + end; {else} + gQuad.where := gQuad.preference; + end; + otherwise: Error(cge1); end; {case} @@ -4630,6 +6008,30 @@ procedure GenTree {op: icptr}; end; {else} end; {case cgLong,cgULong} + cgQuad, cgUQuad: begin + if smallMemoryModel then begin + GenNative(m_lda_abs, absolute, op^.q+6, op^.lab, 0); + StoreWordOfQuad(6); + GenNative(m_lda_abs, absolute, op^.q+4, op^.lab, 0); + StoreWordOfQuad(4); + GenNative(m_lda_abs, absolute, op^.q+2, op^.lab, 0); + StoreWordOfQuad(2); + GenNative(m_lda_abs, absolute, op^.q, op^.lab, 0); + StoreWordOfQuad(0); + end {if} + else begin + GenNative(m_lda_long, longabsolute, op^.q+6, op^.lab, 0); + StoreWordOfQuad(6); + GenNative(m_lda_long, longabsolute, op^.q+4, op^.lab, 0); + StoreWordOfQuad(4); + GenNative(m_lda_long, longabsolute, op^.q+2, op^.lab, 0); + StoreWordOfQuad(2); + GenNative(m_lda_long, longabsolute, op^.q, op^.lab, 0); + StoreWordOfQuad(0); + end; {else} + gQuad.where := gQuad.preference; + end; {case cgQuad,cgUQuad} + otherwise: Error(cge1); end; {case} @@ -4683,6 +6085,40 @@ procedure GenTree {op: icptr}; GenCall(71); end; + cgQuad, cgUQuad: begin + if disp >= 250 then begin + GenNative(m_ldx_imm, immediate, disp, nil, 0); + GenNative(m_lda_dirx, direct, 6, nil, 0); + GenImplied(m_pha); + GenNative(m_lda_dirx, direct, 4, nil, 0); + GenImplied(m_pha); + GenNative(m_lda_dirx, direct, 2, nil, 0); + GenImplied(m_pha); + GenNative(m_lda_dirx, direct, 0, nil, 0); + GenImplied(m_pha); + gQuad.where := onStack; + end {if} + else begin + if gQuad.preference = onStack then begin + GenNative(m_pei_dir, direct, disp+6, nil, 0); + GenNative(m_pei_dir, direct, disp+4, nil, 0); + GenNative(m_pei_dir, direct, disp+2, nil, 0); + GenNative(m_pei_dir, direct, disp, nil, 0); + end {if} + else begin + GenNative(m_lda_dir, direct, disp+6, nil, 0); + StoreWordOfQuad(6); + GenNative(m_lda_dir, direct, disp+4, nil, 0); + StoreWordOfQuad(4); + GenNative(m_lda_dir, direct, disp+2, nil, 0); + StoreWordOfQuad(2); + GenNative(m_lda_dir, direct, disp, nil, 0); + StoreWordOfQuad(0); + end; {else} + gQuad.where := gQuad.preference; + end; {else} + end; + cgLong, cgULong: begin if ((inPointer & gLong.preference) <> 0) and (disp < 254) then begin @@ -5037,6 +6473,7 @@ procedure GenTree {op: icptr}; begin {GenPop} glong.preference := A_X; {generate the operand} + gQuad.preference := nowhere; isIncLoad := op^.left^.opcode in [pc_lil,pc_lli,pc_ldl,pc_lld,pc_gil,pc_gli,pc_gdl,pc_gld, pc_iil,pc_ili,pc_idl,pc_ild]; @@ -5049,7 +6486,9 @@ procedure GenTree {op: icptr}; if isIncLoad then skipLoad := false; case op^.optype of {do the pop} - otherwise: ; + otherwise: Error(cge1); + + cgByte, cgUByte, cgWord, cgUWord, cgVoid: ; cgLong, cgULong: if not isIncLoad then @@ -5058,6 +6497,15 @@ procedure GenTree {op: icptr}; GenImplied(m_pla); end; {if} {else do nothing} + + cgQuad, cgUQuad: begin + if gQuad.where = onStack then begin + GenImplied(m_tsc); + GenImplied(m_clc); + GenNative(m_adc_imm, immediate, 8, nil, 0); + GenImplied(m_tcs); + end; {if} + end; cgReal, cgDouble, cgComp, cgExtended: begin GenImplied(m_tsc); @@ -5259,6 +6707,8 @@ procedure GenTree {op: icptr}; GenNative(m_ldy_dir, direct, funLoc, nil, 0); end; + cgQuad,cgUQuad: ; {return value was already written} + otherwise: Error(cge1); end; {case} @@ -5301,7 +6751,7 @@ procedure GenTree {op: icptr}; end; {if} end; - cgVoid: ; + cgVoid,cgQuad,cgUQuad: ; otherwise: Error(cge1); @@ -5377,8 +6827,28 @@ procedure GenTree {op: icptr}; var lab1: integer; {branch point} - begin {GenStk} + begin {GenStk} + if op^.left^.opcode = pc_psh then begin + if (op^.left^.right^.opcode = pc_ldc) and + (op^.left^.right^.optype in [cgWord,cgUWord]) then + argsSize := argsSize + op^.left^.right^.q + else + Error(cge1); + end {if} + else + case op^.optype of + cgByte,cgUByte,cgWord,cgUWord: + argsSize := argsSize + cgWordSize; + cgReal,cgDouble,cgComp,cgExtended: + argsSize := argsSize + cgExtendedSize; + cgLong,cgULong: + argsSize := argsSize + cgLongSize; + cgQuad,cgUQuad: + argsSize := argsSize + cgQuadSize; + otherwise: Error(cge1); + end; {case} glong.preference := onStack; {generate the operand} + gQuad.preference := onStack; GenTree(op^.left); if op^.optype in {do the stk} [cgByte, cgUByte, cgWord, cgUWord] then @@ -5598,11 +7068,15 @@ case op^.opcode of pc_add: GenNative(d_add, genaddress, op^.q, nil, 0); pc_adi: GenAdi(op); pc_adl,pc_sbl: GenAdlSbl(op, nil); + pc_adq,pc_sbq: GenAdqSbq(op); pc_adr,pc_dvr,pc_mpr,pc_sbr: GenRealBinOp(op); pc_and,pc_bnd,pc_bor,pc_bxr,pc_ior: GenLogic(op); pc_blr,pc_blx,pc_bal,pc_dvl,pc_mdl,pc_mpl,pc_sll,pc_slr,pc_udl,pc_ulm, pc_uml,pc_vsr: GenBinLong(op); + pc_bqr,pc_bqx,pc_baq,pc_mpq,pc_umq,pc_dvq,pc_udq,pc_mdq,pc_uqm,pc_slq, + pc_sqr,pc_wsr: GenBinQuad(op); pc_bnl,pc_ngl: GenUnaryLong(op); + pc_bnq,pc_ngq: GenUnaryQuad(op); pc_bno: GenBno(op); pc_bnt,pc_ngi,pc_not: GenBntNgiNot(op); pc_cnv: GenCnv(op); @@ -5746,6 +7220,10 @@ var cgComp: size := cgCompSize; cgExtended: size := cgExtendedSize; cgLong,cgULong: size := cgLongSize; + cgQuad,cgUQuad: begin + size := cgLongSize; {pointer} + isQuadFunction := true; + end; end; {case} funLoc := 1; if dworkLoc <> 0 then @@ -5774,6 +7252,7 @@ funLoc := 0; dworkLoc := 0; minSize := 1; stackSaveDepth := 0; +isQuadFunction := false; while bk <> nil do begin op := bk^.code; while op <> nil do begin diff --git a/Header.pas b/Header.pas index 065cc2c..731c3ce 100644 --- a/Header.pas +++ b/Header.pas @@ -18,7 +18,7 @@ uses CCommon, MM, Scanner, Symbol, CGI; {$segment 'SCANNER'} const - symFileVersion = 8; {version number of .sym file format} + symFileVersion = 10; {version number of .sym file format} var inhibitHeader: boolean; {should .sym includes be blocked?} @@ -711,6 +711,10 @@ procedure EndInclude {chPtr: ptr}; identifier: WriteString(token.name); intConstant: WriteWord(token.ival); longConstant: WriteLong(token.lval); + longlongConstant: begin + WriteLong(token.qval.lo); + WriteLong(token.qval.hi); + end; doubleConstant: WriteDouble(token.rval); stringConstant: begin WriteLongString(token.sval); @@ -1331,6 +1335,10 @@ var identifier: token.name := ReadString; intConstant: token.ival := ReadWord; longConstant: token.lval := ReadLong; + longlongConstant: begin + token.qval.lo := ReadLong; + token.qval.hi := ReadLong; + end; doubleConstant: token.rval := ReadDouble; stringConstant: begin token.sval := ReadLongString; diff --git a/Native.pas b/Native.pas index 9927b49..1aef324 100644 --- a/Native.pas +++ b/Native.pas @@ -346,7 +346,7 @@ procedure WriteNative (opcode: integer; mode: addressingMode; operand: integer; label 1; type - rkind = (k1,k2,k3); {cnv record types} + rkind = (k1,k2,k3,k4); {cnv record types} var ch: char; {temp storage for string constants} @@ -355,7 +355,8 @@ var case rkind of k1: (rval: real;); k2: (dval: double;); - k3: (ival1,ival2,ival3,ival4: integer;); + k3: (qval: longlong); + k4: (ival1,ival2,ival3,ival4: integer;); end; count: integer; {number of constants to repeat} i,j,k: integer; {loop variables} @@ -606,6 +607,13 @@ case mode of CnOut2(long(lval).lsw); CnOut2(long(lval).msw); end; + cgQuad,cgUQuad : begin + cnv.qval := icptr(name)^.qval; + CnOut2(cnv.ival1); + CnOut2(cnv.ival2); + CnOut2(cnv.ival3); + CnOut2(cnv.ival4); + end; cgReal : begin cnv.rval := icptr(name)^.rval; CnOut2(cnv.ival1); @@ -2025,6 +2033,18 @@ case callNum of 76: sp := @'~STACKERR'; {CC} 77: sp := @'~LOADSTRUCT'; {CC} 78: sp := @'~DIV4'; {CC} + 79: sp := @'~MUL8'; + 80: sp := @'~UMUL8'; + 81: sp := @'~CDIV8'; + 82: sp := @'~UDIV8'; + 83: sp := @'~CNVLONGLONGREAL'; + 84: sp := @'~CNVULONGLONGREAL'; + 85: sp := @'~SHL8'; + 86: sp := @'~ASHR8'; + 87: sp := @'~LSHR8'; + 88: sp := @'~SCMP8'; + 89: sp := @'~CNVREALLONGLONG'; + 90: sp := @'~CNVREALULONGLONG'; otherwise: Error(cge1); end; {case} diff --git a/ORCACDefs/inttypes.h b/ORCACDefs/inttypes.h index d4ed0a1..8d3dbba 100644 --- a/ORCACDefs/inttypes.h +++ b/ORCACDefs/inttypes.h @@ -7,15 +7,6 @@ * ****************************************************************/ -/* - * Note: The format specifier macros defined here generally comply with the - * C99 and C11 standards, except that those associated with intmax_t and - * uintmax_t correspond to their non-standard definitions as 32-bit types. - * - * The functions that the standards specify should be declared in this header - * are not available. - */ - #ifndef __inttypes__ #define __inttypes__ @@ -26,25 +17,31 @@ #define PRId8 "d" /* int8_t */ #define PRId16 "d" /* int16_t */ #define PRId32 "ld" /* int32_t */ +#define PRId64 "lld" /* int64_t */ #define PRIdLEAST8 "d" /* int_least8_t */ #define PRIdLEAST16 "d" /* int_least16_t */ #define PRIdLEAST32 "ld" /* int_least32_t */ +#define PRIdLEAST64 "lld" /* int_least64_t */ #define PRIdFAST8 "d" /* int_fast8_t */ #define PRIdFAST16 "d" /* int_fast16_t */ #define PRIdFAST32 "ld" /* int_fast32_t */ -#define PRIdMAX "ld" /* intmax_t */ +#define PRIdFAST64 "lld" /* int_fast64_t */ +#define PRIdMAX "jd" /* intmax_t */ #define PRIdPTR "ld" /* intptr_t */ #define PRIi8 "i" /* int8_t */ #define PRIi16 "i" /* int16_t */ #define PRIi32 "li" /* int32_t */ +#define PRIi64 "lli" /* int64_t */ #define PRIiLEAST8 "i" /* int_least8_t */ #define PRIiLEAST16 "i" /* int_least16_t */ #define PRIiLEAST32 "li" /* int_least32_t */ +#define PRIiLEAST64 "lli" /* int_least64_t */ #define PRIiFAST8 "i" /* int_fast8_t */ #define PRIiFAST16 "i" /* int_fast16_t */ #define PRIiFAST32 "li" /* int_fast32_t */ -#define PRIiMAX "li" /* intmax_t */ +#define PRIiFAST64 "lli" /* int_fast64_t */ +#define PRIiMAX "ji" /* intmax_t */ #define PRIiPTR "li" /* intptr_t */ /* fprintf macros for unsigned integers */ @@ -52,49 +49,61 @@ #define PRIo8 "o" /* uint8_t */ #define PRIo16 "o" /* uint16_t */ #define PRIo32 "lo" /* uint32_t */ +#define PRIo64 "llo" /* uint64_t */ #define PRIoLEAST8 "o" /* uint_least8_t */ #define PRIoLEAST16 "o" /* uint_least16_t */ #define PRIoLEAST32 "lo" /* uint_least32_t */ +#define PRIoLEAST64 "llo" /* uint_least64_t */ #define PRIoFAST8 "o" /* uint_fast8_t */ #define PRIoFAST16 "o" /* uint_fast16_t */ #define PRIoFAST32 "lo" /* uint_fast32_t */ -#define PRIoMAX "lo" /* uintmax_t */ +#define PRIoFAST64 "llo" /* uint_fast64_t */ +#define PRIoMAX "jo" /* uintmax_t */ #define PRIoPTR "lo" /* uintptr_t */ #define PRIu8 "u" /* uint8_t */ #define PRIu16 "u" /* uint16_t */ #define PRIu32 "lu" /* uint32_t */ +#define PRIu64 "llu" /* uint64_t */ #define PRIuLEAST8 "u" /* uint_least8_t */ #define PRIuLEAST16 "u" /* uint_least16_t */ #define PRIuLEAST32 "lu" /* uint_least32_t */ +#define PRIuLEAST64 "llu" /* uint_least64_t */ #define PRIuFAST8 "u" /* uint_fast8_t */ #define PRIuFAST16 "u" /* uint_fast16_t */ #define PRIuFAST32 "lu" /* uint_fast32_t */ -#define PRIuMAX "lu" /* uintmax_t */ +#define PRIuFAST64 "llu" /* uint_fast64_t */ +#define PRIuMAX "ju" /* uintmax_t */ #define PRIuPTR "lu" /* uintptr_t */ #define PRIx8 "x" /* uint8_t */ #define PRIx16 "x" /* uint16_t */ #define PRIx32 "lx" /* uint32_t */ +#define PRIx64 "llx" /* uint64_t */ #define PRIxLEAST8 "x" /* uint_least8_t */ #define PRIxLEAST16 "x" /* uint_least16_t */ #define PRIxLEAST32 "lx" /* uint_least32_t */ +#define PRIxLEAST64 "llx" /* uint_least64_t */ #define PRIxFAST8 "x" /* uint_fast8_t */ #define PRIxFAST16 "x" /* uint_fast16_t */ #define PRIxFAST32 "lx" /* uint_fast32_t */ -#define PRIxMAX "lx" /* uintmax_t */ +#define PRIxFAST64 "llx" /* uint_fast64_t */ +#define PRIxMAX "jx" /* uintmax_t */ #define PRIxPTR "lx" /* uintptr_t */ #define PRIX8 "X" /* uint8_t */ #define PRIX16 "X" /* uint16_t */ #define PRIX32 "lX" /* uint32_t */ +#define PRIX64 "llX" /* uint64_t */ #define PRIXLEAST8 "X" /* uint_least8_t */ #define PRIXLEAST16 "X" /* uint_least16_t */ #define PRIXLEAST32 "lX" /* uint_least32_t */ +#define PRIXLEAST64 "llX" /* uint_least64_t */ #define PRIXFAST8 "X" /* uint_fast8_t */ #define PRIXFAST16 "X" /* uint_fast16_t */ #define PRIXFAST32 "lX" /* uint_fast32_t */ -#define PRIXMAX "lX" /* uintmax_t */ +#define PRIXFAST64 "llX" /* uint_fast64_t */ +#define PRIXMAX "jX" /* uintmax_t */ #define PRIXPTR "lX" /* uintptr_t */ /* fscanf macros for signed integers */ @@ -102,25 +111,31 @@ #define SCNd8 "hhd" /* int8_t */ #define SCNd16 "hd" /* int16_t */ #define SCNd32 "ld" /* int32_t */ +#define SCNd64 "lld" /* int64_t */ #define SCNdLEAST8 "hhd" /* int_least8_t */ #define SCNdLEAST16 "hd" /* int_least16_t */ #define SCNdLEAST32 "ld" /* int_least32_t */ +#define SCNdLEAST64 "lld" /* int_least64_t */ #define SCNdFAST8 "hd" /* int_fast8_t */ #define SCNdFAST16 "hd" /* int_fast16_t */ #define SCNdFAST32 "ld" /* int_fast32_t */ -#define SCNdMAX "ld" /* intmax_t */ +#define SCNdFAST64 "lld" /* int_fast64_t */ +#define SCNdMAX "jd" /* intmax_t */ #define SCNdPTR "ld" /* intptr_t */ #define SCNi8 "hhi" /* int8_t */ #define SCNi16 "hi" /* int16_t */ #define SCNi32 "li" /* int32_t */ +#define SCNi64 "lli" /* int64_t */ #define SCNiLEAST8 "hhi" /* int_least8_t */ #define SCNiLEAST16 "hi" /* int_least16_t */ #define SCNiLEAST32 "li" /* int_least32_t */ +#define SCNiLEAST64 "lli" /* int_least64_t */ #define SCNiFAST8 "hi" /* int_fast8_t */ #define SCNiFAST16 "hi" /* int_fast16_t */ #define SCNiFAST32 "li" /* int_fast32_t */ -#define SCNiMAX "li" /* intmax_t */ +#define SCNiFAST64 "lli" /* int_fast64_t */ +#define SCNiMAX "ji" /* intmax_t */ #define SCNiPTR "li" /* intptr_t */ /* fscanf macros for unsigned integers */ @@ -128,53 +143,63 @@ #define SCNo8 "hho" /* uint8_t */ #define SCNo16 "ho" /* uint16_t */ #define SCNo32 "lo" /* uint32_t */ +#define SCNo64 "llo" /* uint64_t */ #define SCNoLEAST8 "hho" /* uint_least8_t */ #define SCNoLEAST16 "ho" /* uint_least16_t */ #define SCNoLEAST32 "lo" /* uint_least32_t */ +#define SCNoLEAST64 "llo" /* uint_least64_t */ #define SCNoFAST8 "ho" /* uint_fast8_t */ #define SCNoFAST16 "ho" /* uint_fast16_t */ #define SCNoFAST32 "lo" /* uint_fast32_t */ -#define SCNoMAX "lo" /* uintmax_t */ +#define SCNoFAST64 "llo" /* uint_fast64_t */ +#define SCNoMAX "jo" /* uintmax_t */ #define SCNoPTR "lo" /* uintptr_t */ #define SCNu8 "hhu" /* uint8_t */ #define SCNu16 "hu" /* uint16_t */ #define SCNu32 "lu" /* uint32_t */ +#define SCNu64 "llu" /* uint64_t */ #define SCNuLEAST8 "hhu" /* uint_least8_t */ #define SCNuLEAST16 "hu" /* uint_least16_t */ #define SCNuLEAST32 "lu" /* uint_least32_t */ +#define SCNuLEAST64 "llu" /* uint_least64_t */ #define SCNuFAST8 "hu" /* uint_fast8_t */ #define SCNuFAST16 "hu" /* uint_fast16_t */ #define SCNuFAST32 "lu" /* uint_fast32_t */ -#define SCNuMAX "lu" /* uintmax_t */ +#define SCNuFAST64 "llu" /* uint_fast64_t */ +#define SCNuMAX "ju" /* uintmax_t */ #define SCNuPTR "lu" /* uintptr_t */ #define SCNx8 "hhx" /* uint8_t */ #define SCNx16 "hx" /* uint16_t */ #define SCNx32 "lx" /* uint32_t */ +#define SCNx64 "llx" /* uint64_t */ #define SCNxLEAST8 "hhx" /* uint_least8_t */ #define SCNxLEAST16 "hx" /* uint_least16_t */ #define SCNxLEAST32 "lx" /* uint_least32_t */ +#define SCNxLEAST64 "llx" /* uint_least64_t */ #define SCNxFAST8 "hx" /* uint_fast8_t */ #define SCNxFAST16 "hx" /* uint_fast16_t */ #define SCNxFAST32 "lx" /* uint_fast32_t */ -#define SCNxMAX "lx" /* uintmax_t */ +#define SCNxFAST64 "llx" /* uint_fast64_t */ +#define SCNxMAX "jx" /* uintmax_t */ #define SCNxPTR "lx" /* uintptr_t */ +#if defined(__ORCAC_HAS_LONG_LONG__) || __STDC_VERSION__ >= 199901L +typedef struct {intmax_t quot,rem;} imaxdiv_t; + +intmax_t imaxabs(intmax_t); +imaxdiv_t imaxdiv(intmax_t, intmax_t); +intmax_t strtoimax(const char * restrict, char ** restrict, int); +uintmax_t strtoumax(const char * restrict, char ** restrict, int); +#endif + /* - * The C99 and C11 standards require the following functions and the - * type imaxdiv_t to be declared here, but they are not currently supported. + * The C99 and C11 standards require the following functions + * to be declared here, but they are not currently supported. * - * intmax_t imaxabs(intmax_t j); - * imaxdiv_t imaxdiv(intmax_t numer, intmax_t denom); - * intmax_t strtoimax(const char * restrict nptr, - * char ** restrict endptr, int base); - * uintmax_t strtoumax(const char * restrict nptr, - * char ** restrict endptr, int base); - * intmax_t wcstoimax(const wchar_t * restrict nptr, - * wchar_t ** restrict endptr, int base); - * uintmax_t wcstoumax(const wchar_t * restrict nptr, - * wchar_t ** restrict endptr, int base); + * intmax_t wcstoimax(const wchar_t * restrict, wchar_t ** restrict, int); + * uintmax_t wcstoumax(const wchar_t * restrict, wchar_t ** restrict, int); */ #endif diff --git a/ORCACDefs/limits.h b/ORCACDefs/limits.h index 06e2c0d..213b212 100644 --- a/ORCACDefs/limits.h +++ b/ORCACDefs/limits.h @@ -29,5 +29,10 @@ #define UINT_MAX 65535u #define ULONG_MAX 4294967295u #define USHRT_MAX 65535u +#if defined(__ORCAC_HAS_LONG_LONG__) || __STDC_VERSION__ >= 199901L +#define LLONG_MIN (-9223372036854775807-1) +#define LLONG_MAX 9223372036854775807 +#define ULLONG_MAX 18446744073709551615u +#endif #endif diff --git a/ORCACDefs/stdint.h b/ORCACDefs/stdint.h index 6b54104..a425c50 100644 --- a/ORCACDefs/stdint.h +++ b/ORCACDefs/stdint.h @@ -7,12 +7,6 @@ * ****************************************************************/ -/* - * Note: This header mostly complies with the C99 and C11 standards, - * except that 64-bit types are not provided because ORCA/C does not - * support them. See comments below for further details. - */ - #ifndef __stdint__ #define __stdint__ @@ -20,80 +14,122 @@ typedef signed char int8_t; typedef short int16_t; typedef long int32_t; +#if defined(__ORCAC_HAS_LONG_LONG__) || __STDC_VERSION__ >= 199901L +typedef long long int64_t; +#endif typedef unsigned char uint8_t; typedef unsigned short uint16_t; typedef unsigned long uint32_t; +#if defined(__ORCAC_HAS_LONG_LONG__) || __STDC_VERSION__ >= 199901L +typedef unsigned long long uint64_t; +#endif /* Minimum-width integer types */ typedef signed char int_least8_t; typedef short int_least16_t; typedef long int_least32_t; +#if defined(__ORCAC_HAS_LONG_LONG__) || __STDC_VERSION__ >= 199901L +typedef long long int_least64_t; +#endif typedef unsigned char uint_least8_t; typedef unsigned short uint_least16_t; typedef unsigned long uint_least32_t; +#if defined(__ORCAC_HAS_LONG_LONG__) || __STDC_VERSION__ >= 199901L +typedef unsigned long long uint_least64_t; +#endif /* Fastest minimum-width integer types */ typedef short int_fast8_t; /* Note: 16-bit type */ typedef short int_fast16_t; typedef long int_fast32_t; +#if defined(__ORCAC_HAS_LONG_LONG__) || __STDC_VERSION__ >= 199901L +typedef long long int_fast64_t; +#endif typedef unsigned short uint_fast8_t; /* Note: 16-bit type */ typedef unsigned short uint_fast16_t; typedef unsigned long uint_fast32_t; +#if defined(__ORCAC_HAS_LONG_LONG__) || __STDC_VERSION__ >= 199901L +typedef unsigned long long uint_fast64_t; +#endif /* Integer types capable of holding object pointers */ typedef long intptr_t; typedef unsigned long uintptr_t; /* Greatest-width integer types */ -/* - * Note: In C99 and C11, these are required to be at least 64 bits. - * Since ORCA/C does not currently support 64-bit integer types, - * they are currently defined as 32-bit types instead. - */ -typedef long intmax_t; -typedef unsigned long uintmax_t; +#if defined(__ORCAC_HAS_LONG_LONG__) || __STDC_VERSION__ >= 199901L +typedef long long intmax_t; +typedef unsigned long long uintmax_t; +#endif /* Limits of exact-width integer types */ #define INT8_MIN (-128) #define INT16_MIN (-32767-1) #define INT32_MIN (-2147483647-1) +#if defined(__ORCAC_HAS_LONG_LONG__) || __STDC_VERSION__ >= 199901L +#define INT64_MIN (-9223372036854775807-1) +#endif #define INT8_MAX 127 #define INT16_MAX 32767 #define INT32_MAX 2147483647 +#if defined(__ORCAC_HAS_LONG_LONG__) || __STDC_VERSION__ >= 199901L +#define INT64_MAX 9223372036854775807 +#endif #define UINT8_MAX 255 #define UINT16_MAX 65535u #define UINT32_MAX 4294967295u +#if defined(__ORCAC_HAS_LONG_LONG__) || __STDC_VERSION__ >= 199901L +#define UINT64_MAX 18446744073709551615u +#endif /* Limits of minimum-width integer types */ #define INT_LEAST8_MIN (-128) #define INT_LEAST16_MIN (-32767-1) #define INT_LEAST32_MIN (-2147483647-1) +#if defined(__ORCAC_HAS_LONG_LONG__) || __STDC_VERSION__ >= 199901L +#define INT_LEAST64_MIN (-9223372036854775807-1) +#endif #define INT_LEAST8_MAX 127 #define INT_LEAST16_MAX 32767 #define INT_LEAST32_MAX 2147483647 +#if defined(__ORCAC_HAS_LONG_LONG__) || __STDC_VERSION__ >= 199901L +#define INT_LEAST64_MAX 9223372036854775807 +#endif #define UINT_LEAST8_MAX 255 #define UINT_LEAST16_MAX 65535u #define UINT_LEAST32_MAX 4294967295u +#if defined(__ORCAC_HAS_LONG_LONG__) || __STDC_VERSION__ >= 199901L +#define UINT_LEAST64_MAX 18446744073709551615u +#endif /* Limits of fastest minimum-width integer types */ #define INT_FAST8_MIN (-32767-1) #define INT_FAST16_MIN (-32767-1) #define INT_FAST32_MIN (-2147483647-1) +#if defined(__ORCAC_HAS_LONG_LONG__) || __STDC_VERSION__ >= 199901L +#define INT_FAST64_MIN (-9223372036854775807-1) +#endif #define INT_FAST8_MAX 32767 #define INT_FAST16_MAX 32767 #define INT_FAST32_MAX 2147483647 +#if defined(__ORCAC_HAS_LONG_LONG__) || __STDC_VERSION__ >= 199901L +#define INT_FAST64_MAX 9223372036854775807 +#endif #define UINT_FAST8_MAX 65535u #define UINT_FAST16_MAX 65535u #define UINT_FAST32_MAX 4294967295u +#if defined(__ORCAC_HAS_LONG_LONG__) || __STDC_VERSION__ >= 199901L +#define UINT_FAST64_MAX 18446744073709551615u +#endif /* Limits of integer types capable of holding object pointers */ #define INTPTR_MIN (-2147483647-1) @@ -101,10 +137,11 @@ typedef unsigned long uintmax_t; #define UINTPTR_MAX 4294967295u /* Limits of greatest-width integer types */ -/* Note: These limits are smaller than C99 and C11 require. */ -#define INTMAX_MIN (-2147483647-1) -#define INTMAX_MAX 2147483647 -#define UINTMAX_MAX 4294967295u +#if defined(__ORCAC_HAS_LONG_LONG__) || __STDC_VERSION__ >= 199901L +#define INTMAX_MIN (-9223372036854775807-1) +#define INTMAX_MAX 9223372036854775807 +#define UINTMAX_MAX 18446744073709551615u +#endif /* Limits of other integer types */ #define PTRDIFF_MIN (-2147483647-1) @@ -128,14 +165,21 @@ typedef unsigned long uintmax_t; #define INT8_C(val) (val) #define INT16_C(val) (val) #define INT32_C(val) (val ## L) +#if defined(__ORCAC_HAS_LONG_LONG__) || __STDC_VERSION__ >= 199901L +#define INT64_C(val) (val ## LL) +#endif #define UINT8_C(val) (val) #define UINT16_C(val) (val ## U) #define UINT32_C(val) (val ## UL) +#if defined(__ORCAC_HAS_LONG_LONG__) || __STDC_VERSION__ >= 199901L +#define UINT64_C(val) (val ## ULL) +#endif /* Macros for greatest-width integer constants */ -/* Note: These use 32-bit types, consistent with intmax_t and uintmax_t. */ -#define INTMAX_C(val) (val ## L) -#define UINTMAX_C(val) (val ## UL) +#if defined(__ORCAC_HAS_LONG_LONG__) || __STDC_VERSION__ >= 199901L +#define INTMAX_C(val) (val ## LL) +#define UINTMAX_C(val) (val ## ULL) +#endif #endif diff --git a/ORCACDefs/stdlib.h b/ORCACDefs/stdlib.h index 8561a70..2e29570 100644 --- a/ORCACDefs/stdlib.h +++ b/ORCACDefs/stdlib.h @@ -29,6 +29,9 @@ typedef unsigned long size_t; typedef struct {int quot,rem;} div_t; typedef struct {long quot,rem;} ldiv_t; +#if defined(__ORCAC_HAS_LONG_LONG__) || __STDC_VERSION__ >= 199901L +typedef struct {long long quot,rem;} lldiv_t; +#endif #ifndef __KeepNamespacePure__ #define clalloc(x,y) calloc((x),(y)) @@ -45,6 +48,9 @@ int at_quick_exit(void (*__func)(void)); double atof(const char *); int atoi(const char *); long atol(const char *); +#if defined(__ORCAC_HAS_LONG_LONG__) || __STDC_VERSION__ >= 199901L +long long atoll(const char *); +#endif void *bsearch(const void *, const void *, size_t, size_t, int (*__compar)(const void *, const void *)); void *calloc(size_t, size_t); div_t div(int, int); @@ -55,6 +61,10 @@ void free(void *); char *getenv(const char *); long labs(long); ldiv_t ldiv(long, long); +#if defined(__ORCAC_HAS_LONG_LONG__) || __STDC_VERSION__ >= 199901L +long long llabs(long long); +lldiv_t lldiv(long long, long long); +#endif void *malloc(size_t); void qsort(void *, size_t, size_t, int (*__compar)(const void *, const void *)); void quick_exit(int); @@ -64,6 +74,10 @@ void srand(unsigned); double strtod(const char *, char **); long strtol(const char *, char **, int); unsigned long strtoul(const char *, char **, int); +#if defined(__ORCAC_HAS_LONG_LONG__) || __STDC_VERSION__ >= 199901L +long long strtoll(const char * restrict, char ** restrict, int); +unsigned long long strtoull(const char * restrict, char ** restrict, int); +#endif int system(const char *); #endif diff --git a/Parser.pas b/Parser.pas index ee208c3..d8d8813 100644 --- a/Parser.pas +++ b/Parser.pas @@ -98,7 +98,7 @@ type switchRecord = record next,last: switchPtr; {doubly linked list (for inserts)} lab: integer; {label to branch to} - val: longint; {switch value} + val: longlong; {switch value} end; {token stack} @@ -139,7 +139,6 @@ type ); switchSt: ( maxVal: longint; {max switch value} - isLong: boolean; {do long switch?} ln: integer; {temp var number} size: integer; {temp var size} labelCount: integer; {# of switch labels} @@ -188,6 +187,12 @@ var declarationSpecifiersElement: tokenSet; structDeclarationStart: tokenSet; +{-- External procedures ----------------------------------------} + +function slt64(a,b: longlong): boolean; extern; + +function sgt64(a,b: longlong): boolean; extern; + {-- Parser Utility Procedures ----------------------------------} procedure Match {kind: tokenEnum; err: integer}; @@ -454,38 +459,52 @@ var var stPtr: statementPtr; {switch record for this case label} swPtr,swPtr2: switchPtr; {work pointers for inserting new entry} - val: integer; {case label value} + val: longlong; {case label value} begin {CaseStatement} while token.kind = casesy do begin NextToken; {skip the 'case' token} stPtr := GetSwitchRecord; {get the proper switch record} Expression(arrayExpression, [colonch]); {evaluate the branch condition} - val := long(expressionValue).lsw; - if val <> expressionValue then - if not stPtr^.isLong then - expressionValue := val; {convert out-of-range value to (U)Word} + GetLLExpressionValue(val); + if stPtr^.size = cgLongSize then begin {convert out-of-range values} + if val.lo < 0 then + val.hi := -1 + else + val.hi := 0; + end {if} + else if stPtr^.size = cgWordSize then begin + if long(val.lo).lsw < 0 then begin + val.hi := -1; + val.lo := val.lo | $FFFF0000; + end {if} + else begin + val.hi := 0; + val.lo := val.lo & $0000FFFF; + end; {else} + end; {else if} if stPtr = nil then Error(72) else begin new(swPtr2); {create the new label table entry} swPtr2^.lab := GenLabel; Gen1(dc_lab, swPtr2^.lab); - swPtr2^.val := expressionValue; + swPtr2^.val := val; swPtr := stPtr^.switchList; + if val.lo > stPtr^.maxVal then + stPtr^.maxVal := val.lo; if swPtr = nil then begin {enter it in the table} swPtr2^.last := nil; swPtr2^.next := nil; stPtr^.switchList := swPtr2; - stPtr^.maxVal := expressionValue; stPtr^.labelCount := 1; end {if} else begin - while (swPtr^.next <> nil) and (swPtr^.val < expressionValue) do + while (swPtr^.next <> nil) and slt64(swPtr^.val, val) do swPtr := swPtr^.next; - if swPtr^.val = expressionValue then + if (swPtr^.val.lo = val.lo) and (swPtr^.val.hi = val.hi) then Error(73) - else if swPtr^.val > expressionValue then begin + else if sgt64(swPtr^.val, val) then begin swPtr2^.next := swPtr; if swPtr^.last = nil then stPtr^.switchList := swPtr2 @@ -498,7 +517,6 @@ var swPtr2^.next := nil; swPtr2^.last := swPtr; swPtr^.next := swPtr2; - stPtr^.maxVal := expressionValue; end; {else} stPtr^.labelCount := stPtr^.labelCount + 1; end; {else} @@ -751,12 +769,18 @@ var id := FindSymbol(tk, variableSpace, false, true); Gen1Name(pc_lao, 0, id^.name); size := fType^.size; - end; {if} + end {if} + else if fType^.kind = scalarType then + if fType^.baseType in [cgQuad,cgUQuad] then + Gen2t(pc_lod, 0, 0, cgULong); Expression(normalExpression, [semicolonch]); AssignmentConversion(fType, expressionType, lastWasConst, lastConst, true, false); case fType^.kind of - scalarType: Gen2t(pc_str, 0, 0, fType^.baseType); + scalarType: if fType^.baseType in [cgQuad,cgUQuad] then + Gen0t(pc_sto, fType^.baseType) + else + Gen2t(pc_str, 0, 0, fType^.baseType); enumType: Gen2t(pc_str, 0, 0, cgWord); pointerType: Gen2t(pc_str, 0, 0, cgULong); structType, @@ -792,7 +816,6 @@ var statementList := stPtr; stPtr^.kind := switchSt; stPtr^.maxVal := -maxint4; - stPtr^.isLong := false; stPtr^.labelCount := 0; stPtr^.switchLab := GenLabel; stPtr^.switchExit := GenLabel; @@ -809,14 +832,17 @@ var case tp^.kind of scalarType: - if tp^.baseType in [cgLong,cgULong] then begin - stPtr^.isLong := true; + if tp^.baseType in [cgQuad,cgUQuad] then begin + stPtr^.size := cgQuadSize; + stPtr^.ln := GetTemp(cgQuadSize); + Gen2t(pc_str, stPtr^.ln, 0, cgQuad); + end {if} + else if tp^.baseType in [cgLong,cgULong] then begin stPtr^.size := cgLongSize; stPtr^.ln := GetTemp(cgLongSize); Gen2t(pc_str, stPtr^.ln, 0, cgLong); end {if} else if tp^.baseType in [cgByte,cgUByte,cgWord,cgUWord] then begin - stPtr^.isLong := false; stPtr^.size := cgWordSize; stPtr^.ln := GetTemp(cgWordSize); Gen2t(pc_str, stPtr^.ln, 0, cgWord); @@ -825,7 +851,6 @@ var Error(71); enumType: begin - stPtr^.isLong := false; stPtr^.size := cgWordSize; stPtr^.ln := GetTemp(cgWordSize); Gen2t(pc_str, stPtr^.ln, 0, cgWord); @@ -1069,13 +1094,15 @@ var {-------------------------------} exitLab: integer; {label at the end of the jump table} isLong: boolean; {is the case expression long?} + isLongLong: boolean; {is the case expression long long?} swPtr,swPtr2: switchPtr; {switch label table list} begin {EndSwitchStatement} if c99Scope then PopTable; stPtr := statementList; {get the statement record} exitLab := stPtr^.switchExit; {get the exit label} -isLong := stPtr^.isLong; {get the long flag} +isLong := stPtr^.size = cgLongSize; {get the long flag} +isLongLong := stPtr^.size = cgQuadSize; {get the long long flag} swPtr := stPtr^.switchList; {Skip further generation if there were} if swPtr <> nil then begin { no labels. } default := stPtr^.switchDefault; {get a default label} @@ -1083,21 +1110,25 @@ if swPtr <> nil then begin { no labels. } default := exitLab; Gen1(pc_ujp, exitLab); {branch past the indexed jump} Gen1(dc_lab, stPtr^.switchLab); {create the label for the xjp table} - if isLong then {decide on a base type} + if isLongLong then {decide on a base type} + ltp := cgQuad + else if isLong then ltp := cgLong else ltp := cgWord; - if stPtr^.isLong - or (((stPtr^.maxVal-swPtr^.val) div stPtr^.labelCount) > sparse) then + if isLong or isLongLong + or (((stPtr^.maxVal-swPtr^.val.lo) div stPtr^.labelCount) > sparse) then begin {Long expressions and sparse switch statements are handled as a } {series of if-goto tests. } while swPtr <> nil do begin {generate the compares} - if isLong then - GenLdcLong(swPtr^.val) + if isLongLong then + GenLdcQuad(swPtr^.val) + else if isLong then + GenLdcLong(swPtr^.val.lo) else - Gen1t(pc_ldc, long(swPtr^.val).lsw, cgWord); + Gen1t(pc_ldc, long(swPtr^.val.lo).lsw, cgWord); Gen2t(pc_lod, stPtr^.ln, 0, ltp); Gen0t(pc_equ, ltp); Gen1(pc_tjp, swPtr^.lab); @@ -1110,12 +1141,12 @@ if swPtr <> nil then begin { no labels. } else begin {compact word switch statements are handled with xjp} - minVal := long(swPtr^.val).lsw; {record the min label value} + minVal := long(swPtr^.val.lo).lsw; {record the min label value} Gen2t(pc_lod, stPtr^.ln, 0, ltp); {get the value} Gen1t(pc_dec, minVal, cgWord); {adjust the range} Gen1(pc_xjp, ord(stPtr^.maxVal-minVal+1)); {do the indexed jump} while swPtr <> nil do begin {generate the jump table} - while minVal < swPtr^.val do begin + while minVal < swPtr^.val.lo do begin Gen1(pc_add, default); minVal := minVal+1; end; {while} @@ -1846,6 +1877,13 @@ var size := rtree^.token.ival else if rtree^.token.kind in [longconst,ulongconst] then size := rtree^.token.lval + else if rtree^.token.kind in [longlongconst,ulonglongconst] then begin + size := rtree^.token.qval.lo; + with rtree^.token.qval do + if not (((hi = 0) and (lo & $ff000000 = 0)) or + ((hi = -1) and (lo & $ff000000 = $ff000000))) then + Error(6); + end {else if} else begin Error(18); errorFound := true; @@ -1944,7 +1982,13 @@ var variable^.storage := global; if isConstant and (variable^.storage in [external,global,private]) then begin if bitsize = 0 then begin - iPtr^.iVal := expressionValue; + if etype^.baseType in [cgQuad,cgUQuad] then begin + iPtr^.qVal := llExpressionValue; + end {if} + else begin + iPtr^.qval.hi := 0; + iPtr^.iVal := expressionValue; + end; {else} iPtr^.itype := tp^.baseType; InitializeBitField; end; {if} @@ -1952,13 +1996,20 @@ var scalarType: begin bKind := tp^.baseType; - if (bKind in [cgByte..cgULong]) - and (etype^.baseType in [cgByte..cgULong]) then begin - if bKind in [cgLong,cgULong] then + if (etype^.baseType in [cgByte..cgULong,cgQuad,cgUQuad]) + and (bKind in [cgByte..cgULong,cgQuad,cgUQuad]) then begin + if bKind in [cgLong,cgULong,cgQuad,cgUQuad] then if eType^.baseType = cgUByte then iPtr^.iVal := iPtr^.iVal & $000000FF else if eType^.baseType = cgUWord then iPtr^.iVal := iPtr^.iVal & $0000FFFF; + if bKind in [cgQuad,cgUQuad] then + if etype^.baseType in [cgByte..cgULong] then + if (etype^.baseType in [cgByte,cgWord,cgLong]) + and (iPtr^.iVal < 0) then + iPtr^.qVal.hi := -1 + else + iPtr^.qVal.hi := 0; goto 3; end; {if} if bKind in [cgReal,cgDouble,cgComp,cgExtended] then begin @@ -2015,6 +2066,14 @@ var Error(47); errorFound := true; end {else} + else if etype^.baseType in [cgQuad,cgUQuad] then + if (llExpressionValue.hi = 0) and + (llExpressionValue.lo = 0) then + iPtr^.iType := cgULong + else begin + Error(47); + errorFound := true; + end {else} else begin Error(48); errorFound := true; @@ -2056,11 +2115,25 @@ var operator := tree^.token.kind; while operator in [plusch,minusch] do begin with tree^.right^.token do - if kind in [intConst,longConst] then begin + if kind in [intConst,uintconst,longConst,ulongconst, + longlongConst,ulonglongconst] then begin if kind = intConst then offSet2 := ival - else + else if kind = uintConst then + offset2 := ival & $0000ffff + else if kind in [longConst,ulongconst] then begin offset2 := lval; + if (lval & $ff000000 <> 0) + and (lval & $ff000000 <> $ff000000) then + Error(6); + end {else if} + else {if kind = longlongConst then} begin + offset2 := qval.lo; + with qval do + if not (((hi = 0) and (lo & $ff000000 = 0)) or + ((hi = -1) and (lo & $ff000000 = $ff000000))) then + Error(6); + end; {else} if operator = plusch then offset := offset + offset2 else @@ -2602,6 +2675,8 @@ var mySkipDeclarator: boolean; {value of skipDeclarator to generate} myTypeSpec: typePtr; {value of typeSpec to generate} myDeclarationModifiers: tokenSet; {all modifiers in this declaration} + + isLongLong: boolean; {is this a "long long" type?} procedure FieldList (tp: typePtr; kind: typeKind); @@ -2799,11 +2874,19 @@ var else if (typeSpecifiers = [longsy]) or (typeSpecifiers = [signedsy,longsy]) or (typeSpecifiers = [longsy,intsy]) - or (typeSpecifiers = [signedsy,longsy,intsy]) then - myTypeSpec := longPtr + or (typeSpecifiers = [signedsy,longsy,intsy]) then begin + if isLongLong then + myTypeSpec := longLongPtr + else + myTypeSpec := longPtr; + end {else if} else if (typeSpecifiers = [unsignedsy,longsy]) - or (typeSpecifiers = [unsignedsy,longsy,intsy]) then - myTypeSpec := uLongPtr + or (typeSpecifiers = [unsignedsy,longsy,intsy]) then begin + if isLongLong then + myTypeSpec := uLongLongPtr + else + myTypeSpec := uLongPtr; + end {else if} else if typeSpecifiers = [floatsy] then myTypeSpec := floatPtr else if typeSpecifiers = [doublesy] then @@ -2829,6 +2912,7 @@ myDeclarationModifiers := []; typeSpecifiers := []; typeDone := false; isConstant := false; +isLongLong := false; while token.kind in allowedTokens do begin case token.kind of {storage class specifiers} @@ -2918,9 +3002,11 @@ while token.kind in allowedTokens do begin if typeDone then UnexpectedTokenError(expectedNext) else if token.kind in typeSpecifiers then begin - if (token.kind = longsy) - and (typeSpecifiers <= [signedsy,unsignedsy,longsy,intsy]) then - Error(134) + if (token.kind = longsy) and + ((myTypeSpec = longPtr) or (myTypeSpec = uLongPtr)) then begin + isLongLong := true; + ResolveType; + end else UnexpectedTokenError(expectedNext); end {if} @@ -4166,12 +4252,19 @@ var {do assignment conversions} while tree^.token.kind = castoper do tree := tree^.left; - isConstant := tree^.token.class in [intConstant,longConstant]; + isConstant := + tree^.token.class in [intConstant,longConstant,longlongConstant]; if isConstant then if tree^.token.class = intConstant then val := tree^.token.ival - else - val := tree^.token.lval; + else if tree^.token.class = longConstant then + val := tree^.token.lval + else {if tree^.token.class = longlongConstant then} begin + if (tree^.token.qval.hi = 0) and (tree^.token.qval.lo >= 0) then + val := tree^.token.qval.lo + else + isConstant := false; + end; {else} { if isConstant then if tree^.token.class = intConstant then diff --git a/Printf.pas b/Printf.pas index 9ba63d1..dbfa30f 100644 --- a/Printf.pas +++ b/Printf.pas @@ -49,9 +49,10 @@ implementation const feature_hh = true; - feature_ll = false; + feature_ll = true; feature_s_long = false; feature_n_size = true; + feature_scanf_ld = false; type length_modifier = (default, h, hh, l, ll, j, z, t, ld); @@ -252,6 +253,24 @@ var end; {expect_long} + procedure expect_long_long; + { Verify the current argument is a long long int.} + var + ty: typePtr; + + begin {expect_long_long} + ty := popType; + if ty <> nil then begin + if (ty^.kind <> scalarType) or (not (ty^.baseType in [cgQuad, cgUQuad])) then begin + Warning(@'expected long long int'); + end; {if} + end {if} + else begin + Warning(@'argument missing; expected long long int'); + end; {else} + end; {expect_long_long} + + procedure expect_int; var ty: typePtr; @@ -456,9 +475,9 @@ var has_suppress := true; end; - 'b': begin + 'b', 'P': begin if has_length <> default then - Warning(@'length modifier may not be used with %b'); + Warning(@'length modifier may not be used with %b or %P'); expected := [cgByte, cgUByte]; name := @'char'; end; @@ -489,10 +508,14 @@ var expected := [cgByte, cgUByte]; name := @'char'; end; - l, ll, j, z, t: begin + l, z, t: begin expected := [cgLong, cgULong]; name := @'long'; end; + ll, j: begin + expected := [cgQuad, cgUQuad]; + name := @'long long'; + end; h: begin expected := [cgWord, cgUWord]; name := @'short'; @@ -523,10 +546,14 @@ var expected := [cgByte, cgUByte]; name := @'char'; end; - l, ll, j, z, t: begin + l, z, t: begin expected := [cgLong, cgULong]; name := @'long'; end; + ll, j: begin + expected := [cgQuad, cgUQuad]; + name := @'long long'; + end; h: begin expected := [cgWord, cgUWord]; name := @'short'; @@ -552,6 +579,9 @@ var case has_length of ld: begin + if not feature_scanf_ld then + if not has_suppress then + Warning(@'L length modifier is not currently supported'); expected := [cgExtended]; name := @'long double'; end; @@ -606,7 +636,7 @@ var length_set := ['h', 'l', 'j', 't', 'z', 'L']; flag_set := ['#', '0', '-', '+', ' ']; format_set := ['%', '[', 'b', 'c', 's', 'd', 'i', 'o', 'x', 'X', 'u', - 'f', 'F', 'e', 'E', 'a', 'A', 'g', 'G', 'n', 'p']; + 'f', 'F', 'e', 'E', 'a', 'A', 'g', 'G', 'n', 'p', 'P']; for i := 1 to s^.length do begin @@ -711,9 +741,9 @@ var end; { %b: orca-specific - pascal string } - 'b': begin + 'b', 'P': begin if has_length <> default then - Warning(@'length modifier may not be used with %b'); + Warning(@'length modifier may not be used with %b or %P'); expect_pointer_to([cgByte, cgUByte], @'char'); end; @@ -739,9 +769,12 @@ var hh: expect_pointer_to([cgByte, cgUByte], @'char'); - l, ll, j, z, t: + l, z, t: expect_pointer_to([cgLong, cgULong], @'long'); + ll, j: + expect_pointer_to([cgQuad, cgUQuad], @'long long'); + otherwise: begin if feature_n_size and (has_length = ld) then Warning(@'invalid length modifier'); @@ -767,9 +800,12 @@ var { chars are passed as ints so %hhx can be ignored here. } 'd', 'i', 'o', 'x', 'X', 'u': - if has_length in [l, ll, j, z, t] then begin + if has_length in [l, z, t] then begin expect_long; end + else if has_length in [ll, j] then begin + expect_long_long; + end else if has_length = ld then begin Warning(@'invalid length modifier'); expect_int; @@ -805,7 +841,7 @@ var length_set := ['h', 'l', 'j', 't', 'z', 'L']; flag_set := ['#', '0', '-', '+', ' ']; format_set := ['%', 'b', 'c', 's', 'd', 'i', 'o', 'x', 'X', 'u', - 'f', 'F', 'e', 'E', 'a', 'A', 'g', 'G', 'n', 'p']; + 'f', 'F', 'e', 'E', 'a', 'A', 'g', 'G', 'n', 'p', 'P']; for i := 1 to s^.length do begin c := s^.str[i]; diff --git a/Scanner.asm b/Scanner.asm index 805fa5b..9d25ffd 100644 --- a/Scanner.asm +++ b/Scanner.asm @@ -53,6 +53,54 @@ lb2 iny next character return 4:val end +**************************************************************** +* +* Convertsll - Convert a string to a long long integer +* +* Inputs: +* qval - pointer to location to save value +* str - pointer to the string +* +* Outputs: +* Saves the value to [qval]. +* +* Notes: +* Assumes the string is valid. +* +**************************************************************** +* +Convertsll start scanner +disp equ 0 displacement into the string +count equ 2 number of characters remaining to read + + subroutine (4:qval,4:str),4 + + lda [str] set count to length of string + and #$00FF + sta count + lda #1 start reading from character 1 + sta disp + ph8 #0 initialize the number to zero + bra lb1a +lb1 ph8 #10 multiply by 10 + jsl ~UMUL8 +lb1a pea $0000 + pea $0000 + pea $0000 + ldy disp + lda [str],Y add in the new digit + and #$000F + pha + jsl ~ADD8 +lb2 inc disp next character + dec count + bne lb1 + + pl8 [qval] save the value + + return + end + **************************************************************** * * KeyPress - Has a key been pressed? diff --git a/Scanner.macros b/Scanner.macros index 9bfff31..65bd74c 100644 --- a/Scanner.macros +++ b/Scanner.macros @@ -529,3 +529,110 @@ dc i4'&p' ~restm mend + macro +&l ph8 &n1 + lclc &c +&l anop +&c amid &n1,1,1 + aif s:longa=1,.a + rep #%00100000 +.a + aif "&c"="#",.d + aif "&c"="[",.b + aif "&c"<>"{",.c +&c amid &n1,l:&n1,1 + aif "&c"<>"}",.g +&n1 amid &n1,2,l:&n1-2 +&n1 setc (&n1) +.b + ldy #6 +~&SYSCNT lda &n1,y + pha + dey + dey + bpl ~&SYSCNT + ago .e +.c + aif "&c"<>"<",.c1 + pei &n1+6 + pei &n1+4 + pei &n1+2 + pei &n1 + ago .e +.c1 + ldx #6 +~&SYSCNT lda &n1,x + pha + dex + dex + bpl ~&SYSCNT + ago .e +.d +&n1 amid &n1,2,l:&n1-1 + pea +(&n1)|-48 + pea +(&n1)|-32 + pea +(&n1)|-16 + pea &n1 +.e + aif s:longa=1,.f + sep #%00100000 +.f + mexit +.g + mnote "Missing closing '}'",16 + mend + macro +&l pl8 &n1 + lclc &c +&l anop + aif s:longa=1,.a + rep #%00100000 +.a +&c amid &n1,1,1 + aif "&c"<>"{",.b +&c amid &n1,l:&n1,1 + aif "&c"<>"}",.f +&n1 amid &n1,2,l:&n1-2 + pla + sta (&n1) + ldy #2 + pla + sta (&n1),y + ldy #4 + pla + sta (&n1),y + ldy #6 + pla + sta (&n1),y + ago .d +.b + aif "&c"<>"[",.c + pla + sta &n1 + ldy #2 + pla + sta &n1,y + ldy #4 + pla + sta &n1,y + ldy #6 + pla + sta &n1,y + ago .d +.c + pla + sta &n1 + pla + sta &n1+2 + pla + sta &n1+4 + pla + sta &n1+6 +.d + aif s:longa=1,.e + sep #%00100000 +.e + mexit +.f + mnote "Missing closing '}'",16 + mend diff --git a/Scanner.pas b/Scanner.pas index 8316f83..872d921 100644 --- a/Scanner.pas +++ b/Scanner.pas @@ -272,6 +272,7 @@ var lintErrors: set of 1..maxLint; {lint error codes} spaceStr: string[2]; {string ' ' (used in stringization)} quoteStr: string[2]; {string '"' (used in stringization)} + numericConstants: set of tokenClass; {token classes for numeric constants} {-- External procedures; see expression evaluator for notes ----} @@ -413,6 +414,11 @@ function Convertsl(var str: pString): longint; extern; { Return the integer equivalent of the string. Assumes a valid } { 4-byte integer string; supports unsigned values. } +procedure Convertsll(var qval: longlong; var str: pString); extern; + +{ Save the integer equivalent of the string to qval. Assumes a } +{ valid 8-byte integer string; supports unsigned values. } + procedure SetDateTime; extern; @@ -663,8 +669,8 @@ if list or (numErr <> 0) then begin 131: msg := @'numeric constant is too long'; 132: msg := @'static assertion failed'; 133: msg := @'incomplete or function types may not be used here'; - 134: msg := @'''long long'' types are not supported by ORCA/C'; - 135: msg := @'the type _Bool is not supported by ORCA/C'; + {134: msg := @'''long long'' types are not supported by ORCA/C';} + {135: msg := @'the type _Bool is not supported by ORCA/C';} 136: msg := @'complex or imaginary types are not supported by ORCA/C'; 137: msg := @'atomic types are not supported by ORCA/C'; 138: msg := @'unsupported alignment'; @@ -742,6 +748,9 @@ case token.kind of longConst, ulongConst: write(token.lval:1); + + longlongConst, + ulonglongConst: write('0x...'); {TODO implement} doubleConst: write(token.rval:1); @@ -1043,7 +1052,7 @@ if class1 in [identifier,reservedWord] then begin str2 := tk2.name else if class2 = reservedWord then str2 := @reservedWords[kind2] - else if class2 in [intConstant,longConstant,doubleConstant] then + else if class2 in numericConstants then str2 := tk2.numString else begin Error(63); @@ -1067,8 +1076,8 @@ if class1 in [identifier,reservedWord] then begin goto 1; end {class1 in [identifier,reservedWord]} -else if class1 in [intConstant,longConstant,doubleConstant] then begin - if class2 in [intConstant,longConstant,doubleConstant] then +else if class1 in numericConstants then begin + if class2 in numericConstants then str2 := tk2.numString else if class2 = identifier then str2 := tk2.name @@ -1086,7 +1095,7 @@ else if class1 in [intConstant,longConstant,doubleConstant] then begin tk1 := token; token := lt; goto 1; - end {else if class1 in [intConstant,longConstant,doubleConstant]} + end {else if class1 in numericConstants} else if class1 = stringConstant then begin if class2 = stringConstant then begin @@ -1106,7 +1115,7 @@ else if class1 = stringConstant then begin end {else if} else if kind1 = dotch then begin - if class2 in [intConstant,longConstant,doubleConstant] then begin + if class2 in numericConstants then begin workString := concat(tk1.numString^, tk2.numString^); lt := token; DoNumber(true); @@ -1114,7 +1123,7 @@ else if kind1 = dotch then begin token := lt; goto 1; end; {if} - end {else if class1 in [intConstant,longConstant,doubleConstant]} + end {else if class1 in numericConstants} else if kind1 = poundch then begin if kind2 = poundch then begin @@ -1481,7 +1490,7 @@ if macro^.readOnly then begin {handle special macros} 5: begin {__STDC__} token.kind := intConst; {__ORCAC__} token.numString := @oneStr; {__STDC_NO_...__} - token.class := intConstant; + token.class := intConstant; {__ORCAC_HAS_LONG_LONG__} token.ival := 1; oneStr := '1'; tokenStart := @oneStr[1]; @@ -1846,7 +1855,7 @@ else begin new(tempString); tempString^[0] := chr(0); while - (token.class in [reservedWord,intconstant,longconstant,doubleconstant]) + (token.class in ([reservedWord] + numericConstants)) or (token.kind in [dotch,ident]) do begin if token.kind = ident then tempString^ := concat(tempString^, token.name^) @@ -1854,7 +1863,7 @@ else begin tempString^ := concat(tempString^, '.') else if token.class = reservedWord then tempString^ := concat(tempString^, reservedWords[token.kind]) - else {if token.class in [intconst,longconst,doubleconst] then} + else {if token.class in numericConstants then} tempString^ := concat(tempString^, token.numstring^); NextToken; end; {while} @@ -2317,6 +2326,10 @@ var longConstant: if tk1^.token.lval <> tk2^.token.lval then goto 3; + longlongConstant: + if (tk1^.token.qval.lo <> tk2^.token.qval.lo) or + (tk1^.token.qval.hi <> tk2^.token.qval.hi) then + goto 3; doubleConstant: if tk1^.token.rval <> tk2^.token.rval then goto 3; @@ -2831,6 +2844,9 @@ if ch in ['a','d','e','i','l','p','u','w'] then begin { 16 - check for stack errors } FlagPragmas(p_debug); NumericDirective; + if expressionType^.kind = scalarType then + if expressionType^.baseType in [cgQuad,cgUQuad] then + expressionValue := llExpressionValue.lo; val := long(expressionValue).lsw; rangeCheck := odd(val); debugFlag := odd(val >> 1); @@ -2845,7 +2861,10 @@ if ch in ['a','d','e','i','l','p','u','w'] then begin end {else} else if token.name^ = 'lint' then begin FlagPragmas(p_lint); - NumericDirective; + NumericDirective; + if expressionType^.kind = scalarType then + if expressionType^.baseType in [cgQuad,cgUQuad] then + expressionValue := llExpressionValue.lo; lint := long(expressionValue).lsw; lintIsError := true; if token.kind = semicolonch then begin @@ -2879,7 +2898,10 @@ if ch in ['a','d','e','i','l','p','u','w'] then begin { 16 - common subexpression elimination } { 32 - loop invariant removal } FlagPragmas(p_optimize); - NumericDirective; + NumericDirective; + if expressionType^.kind = scalarType then + if expressionType^.baseType in [cgQuad,cgUQuad] then + expressionValue := llExpressionValue.lo; val := long(expressionValue).lsw; peepHole := odd(val); npeepHole := odd(val >> 1); @@ -2976,7 +2998,10 @@ if ch in ['a','d','e','i','l','p','u','w'] then begin { 8 - allow // comments } { 16 - allow mixed decls & use C99 scope rules } FlagPragmas(p_ignore); - NumericDirective; + NumericDirective; + if expressionType^.kind = scalarType then + if expressionType^.baseType in [cgQuad,cgUQuad] then + expressionValue := llExpressionValue.lo; val := long(expressionValue).lsw; skipIllegalTokens := odd(val); allowLongIntChar := odd(val >> 1); @@ -3145,12 +3170,14 @@ var isBin: boolean; {is the value a binary number?} isHex: boolean; {is the value a hex number?} isLong: boolean; {is the value a long number?} + isLongLong: boolean; {is the value a long long number?} isReal: boolean; {is the value a real number?} numIndex: 0..maxLine; {index into workString} sp: stringPtr; {for saving identifier names} stringIndex: 0..maxLine; {length of the number string} unsigned: boolean; {is the number unsigned?} val: integer; {value of a digit} + c1: char; {saved copy of last character} numString: pString; {characters in the number} @@ -3212,11 +3239,29 @@ var end; {GetDigits} + procedure ShiftAndOrValue (shiftCount, nextDigit: integer); + + { Shift the 64-bit value of token.qval left by shiftCount, } + { then binary-or it with nextDigit. } + + begin {ShiftAndOrValue} + while shiftCount > 0 do begin + token.qval.hi := token.qval.hi << 1; + if (token.qval.lo & $80000000) <> 0 then + token.qval.hi := token.qval.hi | 1; + token.qval.lo := token.qval.lo << 1; + shiftCount := shiftCount - 1; + end; {while} + token.qval.lo := token.qval.lo | nextDigit; + end; {ShiftAndOrValue} + + begin {DoNumber} isBin := false; {assume it's not binary} isHex := false; {assume it's not hex} isReal := false; {assume it's an integer} isLong := false; {assume a short integer} +isLongLong := false; unsigned := false; {assume signed numbers} stringIndex := 0; {no digits so far...} if scanWork then begin {set up the scanner} @@ -3276,11 +3321,17 @@ if c2 in ['e','E'] then begin {handle an exponent} end; {if} 1: while c2 in ['l','u','L','U'] do {check for long or unsigned} - if c2 in ['l','L'] then begin - NextChar; - if isLong then + if c2 in ['l','L'] then begin + if isLong or isLongLong then FlagError(156); - isLong := true; + c1 := c2; + NextChar; + if c2 = c1 then begin + NextChar; + isLongLong := true; + end {if} + else + isLong := true; end {if} else {if c2 in ['u','U'] then} begin NextChar; @@ -3293,6 +3344,8 @@ while c2 in ['l','u','L','U'] do {check for long or unsigned} if c2 in ['f','F'] then begin {allow F designator on reals} if unsigned then FlagError(91); + if isLongLong then + FlagError(156); if not isReal then begin FlagError(100); isReal := true; @@ -3300,6 +3353,8 @@ if c2 in ['f','F'] then begin {allow F designator on reals} NextChar; end; {if} numString[0] := chr(stringIndex); {set the length of the string} +if doingPPExpression then + isLongLong := true; if isReal then begin {convert a real constant} token.kind := doubleConst; token.class := doubleConstant; @@ -3315,22 +3370,34 @@ else if numString[1] <> '0' then begin {convert a decimal integer} or (not unsigned and (stringIndex = 5) and (numString > '32767')) or (unsigned and (stringIndex = 5) and (numString > '65535')) then isLong := true; - if (stringIndex > 10) or - ((stringIndex = 10) and (numString > '4294967295')) then begin + if (stringIndex > 10) + or (not unsigned and (stringIndex = 10) and (numString > '2147483647')) + or (unsigned and (stringIndex = 10) and (numString > '4294967295')) then + isLongLong := true; + if (not unsigned and ((stringIndex > 19) or + ((stringIndex = 19) and (numString > '9223372036854775807')))) or + (unsigned and ((stringIndex > 20) or + ((stringIndex = 20) and (numString > '18446744073709551615')))) then begin numString := '0'; if flagOverflows then FlagError(6); end; {if} - if isLong then begin + if isLongLong then begin + token.class := longlongConstant; + Convertsll(token.qval, numString); + if unsigned then + token.kind := ulonglongConst + else begin + token.kind := longlongConst; + end; {else} + end {if} + else if isLong then begin token.class := longConstant; token.lval := Convertsl(numString); if unsigned then token.kind := ulongConst - else begin + else token.kind := longConst; - if token.lval < 0 then - token.kind := ulongConst; - end; {else} end {if} else begin if unsigned then @@ -3342,11 +3409,12 @@ else if numString[1] <> '0' then begin {convert a decimal integer} end; {else} end {else if} else begin {hex, octal, & binary} - token.lval := 0; + token.qval.lo := 0; + token.qval.hi := 0; if isHex then begin i := 3; while i <= length(numString) do begin - if token.lval & $F0000000 <> 0 then begin + if token.qval.hi & $F0000000 <> 0 then begin i := maxint; if flagOverflows then FlagError(6); @@ -3356,7 +3424,7 @@ else begin {hex, octal, & binary} val := (ord(numString[i])-7) & $000F else val := ord(numString[i]) & $000F; - token.lval := (token.lval << 4) | val; + ShiftAndOrValue(4, val); i := i+1; end; {else} end; {while} @@ -3364,7 +3432,7 @@ else begin {hex, octal, & binary} else if isBin then begin i := 3; while i <= length(numString) do begin - if token.lval & $80000000 <> 0 then begin + if token.qval.hi & $80000000 <> 0 then begin i := maxint; if flagOverflows then FlagError(6); @@ -3372,7 +3440,7 @@ else begin {hex, octal, & binary} else begin if not (numString[i] in ['0','1']) then FlagError(121); - token.lval := (token.lval << 1) | (ord(numString[i]) & $0001); + ShiftAndOrValue(1, ord(numString[i]) & $0001); i := i+1; end; {else} end; {while} @@ -3380,7 +3448,7 @@ else begin {hex, octal, & binary} else begin i := 1; while i <= length(numString) do begin - if token.lval & $E0000000 <> 0 then begin + if token.qval.hi & $E0000000 <> 0 then begin i := maxint; if flagOverflows then FlagError(6); @@ -3388,22 +3456,32 @@ else begin {hex, octal, & binary} else begin if numString[i] in ['8','9'] then FlagError(7); - token.lval := (token.lval << 3) | (ord(numString[i]) & $0007); + ShiftAndOrValue(3, ord(numString[i]) & $0007); i := i+1; end; {else} end; {while} end; {else} - if long(token.lval).msw <> 0 then - isLong := true; - if isLong then begin - if unsigned or (token.lval & $80000000 <> 0) then + if token.qval.hi <> 0 then + isLongLong := true; + if not isLongLong then + if long(token.qval.lo).msw <> 0 then + isLong := true; + if isLongLong then begin + if unsigned or (token.qval.hi & $80000000 <> 0) then + token.kind := ulonglongConst + else + token.kind := longlongConst; + token.class := longlongConstant; + end {if} + else if isLong then begin + if unsigned or (token.qval.lo & $80000000 <> 0) then token.kind := ulongConst else token.kind := longConst; token.class := longConstant; end {if} else begin - if (long(token.lval).lsw & $8000) <> 0 then + if (long(token.qval.lo).lsw & $8000) <> 0 then unsigned := true; if unsigned then token.kind := uintConst @@ -3718,6 +3796,8 @@ lintErrors := [51,104,105,110,124,125,128,129,130,147,151,152,153,154,155]; spaceStr := ' '; {strings used in stringization} quoteStr := '"'; + {set of classes for numeric constants} +numericConstants := [intConstant,longConstant,longlongConstant,doubleConstant]; new(mp); {__LINE__} mp^.name := @'__LINE__'; @@ -3782,6 +3862,15 @@ mp^.algorithm := 6; bp := pointer(ord4(macros) + hash(mp^.name)); mp^.next := bp^; bp^ := mp; +new(mp); {__ORCAC_HAS_LONG_LONG__} +mp^.name := @'__ORCAC_HAS_LONG_LONG__'; +mp^.parameters := -1; +mp^.tokens := nil; +mp^.readOnly := true; +mp^.algorithm := 5; +bp := pointer(ord4(macros) + hash(mp^.name)); +mp^.next := bp^; +bp^ := mp; new(mp); {__STDC_NO_ATOMICS__} mp^.name := @'__STDC_NO_ATOMICS__'; mp^.parameters := -1; @@ -3877,7 +3966,7 @@ repeat intConstant : token.ival := -token.ival; longConstant : token.lval := -token.lval; doubleConstant: token.rval := -token.rval; - otherwise: ; + longlongConstant,otherwise: Error(108); end; {case} end {if} else diff --git a/Symbol.pas b/Symbol.pas index 2694d2b..5316e3e 100644 --- a/Symbol.pas +++ b/Symbol.pas @@ -36,6 +36,8 @@ { uInt32Ptr - pointer to the base type for 32-bit unsigned int } { longPtr - pointer to the base type for long } { uLongPtr - pointer to the base type for unsigned long } +{ longLongPtr - pointer to the base type for long long } +{ uLongLongPtr - pointer to base type for unsigned long long } { floatPtr - pointer to the base type for float } { doublePtr - pointer to the base type for double } { compPtr - pointer to the base type for comp } @@ -77,8 +79,9 @@ var {base types} charPtr,sCharPtr,uCharPtr,shortPtr,uShortPtr,intPtr,uIntPtr,int32Ptr, - uInt32Ptr,longPtr,uLongPtr,floatPtr,doublePtr,compPtr,extendedPtr, - boolPtr,stringTypePtr,voidPtr,voidPtrPtr,defaultStruct: typePtr; + uInt32Ptr,longPtr,uLongPtr,longLongPtr,uLongLongPtr,boolPtr, + floatPtr,doublePtr,compPtr,extendedPtr,stringTypePtr,voidPtr, + voidPtrPtr,defaultStruct: typePtr; {---------------------------------------------------------------} @@ -491,6 +494,8 @@ procedure DoGlobals; end; cgLong,cgULong: GenL1(dc_cns, ip^.ival, ip^.count); + cgQuad,cgUQuad: + GenQ1(dc_cns, ip^.qval, ip^.count); cgReal,cgDouble,cgComp,cgExtended: GenR1t(dc_cns, ip^.rval, ip^.count, ip^.itype); cgString: @@ -580,6 +585,8 @@ procedure DoGlobals; end; cgLong,cgULong: GenL1(dc_cns, ip^.ival, 1); + cgQuad,cgUQuad: + GenQ1(dc_cns, ip^.qval, 1); cgReal,cgDouble,cgComp,cgExtended: GenR1t(dc_cns, ip^.rval, 1, ip^.itype); cgString: @@ -979,6 +986,8 @@ var cgDouble: val := $04; cgComp: val := $0A; cgExtended: val := $05; + cgQuad: val := $0A; {same as comp} + cgUQuad: val := $4A; otherwise: val := $01; end; {case} CnOut(val | modifiers); {write the format byte} @@ -1306,6 +1315,24 @@ with uLongPtr^ do begin baseType := cgULong; cType := ctULong; end; {with} +new(longLongPtr); {long long} +with longLongPtr^ do begin + size := cgQuadSize; + saveDisp := 0; + isConstant := false; + kind := scalarType; + baseType := cgQuad; + cType := ctLongLong; + end; {with} +new(uLongLongPtr); {unsigned long long} +with uLongLongPtr^ do begin + size := cgQuadSize; + saveDisp := 0; + isConstant := false; + kind := scalarType; + baseType := cgUQuad; + cType := ctULongLong; + end; {with} new(floatPtr); {real} with floatPtr^ do begin size := cgRealSize; diff --git a/Table.asm b/Table.asm index e154d9f..fbbf4a9 100644 --- a/Table.asm +++ b/Table.asm @@ -284,7 +284,8 @@ charKinds start character set charSym start single character symbols enum ident,0 identifiers ! constants - enum (intconst,uintconst,longconst,ulongconst,doubleconst) + enum (intconst,uintconst,longconst,ulongconst,longlongconst) + enum (ulonglongconst,doubleconst) enum stringconst ! reserved words enum (_Alignassy,_Alignofsy,_Atomicsy,_Boolsy,_Complexsy) @@ -356,6 +357,8 @@ icp start in-coming priority for expression dc i1'200' uintconst dc i1'200' longconst dc i1'200' ulongconst + dc i1'200' longlongconst + dc i1'200' ulonglongconst dc i1'200' doubleconst dc i1'200' stringconst dc i1'200' _Alignassy @@ -521,6 +524,8 @@ isp start in stack priority for expression dc i1'0' uintconst dc i1'0' longconst dc i1'0' ulongconst + dc i1'0' longlongconst + dc i1'0' ulonglongconst dc i1'0' doubleconst dc i1'0' stringconst dc i1'0' _Alignassy @@ -893,7 +898,8 @@ wordHash start reserved word hash table enum ident,0 identifiers ! constants - enum (intconst,uintconst,longconst,ulongconst,doubleconst) + enum (intconst,uintconst,longconst,ulongconst,longlongconst) + enum (ulonglongconst,doubleconst) enum stringconst ! reserved words enum (_Alignassy,_Alignofsy,_Atomicsy,_Boolsy,_Complexsy)