Apple-2gs-SW/ORCA-C
1
0
Fork 0
mirror of https://github.com/byteworksinc/ORCA-C.git synced 2024-12-22 23:29:27 +00:00
Code Issues Projects Releases Wiki Activity

Merge branch 'longlong'

Browse Source 
* longlong:
  In PP expressions, make sure identifiers turn into 0LL.
  Optimize quad == 0 comparisons.
  Do unsigned quad inequalities without loading operands on stack.
  Do quad equality comparisons without loading operands on stack.
  Do unary quad ops without loading operand on stack.
  Do quad add/subtract without loading operands on stack.
  Implement support for doing quad ops without loading operands on stack.
  Evaluate constant expressions with long long and floating operands.
  Let functions store a long long return value directly into a variable in the caller.
  Optimize some quad ops to use interleaved loads and stores.
  Basic infrastructure for using different quadword locations in codegen.
  Allow static evaluation of ? : expressions with long long operands.
  Statically evaluate casts to and from long long.
  Implement conversions from long long to other types in the optimizer.
  Add various intermediate code peephole optimizations.
  Fix a comment.
  Support switch statements using long long expressions.
  Update headers to support long long (and intmax_t typedef'd as long long).
  Add the predefined macro __ORCAC_HAS_LONG_LONG__.
  Do preprocessor arithmetic in intmax_t/uintmax_t (aka long long types).
  Evaluate 64-bit comparisons in constant expressions.
  Add support for real to long long conversions.
  Implement comparisons for signed long long.
  Implement comparisons (>, >=, <, <=) for unsigned long long.
  Support 64-bit decimal constants in code.
  Evaluate arithmetic and shifts in long long constant expressions.
  Update printf/scanf format checker to match recent library changes.
  Implement && and || operators for long long types.
  Implement pc_ind (load indirect) for long long.
  Do not corrupt long long expressions that cannot be evaluated at compile time.
  Report errors in a few cases where the codegen finds unexpected types.
  Slightly optimize stack save code for calls to long long functions.
  Handle long long in pc_equ/pc_neq optimizations.
  Allow unsigned constants in "address+constant" constant expressions.
  Evaluate some kinds of long long operations in constant expressions.
  Implement 64-bit shifts.
  Implement basic peephole optimizations for some 64-bit operations.
  Do not copy CGI.Comments into CGI.pas.
  Generate code for long long to real conversions.
  Don't bogusly push stuff on the stack for conversions to non-long types.
  Implement support for functions returning (unsigned) long long.
  Compute how many bytes of arguments are passed to a function.
  Implement 64-bit division and remainder, signed and unsigned.
  Implement 64-bit multiplication support.
  Allow pointer arithmetic using long long values.
  Implement indirect store/copy operations for 64-bit types.
  Add long long support for a couple lint checks.
  Add long long support for the ! operator.
  Give an error when trying to evaluate constant expressions with long long operands.
  Make expressionValue a saturating approximation of the true value for long long expressions.
  Enable automatic comparison with 0 for long longs.
  Add some support for ++/-- on long long values.
  Add support for emitting 64-bit constants in statically-initialized data.
  Add most of the infrastructure to support 64-bit decimal constants.
  Support 64-bit integer constants in hex/octal/binary formats.
  Initial support for constants with long long types.
  Implement equality/inequality comparisons for 64-bit types.
  Implement remaining conversions of integer types to and from long long.
  Update the debugging format for long long values.
  Begin implementing conversions to and from 64-bit types.
  Implement 64-bit addition and subtraction.
  Add support for new pcodes in optimizer.
  Implement unary negation and bitwise complement for 64-bit types.
  Implement bitwise and/or/xor for 64-bit types.
  Handle (unsigned) long long in the front-end code for binary conversions.
  Restore old order of baseTypeEnum values.
  Implement basic load/store ops for long long.
  Initial code to recognize 'long long' as a type.
This commit is contained in:
Stephen Heumann 2021-02-26 19:48:08 -06:00
commit a44840718e
26 changed files with 4476 additions and 311 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
CCommon.pas
View File

@ -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}

122
CGC.asm
View File

@ -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
****************************************************************
*

249
CGC.macros
View File

@ -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

34
CGC.pas
View File

@ -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 }

49
CGI.Comments
View File

@ -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 }
{ }

17
CGI.Debug
View File

@ -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

75
CGI.pas
View File

@ -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;

487
DAG.pas
View File

@ -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;

4
Debugger.md
View File

@ -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.

104
Exp.macros
View File

@ -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

556
Expression.asm
View File

@ -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

700
Expression.pas
View File

File diff suppressed because it is too large Load Diff

1539
Gen.pas
View File

File diff suppressed because it is too large Load Diff

10
Header.pas
View File

@ -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;

24
Native.pas
View File

@ -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}

89
ORCACDefs/inttypes.h
View File

@ -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

5
ORCACDefs/limits.h
View File

@ -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

84
ORCACDefs/stdint.h
View File

@ -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

14
ORCACDefs/stdlib.h
View File

@ -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

183
Parser.pas
View File

@ -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

58
Printf.pas
View File

@ -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];

48
Scanner.asm
View File

@ -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?

107
Scanner.macros
View File

@ -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

165
Scanner.pas
View File

@ -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

31
Symbol.pas
View File

@ -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;

10
Table.asm
View File

@ -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)