ORCA-C/Expression.pas
Stephen Heumann 50636bd28b Fix code generation for qualified struct or union function parameters.
They were not being properly recognized as structs/unions, so they were being passed by address rather than by value as they should be.

Here is an example affected by this:

struct S {int a,b,c,d;};

int f(struct S s) {
    return s.a + s.b + s.c + s.d;
}

int main(void) {
    const struct S s = {1,2,3,4};
    return f(s);
}
2024-04-01 20:37:51 -05:00

5054 lines
188 KiB
ObjectPascal

{$optimize 1}
{---------------------------------------------------------------}
{ }
{ Expression }
{ }
{ Evaluate expressions }
{ }
{ Note: The expression evaluator uses the scanner to fetch }
{ tokens, but IT IS ALSO USED BY THE SCANNER to evaluate }
{ expressions in preprocessor commands. This circular }
{ dependency is handle by defining all of the expression }
{ evaluator's external types, constants, and variables in the }
{ CCOMMON module. The only procedure from this module used by }
{ the scanner is Expression, which is declared as an external }
{ procedure in the scanner. }
{ }
{ External Variables: }
{ }
{ startExpression - tokens that may start an expression }
{ bitDisp,bitSize - bit field disp, size }
{ unsigned - is the bit field unsigned? }
{ isBitField - is the field a bit field? }
{ }
{ External Subroutines: }
{ }
{ AssignmentConversion - do type checking and conversions for }
{ assignment statements }
{ CompareToZero - Compare the result on tos to zero. }
{ DisposeTree - dispose of an expression tree }
{ DoSelection - Find the displacement & type for a }
{ selection operation }
{ Expression - handle an expression }
{ FreeTemp - place a temporary label in the available label }
{ list }
{ GenerateCode - generate code from a fully formed expression }
{ tree }
{ GetTemp - find a temporary work variable }
{ InitExpression - initialize the expression handler }
{ UsualBinaryConversions - performs the usual binary }
{ conversions }
{ UsualUnaryConversions - performs the usual unary conversions }
{ }
{---------------------------------------------------------------}
unit Expression;
{$LibPrefix '0/obj/'}
interface
uses CCommon, Table, CGI, Scanner, Symbol, MM, Printf;
{$segment 'EXP'}
var
startExpression: tokenSet; {tokens that can start an expression}
{set by DoSelection}
{------------------}
bitDisp,bitSize: integer; {bit field disp, size}
unsigned: boolean; {is the bit field unsigned?}
isBitField: boolean; {is the field a bit field?}
{misc}
{----}
lastwasconst: boolean; {did the last GenerateCode result in an integer constant?}
lastconst: longint; {last integer constant from GenerateCode}
lastWasNullPtrConst: boolean; {did last GenerateCode give a null ptr const?}
{---------------------------------------------------------------}
procedure AssignmentConversion (t1, t2: typePtr; isConstant: boolean;
value: longint; genCode, checkConst: boolean);
{ TOS is of type t2, and is about to be stored to a variable of }
{ type t1 by an assignment or a return statement. Make sure }
{ this is legal, and do any necessary type conversions on t2, }
{ which is on the top of the evaluation stack. Flag an error }
{ if the conversion is illegal. }
{ }
{ parameters: }
{ t1 - type of the variable }
{ t2 - type of the expression }
{ isConstant - is the rhs a constant? }
{ value - if isConstant = true, then this is the value }
{ genCode - should conversion code be generated? }
{ checkConst - check for assignments to constants? }
procedure CompareToZero(op: pcodes);
{ Compare the result on tos to zero. }
{ }
{ This procedure is used by the logical statements to compare }
{ _any_ scalar result to zero, giving a boolean result. }
{ }
{ parameters: }
{ op - operation to use on the compare }
procedure DisposeTree (tree: tokenPtr);
{ dispose of an expression tree }
{ }
{ parameters: }
{ tree - head of the expression tree to dispose of }
procedure DoSelection (lType: typePtr; tree: tokenPtr; var size: longint);
{ Find the displacement & type for a selection operation }
{ }
{ parameters: }
{ lType - structure/union type }
{ id - tag field name }
{ size - disp into the structure/union }
{ }
{ returned in non-local variables: }
{ bitDisp - displacement to bit field }
{ bitSize - size of bit field }
{ unsigned - is the bit field unsigned? }
{ isBitField - is the field a bit field? }
{ }
{ variables: }
{ expressionType - set to the type of the field }
procedure Expression (kind: expressionKind; stopSym: tokenSet);
{ handle an expression }
{ }
{ parameters: }
{ kind - Kind of expression; determines what operations }
{ and what kind of operands are allowed. }
{ stopSym - Set of symbols that can mark the end of an }
{ expression; used to skip tokens after syntax }
{ errors and to block certain operations. For }
{ example, the comma operator is not allowed in }
{ an expression when evaluating a function }
{ parameter list. }
{ }
{ variables: }
{ realExpressionValue - value of a real constant }
{ expression }
{ expressionValue - value of a constant expression }
{ expressionType - type of the constant expression }
procedure FreeTemp(labelNum, size: integer);
{ place a temporary label in the available label list }
{ }
{ parameters: }
{ labelNum - number of the label to free }
{ size - size of the variable }
{ }
{ variables: }
{ tempList - list of free labels }
procedure GenerateCode (tree: tokenPtr);
{ generate code from a fully formed expression tree }
{ }
{ parameters: }
{ tree - top of the expression tree to generate code from }
{ }
{ variables: }
{ expressionType - result type of the expression }
function GetTemp(size: integer): integer;
{ find a temporary work variable }
{ }
{ parameters: }
{ size - size of the variable }
{ }
{ variables: }
{ tempList - list of free labels }
{ }
{ Returns the label number. }
procedure InitExpression;
{ initialize the expression handler }
function UsualBinaryConversions (lType: typePtr): baseTypeEnum;
{ performs the usual binary conversions }
{ }
{ inputs: }
{ lType - type of the left operand }
{ expressionType - type of the right operand }
{ }
{ result: }
{ The base type of the operation to perform is }
{ returned. Any conversion code necessary has been }
{ generated. }
{ }
{ outputs: }
{ expressionType - set to result type }
function UsualUnaryConversions: baseTypeEnum;
{ performs the usual unary conversions }
{ }
{ inputs: }
{ expressionType - type of the operand }
{ }
{ result: }
{ The base type of the operation to perform is returned. }
{ Any conversion code necessary has been generated. }
{ }
{ outputs: }
{ expressionType - set to result type }
procedure GetLLExpressionValue (var val: longlong);
{ get the value of the last integer constant expression as a }
{ long long (whether it had long long type or not). }
{---------------------------------------------------------------}
implementation
const
{notAnOperation is also used in TABLE.ASM}
notAnOperation = 200; {used as the icp for non-operation tokens}
var
{structured constants}
{--------------------}
startTerm: tokenSet; {tokens that can start a term}
{misc}
{----}
errorFound: boolean; {was there are error during generation?}
{-- Procedures imported from the parser ------------------------}
procedure Match (kind: tokenEnum; err: integer); extern;
{ insure that the next token is of the specified type }
{ }
{ parameters: }
{ kind - expected token kind }
{ err - error number if the expected token is not found }
function TypeName: typePtr; extern;
{ process a type name (used for casts and sizeof/_Alignof) }
{ }
{ returns: a pointer to the type }
function MakeFuncIdentifier: identPtr; extern;
{ Make the predefined identifier __func__. }
{ }
{ It is inserted in the symbol table as if the following }
{ declaration appeared at the beginning of the function body: }
{ }
{ static const char __func__[] = "function-name"; }
{ }
{ This must only be called within a function body. }
function MakeCompoundLiteral(tp: typePtr): identPtr; extern;
{ Make the identifier for a compound literal. }
{ }
{ parameters: }
{ tp - the type of the compound literal }
procedure AutoInit (variable: identPtr; line: longint;
isCompoundLiteral: boolean); extern;
{ generate code to initialize an auto variable }
{ }
{ parameters: }
{ variable - the variable to initialize }
{ line - line number (used for debugging) }
{ isCompoundLiteral - initializing a compound literal? }
{-- External unsigned math routines ----------------------------}
function lshr (x,y: longint): longint; extern;
function udiv (x,y: longint): longint; extern;
function uge (x,y: longint): longint; extern;
function ugt (x,y: longint): longint; extern;
function ule (x,y: longint): longint; extern;
function ult (x,y: longint): longint; extern;
function umod (x,y: longint): longint; extern;
function umul (x,y: longint): longint; extern;
{-- External 64-bit math routines ------------------------------}
{ Procedures for arithmetic and shifts compute "x := x OP y". }
procedure umul64 (var x: longlong; y: longlong); extern;
procedure udiv64 (var x: longlong; y: longlong); extern;
procedure div64 (var x: longlong; y: longlong); extern;
procedure umod64 (var x: longlong; y: longlong); extern;
procedure rem64 (var x: longlong; y: longlong); extern;
procedure add64 (var x: longlong; y: longlong); extern;
procedure sub64 (var x: longlong; y: longlong); extern;
procedure shl64 (var x: longlong; y: integer); extern;
procedure ashr64 (var x: longlong; y: integer); extern;
procedure lshr64 (var x: longlong; y: integer); extern;
function ult64(a,b: longlong): integer; extern;
function uge64(a,b: longlong): integer; extern;
function ule64(a,b: longlong): integer; extern;
function ugt64(a,b: longlong): integer; extern;
function slt64(a,b: longlong): integer; extern;
function sge64(a,b: longlong): integer; extern;
function sle64(a,b: longlong): integer; extern;
function sgt64(a,b: longlong): integer; extern;
{-- External conversion functions; imported from CGC.pas -------}
procedure CnvXLL (var result: longlong; val: extended); extern;
procedure CnvXULL (var result: longlong; val: extended); extern;
function CnvLLX (val: longlong): extended; extern;
function CnvULLX (val: longlong): extended; extern;
{---------------------------------------------------------------}
function Unary(tp: baseTypeEnum): baseTypeEnum;
{ usual unary conversions }
{ }
{ This function returns the base type actually loaded on the }
{ stack for a particular data type. This corresponds to C's }
{ usual unary conversions. }
{ }
{ parameter: }
{ tp - data type }
{ }
{ result: }
{ Stack type. }
begin {Unary}
if tp in [cgByte,cgUByte] then
tp := cgWord;
Unary := tp;
end; {Unary}
function UsualBinaryConversions {lType: typePtr): baseTypeEnum};
{ performs the usual binary conversions }
{ }
{ inputs: }
{ lType - type of the left operand }
{ expressionType - type of the right operand }
{ }
{ result: }
{ The base type of the operation to perform is }
{ returned. Any conversion code necessary has been }
{ generated. }
{ }
{ outputs: }
{ expressionType - set to result type }
var
rType: typePtr; {right type}
lt,rt: baseTypeEnum; {work variables}
function CommonRealType (lt, rt: baseTypeEnum): baseTypeEnum;
{ Compute the common real type of two types, where at least }
{ one of the types is a real type. }
{ }
{ inputs: }
{ lt, rt - the two operand types }
{ }
{ outputs: }
{ expressionType - set to result type }
begin {CommonRealType}
if (lt = cgComp) and (rt = cgComp) then
lt := cgComp
else if (lt in [cgExtended,cgComp]) or (rt in [cgExtended,cgComp]) then
lt := cgExtended
else if (lt = cgDouble) or (rt = cgDouble) then
lt := cgDouble
else
lt := cgReal;
CommonRealType := lt;
case lt of
cgReal: expressionType := floatPtr;
cgDouble: expressionType := doublePtr;
cgExtended: expressionType := extendedPtr;
cgComp: expressionType := compPtr;
end; {case}
end; {CommonRealType}
begin {UsualBinaryConversions}
UsualBinaryConversions := cgULong;
if lType^.kind = pointerType then
lType := uLongPtr
else if lType^.kind = scalarType then
if lType^.baseType = cgVoid then begin
lType := uLongPtr;
Error(66);
end; {if}
rType := expressionType;
if rType^.kind = pointerType then
rType := uLongPtr
else if rType^.kind = scalarType then
if rType^.baseType = cgVoid then begin
rType := uLongPtr;
Error(66);
end; {if}
if (lType^.kind = scalarType) and (rType^.kind = scalarType) then begin
lt := Unary(lType^.baseType);
rt := Unary(rType^.baseType);
if lt <> rt then begin
if lt in [cgReal,cgDouble,cgExtended,cgComp] then begin
if rt in [cgWord,cgUWord,cgLong,cgULong,cgQuad,cgUQuad] then
Gen2(pc_cnv, ord(rt), ord(cgExtended));
UsualBinaryConversions := CommonRealType(lt, rt);
end {if}
else if rt in [cgReal,cgDouble,cgExtended,cgComp] then begin
if lt in [cgWord,cgUWord,cgLong,cgULong,cgQuad,cgUQuad] then
Gen2(pc_cnn, ord(lt), ord(cgExtended));
UsualBinaryConversions := CommonRealType(lt, rt);
end {else if}
else if lt = cgUQuad then begin
if rt in [cgWord,cgUWord,cgLong,cgULong] then
Gen2(pc_cnv, ord(rt), ord(cgUQuad));
UsualBinaryConversions := cgUQuad;
expressionType := uLongLongPtr;
end {else if}
else if rt = cgUQuad then begin
if lt in [cgWord,cgUWord,cgLong,cgULong] then
Gen2(pc_cnn, ord(lt), ord(cgUQuad));
UsualBinaryConversions := cgUQuad;
expressionType := uLongLongPtr;
end {else if}
else if lt = cgQuad then begin
if rt in [cgWord,cgUWord,cgLong,cgULong] then
Gen2(pc_cnv, ord(rt), ord(cgQuad));
UsualBinaryConversions := cgQuad;
expressionType := longLongPtr;
end {else if}
else if rt = cgQuad then begin
if lt in [cgWord,cgUWord,cgLong,cgULong] then
Gen2(pc_cnn, ord(lt), ord(cgQuad));
UsualBinaryConversions := cgQuad;
expressionType := longLongPtr;
end {else if}
else if lt = cgULong then begin
if rt in [cgWord,cgUWord] then
Gen2(pc_cnv, ord(rt), ord(cgULong));
UsualBinaryConversions := cgULong;
expressionType := uLongPtr;
end {else if}
else if rt = cgULong then begin
if lt in [cgWord,cgUWord] then
Gen2(pc_cnn, ord(lt), ord(cgULong));
UsualBinaryConversions := cgULong;
expressionType := uLongPtr;
end {else if}
else if lt = cgLong then begin
if rt in [cgWord,cgUWord] then
Gen2(pc_cnv, ord(rt), ord(cgLong));
UsualBinaryConversions := cgLong;
expressionType := longPtr;
end {else if}
else if rt = cgLong then begin
if lt in [cgWord,cgUWord] then
Gen2(pc_cnn, ord(lt), ord(cgLong));
UsualBinaryConversions := cgLong;
expressionType := longPtr;
end {else if}
else {one operand is unsigned in and the other is int} begin
UsualBinaryConversions := cgUWord;
expressionType := uIntPtr;
end; {else}
end {if}
else begin {types are the same}
UsualBinaryConversions := lt;
if lt = cgWord then {update types that may have changed}
expressionType := intPtr;
end; {else}
end {if}
else
Error(66);
end; {UsualBinaryConversions}
function UsualUnaryConversions{: baseTypeEnum};
{ performs the usual unary conversions }
{ }
{ inputs: }
{ expressionType - type of the operand }
{ }
{ result: }
{ The base type of the operation to perform is returned. }
{ Any conversion code necessary has been generated. }
{ }
{ outputs: }
{ expressionType - set to result type }
var
et: baseTypeEnum; {work variables}
begin {UsualUnaryConversions}
UsualUnaryConversions := cgULong;
if expressionType^.kind = scalarType then begin
et := Unary(expressionType^.baseType);
UsualUnaryConversions := et;
if et = cgWord then {update types that may have changed}
expressionType := intPtr;
end {if}
{else if expressionType^.kind in [arrayType,pointerType] then
UsualUnaryConversions := cgULong};
end; {UsualUnaryConversions}
procedure DisposeTree {tree: tokenPtr};
{ dispose of an expression tree }
{ }
{ parameters: }
{ tree - head of the expression tree to dispose of }
begin {DisposeTree}
if tree <> nil then begin
DisposeTree(tree^.left);
DisposeTree(tree^.middle);
DisposeTree(tree^.right);
dispose(tree);
end; {if}
end; {DisposeTree}
procedure ValueExpressionConversions;
{ Perform type conversions applicable to an expression used }
{ for its value. These include lvalue conversion (removing }
{ qualifiers), array-to-pointer conversion, and }
{ function-to-pointer conversion. See C17 section 6.3.2.1. }
{ }
{ variables: }
{ expressionType - set to type after conversions }
begin {ValueExpressionConversions}
expressionType := Unqualify(expressionType);
if expressionType^.kind = arrayType then
expressionType := MakePointerTo(expressionType^.aType)
else if expressionType^.kind = functionType then
expressionType := MakePointerTo(expressionType);
end; {ValueExpressionConversions}
procedure AssignmentConversion {t1, t2: typePtr; isConstant: boolean;
value: longint; genCode, checkConst: boolean};
{ TOS is of type t2, and is about to be stored to a variable of }
{ type t1 by an assignment or a return statement. Make sure }
{ this is legal, and do any necessary type conversions on t2, }
{ which is on the top of the evaluation stack. Flag an error }
{ if the conversion is illegal. }
{ }
{ parameters: }
{ t1 - type of the variable }
{ t2 - type of the expression }
{ isConstant - is the rhs a constant? }
{ value - if isConstant = true, then this is the value }
{ genCode - should conversion code be generated? }
{ checkConst - check for assignments to constants? }
var
baseType1,baseType2: baseTypeEnum; {temp variables (for speed)}
kind1,kind2: typeKind; {temp variables (for speed)}
procedure CheckConstantRange(t1: typePtr; value: longint);
{ Check for situations where an implicit conversion will }
{ change the value of a constant. }
{ }
{ Note: This currently only addresses conversions to 8-bit }
{ or 16-bit integer types, and intentionally does not }
{ distinguish between signed and unsigned types. }
var
min,max: longint; {min/max allowed values}
begin {CheckConstantRange}
if t1^.cType = ctBool then begin
min := 0;
max := 1;
end {if}
else if t1^.baseType in [cgByte,cgUByte] then begin
min := -128;
max := 255;
end {else if}
else if t1^.baseType in [cgWord,cgUWord] then begin
min := -32768;
max := 65536;
end {else if}
else begin
min := -maxint4-1;
max := maxint4;
end; {else}
if (value < min) or (value > max) then
Error(186);
end; {CheckConstantRange}
begin {AssignmentConversion}
kind1 := t1^.kind;
kind2 := t2^.kind;
if genCode then
if checkConst then
if kind2 <> definedType then
if tqConst in t1^.qualifiers then
Error(93)
else if kind1 in [structType,unionType] then
if t1^.constMember then
Error(93);
if kind2 = definedType then
AssignmentConversion(t1, t2^.dType, false, 0, genCode, checkConst)
else if kind1 = definedType then
AssignmentConversion(t1^.dType, t2, false, 0, genCode, checkConst)
else if kind2 in
[scalarType,pointerType,enumType,structType,unionType,arrayType,functionType] then
case kind1 of
scalarType: begin
if ((lint & lintConstantRange) <> 0) then
if isConstant then
CheckConstantRange(t1, value);
baseType1 := t1^.baseType;
if baseType1 in [cgReal,cgDouble,cgComp] then
baseType1 := cgExtended;
if baseType1 = cgString then
Error(64)
else if baseType1 = cgVoid then
Error(65)
else if kind2 = enumType then begin
if genCode then
Gen2(pc_cnv, ord(cgWord), ord(baseType1));
end {else if}
else if kind2 = scalarType then begin
baseType2 := t2^.baseType;
if baseType2 in [cgString,cgVoid] then
Error(47)
else if genCode then begin
if t1^.cType = ctBool then begin
expressionType := t2;
CompareToZero(pc_neq);
end {if}
else
Gen2(pc_cnv, ord(baseType2), ord(baseType1));
end {else if}
end {else if}
else if (t1^.cType = ctBool)
and (kind2 in [pointerType,arrayType]) then begin
if genCode then begin
expressionType := t2;
CompareToZero(pc_neq);
end {if}
end {else if}
else
Error(47);
end;
arrayType: ;
{any errors are handled elsewhere}
functionType,enumConst:
Error(47);
pointerType: begin
if kind2 = pointerType then begin
if not CompTypes(t1, t2) then
Error(47)
else if not looseTypeChecks then
if not (t1^.ptype^.qualifiers >= t2^.ptype^.qualifiers) then
Error(163);
end {if}
else if kind2 = arrayType then begin
if not CompTypes(t1^.ptype, t2^.atype) and
(t1^.ptype^.baseType <> cgVoid) then
Error(47)
else if not looseTypeChecks then
if not (t1^.ptype^.qualifiers >= t2^.atype^.qualifiers) then
Error(163);
end {if}
else if kind2 = scalarType then begin
if isConstant and (value = 0) then begin
if genCode then
Gen2(pc_cnv, ord(t2^.baseType), ord(cgULong));
end {if}
else
Error(47);
end {else if}
else
Error(47);
end;
enumType: begin
if kind2 = scalarType then begin
if ((lint & lintConstantRange) <> 0) then
if isConstant then
CheckConstantRange(intPtr, value);
baseType2 := t2^.baseType;
if baseType2 in [cgString,cgVoid] then
Error(47)
else if genCode then
Gen2(pc_cnv, ord(baseType2), ord(cgWord));
end {if}
else if kind2 <> enumType then
Error(47);
end;
definedType:
AssignmentConversion(t1^.dType, t2, isConstant, value, genCode,
checkConst);
structType,unionType:
if not CompTypes(t1, t2) then
Error(47);
otherwise: Error(57);
end; {case T1^.kind}
expressionType := t1; {set the type of the expression}
end; {AssignmentConversion}
function ExpressionTree (kind: expressionKind; stopSym: tokenSet): tokenPtr;
{ generate an expression tree }
{ }
{ Returns a pointer to the generated tree. The pointer is }
{ nil, and the variable errorFound is set to true, if an }
{ error is found. }
{ }
{ parameters: }
{ kind - Kind of expression; determines what operations }
{ and what kind of operands are allowed. }
{ stopSym - Set of symbols that can mark the end of an }
{ expression; used to skip tokens after syntax }
{ errors and to block certain operations. For }
{ example, the comma operator is not allowed in }
{ an expression when evaluating a function }
{ parameter list. }
label 1,2,3;
var
done,done2: boolean; {for loop termination}
doingSizeof: boolean; {used to test for a sizeof operator}
doingAlignof: boolean; {used to test for an _Alignof operator}
expectingTerm: boolean; {should the next token be a term?}
opStack: tokenPtr; {operation stack}
parenCount: integer; {# of open parenthesis}
stack: tokenPtr; {operand stack}
tType: typePtr; {type for cast/sizeof/etc.}
op,sp: tokenPtr; {work pointers}
procedure ComplexTerm;
{ handle complex terms }
var
done: boolean; {for loop termination}
namePtr: stringPtr; {name of struct/union fields}
sp,tp,tm: tokenPtr; {work pointers}
begin {ComplexTerm}
while token.kind in
[lbrackch,lparench,dotch,minusgtop,plusplusop,minusminusop] do begin
case token.kind of
lbrackch: begin {subscripting}
NextToken; {skip the '['}
new(sp); {evaluate the subscript}
sp^.token.kind := plusch;
sp^.token.class := reservedSymbol;
sp^.left := stack;
stack := stack^.next;
sp^.middle := nil;
sp^.right := ExpressionTree(normalExpression, [rbrackch]);
sp^.next := stack;
stack := sp;
Match(rbrackch,24); {skip the ']'}
new(sp); {resolve the pointer}
sp^.token.kind := uasterisk;
sp^.token.class := reservedSymbol;
sp^.left := stack;
sp^.middle := nil;
sp^.right := nil;
sp^.next := stack^.next;
stack := sp;
end;
lparench: begin {function call}
NextToken;
new(sp); {create a parameter list terminator}
sp^.token.kind := parameteroper;
sp^.token.class := reservedSymbol;
sp^.left := nil;
sp^.middle := nil;
sp^.right := nil;
sp^.next := stack;
stack := sp;
if token.kind <> rparench {evaluate the parameters}
then begin
done := false;
repeat
if token.kind in [rparench,eofsy] then begin
done := true;
Error(35);
end {if}
else begin
new(sp);
sp^.token.kind := parameteroper;
sp^.token.class := reservedSymbol;
sp^.left := nil;
sp^.middle :=
ExpressionTree(normalExpression, [rparench,commach]);
sp^.right := stack;
sp^.next := stack^.next;
stack := sp;
if token.kind = commach then
NextToken
else
done := true;
end; {else}
until done;
end; {if}
sp := stack;
stack := sp^.next;
sp^.left := stack;
sp^.next := stack^.next;
stack := sp;
Match(rparench,12);
end;
dotch,minusgtop: begin {direct and indirect selection}
if token.kind = minusgtop then begin
new(sp); {e->name == (*e).name}
sp^.token.kind := uasterisk;
sp^.token.class := reservedSymbol;
sp^.left := stack;
sp^.middle := nil;
sp^.right := nil;
sp^.next := stack^.next;
stack := sp;
token.kind := dotch;
token.class := reservedSymbol;
end; {if}
new(sp); {create a record for the selection operator}
sp^.token := token;
sp^.left := stack;
stack := stack^.next;
sp^.middle := nil;
sp^.right := nil;
sp^.next := stack;
stack := sp;
NextToken; {skip the operator}
if token.kind in [ident,typedef] then begin
namePtr := token.name; {record the name}
new(sp); {record the selection field}
sp^.token := token;
sp^.left := nil;
sp^.middle := nil;
sp^.right := nil;
stack^.right := sp; {this becomes the right opnd}
NextToken; {skip the field name}
end {if}
else
Error(9);
end;
plusplusop: begin {postfix ++}
NextToken;
new(sp);
sp^.token.kind := opplusplus;
sp^.token.class := reservedSymbol;
sp^.left := stack;
stack := stack^.next;
sp^.middle := nil;
sp^.right := nil;
sp^.next := stack;
stack := sp;
end;
minusminusop: begin {postfix --}
NextToken;
new(sp);
sp^.token.kind := opminusminus;
sp^.token.class := reservedSymbol;
sp^.left := stack;
stack := stack^.next;
sp^.middle := nil;
sp^.right := nil;
sp^.next := stack;
stack := sp;
end;
otherwise: Error(57);
end; {case}
end; {while}
end; {ComplexTerm}
procedure DoOperand;
{ process an operand }
label 1,2;
var
fnPtr: typePtr; {for defining functions on the fly}
fToken: tokenType; {used to save function name token}
id: identPtr; {pointer to an id's symbol table entry}
np: stringPtr; {for forming global names}
sp: tokenPtr; {work pointer}
begin {DoOperand}
{create an operand on the stack}
new(sp);
sp^.token := token;
sp^.next := stack;
sp^.left := nil;
sp^.middle := nil;
sp^.right := nil;
stack := sp;
{handle the preprocessor 'defined' function}
if kind = preprocessorExpression then
if token.name^ = 'defined' then begin
expandMacros := false;
NextToken;
sp^.token.kind := intconst;
sp^.token.class := intConstant;
if token.kind in [ident,typedef] then begin
sp^.token.ival := ord(IsDefined(token.name));
NextToken;
end {if}
else begin
Match(lparench, 13);
if token.kind in [ident,typedef] then begin
sp^.token.ival := ord(IsDefined(token.name));
NextToken;
end {if}
else begin
Error(9);
sp^.token.ival := 0;
end; {else}
Match(rparench, 12);
end; {else}
expandMacros := true;
goto 1;
end; {if}
{check for illegal use}
id := FindSymbol(token, variableSpace, false, true);
if not (kind in
[normalExpression,initializerExpression,autoInitializerExpression])
then begin
if id <> nil then
if id^.itype^.kind = enumConst then
goto 2;
if kind <> preprocessorExpression then begin
op := opStack;
while op <> nil do begin
if op^.token.kind = sizeofsy then
goto 2;
op := op^.next;
end; {while}
Error(41);
errorFound := true;
end; {if}
end; {if}
2:
{skip the name}
fToken := token;
NextToken;
{in the preprocessor, all identifiers (post macro replacement) become 0}
if kind = preprocessorExpression then begin
stack^.token.class := longlongConstant;
stack^.token.kind := longlongconst;
stack^.token.qval := longlong0;
id := nil;
end {if}
{if the id is not declared, create a function returning integer}
else if id = nil then begin
if (fToken.name^ = '__func__') and (functionTable <> nil) then
id := MakeFuncIdentifier
else if token.kind = lparench then begin
fnPtr := pointer(GCalloc(sizeof(typeRecord)));
{fnPtr^.size := 0;}
{fnPtr^.saveDisp := 0;}
{fnPtr^.qualifiers := [];}
fnPtr^.kind := functionType;
fnPtr^.fType := intPtr;
{fnPtr^.varargs := false;}
{fnPtr^.prototyped := false;}
{fnPtr^.overrideKR := false;}
{fnPtr^.parameterList := nil;}
{fnPtr^.isPascal := false;}
{fnPtr^.toolNum := 0;}
{fnPtr^.dispatcher := 0;}
np := pointer(GMalloc(length(fToken.name^)+1));
CopyString(pointer(np), pointer(fToken.name));
id := NewSymbol(np, fnPtr, ident, variableSpace, declared, false);
if ((lint & lintUndefFn) <> 0) or ((lint & lintC99Syntax) <> 0) then
Error(51);
end {if}
else begin
Error(31);
errorFound := true;
end; {else}
end {if id = nil}
else if id^.itype^.kind = enumConst then begin
stack^.token.class := intConstant;
stack^.token.kind := intconst;
stack^.token.ival := id^.itype^.eval;
end; {else if}
if id <> nil then
id^.used := true;
stack^.id := id; {save the identifier}
ComplexTerm; {handle subscripts, selection, etc.}
1:
end; {DoOperand}
procedure Operation;
{ do an operation }
label 1,2,3,4;
var
baseType: baseTypeEnum; {base type of value to cast}
class: tokenClass; {class of cast token}
ekind: tokenEnum; {kind of constant expression}
kindLeft, kindRight: tokenEnum; {kinds of operands}
lCodeGeneration: boolean; {local copy of codeGeneration}
op: tokenPtr; {work pointer}
op1,op2: longint; {for evaluating constant expressions}
rop1,rop2: extended; {for evaluating fp expressions}
llop1, llop2: longlong; {for evaluating long long expressions}
tp: typePtr; {cast type}
unsigned: boolean; {is the term unsigned?}
function Pop: tokenPtr;
{ pop an operand, returning its pointer }
begin {Pop}
if stack = nil then begin
Error(36);
errorFound := true;
new(stack); {synthesize the missing token}
stack^.token.class := intConstant;
stack^.token.kind := intconst;
stack^.token.ival := 0;
stack^.next := nil;
stack^.left := nil;
stack^.middle := nil;
stack^.right := nil;
end; {if}
Pop := stack;
stack := stack^.next;
end; {Pop}
function RealVal (token: tokenType): extended;
{ convert an operand to a real value }
begin {RealVal}
if token.kind in [intconst,charconst,scharconst,ucharconst] then
RealVal := token.ival
else if token.kind in [uintconst,ushortconst] then begin
if token.ival < 0 then
RealVal := (token.ival & $7FFF) + 32768.0
else
RealVal := token.ival;
end {else if}
else if token.kind = longconst then
RealVal := token.lval
else if token.kind = ulongconst then begin
if token.lval < 0 then
RealVal := (token.lval & $7FFFFFFF) + 2147483648.0
else
RealVal := token.lval;
end {else if}
else if token.kind = longlongconst then
RealVal := CnvLLX(token.qval)
else if token.kind = ulonglongconst then
RealVal := CnvULLX(token.qval)
else
RealVal := token.rval;
end; {RealVal}
function IntVal (token: tokenType): longint;
{ convert an operand to a longint value }
begin {IntVal}
if token.kind in [intconst,charconst,scharconst,ucharconst] then
IntVal := token.ival
else if token.kind in [uintconst,ushortconst] then begin
IntVal := token.ival & $0000FFFF;
end {else if}
else {if token.kind in [longconst,ulongconst] then} begin
IntVal := token.lval;
end; {else}
end; {IntVal}
procedure GetLongLongVal (var result: longlong; token: tokenType);
{ convert an operand to a long long value }
begin {LongLongVal}
if token.kind in [intconst,charconst,scharconst,ucharconst] then begin
result.lo := token.ival;
if result.lo < 0 then
result.hi := -1
else
result.hi := 0;
end {if}
else if token.kind in [uintconst,ushortconst] then begin
result.lo := token.ival & $0000FFFF;
result.hi := 0;
end {else if}
else if token.kind = longconst then begin
result.lo := token.lval;
if result.lo < 0 then
result.hi := -1
else
result.hi := 0;
end {else if}
else if token.kind = ulongconst then begin
result.lo := token.lval;
result.hi := 0;
end {else if}
else {if token.kind in [longlongconst,ulonglongconst] then} begin
result := token.qval;
end; {else}
end; {LongLongVal}
function PPKind (token: tokenType): tokenEnum;
{ adjust kind of token for use in preprocessor expression }
begin {PPKind}
if token.kind in [intconst,longconst] then
PPKind := longlongconst
else if token.kind in [uintconst,ushortconst,ulongconst] then
PPKind := ulonglongconst
else
PPKind := token.kind;
end; {PPKind}
begin {Operation}
op := opStack; {pop the operation}
opStack := op^.next;
case op^.token.kind of
commach: begin {,}
op^.right := Pop;
op^.left := Pop;
end;
eqch, {=}
pluseqop, {+=}
minuseqop, {-=}
asteriskeqop, {*=}
slasheqop, {/=}
percenteqop, {%=}
ltlteqop, {<<=}
gtgteqop, {>>=}
andeqop, {&=}
caroteqop, {^=}
bareqop: begin {|=}
op^.right := Pop;
op^.left := Pop;
end;
colonch: begin {? :}
op^.right := Pop;
op^.middle := Pop;
op^.left := Pop;
if op^.right^.token.kind in [intconst,uintconst,ushortconst,
longconst,ulongconst,longlongconst,ulonglongconst,
charconst,scharconst,ucharconst] then
if op^.left^.token.kind in [intconst,uintconst,ushortconst,
longconst,ulongconst,longlongconst,ulonglongconst,
charconst,scharconst,ucharconst] then
if op^.middle^.token.kind in [intconst,uintconst,ushortconst,
longconst,ulongconst,longlongconst,ulonglongconst,
charconst,scharconst,ucharconst] then begin
kindLeft := op^.middle^.token.kind;
kindRight := op^.right^.token.kind;
{do the usual binary conversions}
if (kindRight = ulonglongconst) or (kindLeft = ulonglongconst) then
ekind := ulonglongconst
else if (kindRight = longlongconst) or (kindLeft = longlongconst) then
ekind := longlongconst
else if (kindRight = ulongconst) or (kindLeft = ulongconst) then
ekind := ulongconst
else if (kindRight = longconst) or (kindLeft = longconst) then
ekind := longconst
else if (kindRight = uintconst) or (kindLeft = uintconst)
or (kindRight = ushortconst) or (kindLeft = ushortconst) then
ekind := uintconst
else
ekind := intconst;
GetLongLongVal(llop1, op^.left^.token);
if (llop1.lo <> 0) or (llop1.hi <> 0) then
GetLongLongVal(llop2, op^.middle^.token)
else
GetLongLongVal(llop2, op^.right^.token);
op^.token.kind := ekind;
if ekind in [longlongconst,ulonglongconst] then begin
op^.token.qval := llop2;
op^.token.class := longlongConstant;
end {if}
else if ekind in [longconst,ulongconst] then begin
op^.token.lval := llop2.lo;
op^.token.class := longConstant;
end {if}
else begin
op^.token.ival := long(llop2.lo).lsw;
op^.token.class := intConstant;
end; {else}
dispose(op^.left);
dispose(op^.right);
dispose(op^.middle);
op^.left := nil;
op^.right := nil;
op^.middle := nil;
end; {if}
end;
questionch: begin {error -> ? should not be unmatched}
Error(29);
errorFound := true;
end;
barbarop, {||}
andandop, {&&}
carotch, {^}
barch, {|}
andch, {&}
eqeqop, {==}
exceqop, {!=}
ltch, {<}
gtch, {>}
lteqop, {<=}
gteqop, {>=}
ltltop, {<<}
gtgtop, {>>}
plusch, {+}
minusch, {-}
asteriskch, {*}
slashch, {/}
percentch: begin {%}
op^.right := Pop;
op^.left := Pop;
kindRight := op^.right^.token.kind;
kindLeft := op^.left^.token.kind;
if kindRight in [intconst,uintconst,ushortconst,longconst,ulongconst,
charconst,scharconst,ucharconst] then begin
if kindLeft in [intconst,uintconst,ushortconst,longconst,ulongconst,
charconst,scharconst,ucharconst] then begin
if kind = preprocessorExpression then
goto 2;
{do the usual binary conversions}
if (kindRight = ulongconst) or (kindLeft = ulongconst) then
ekind := ulongconst
else if (kindRight = longconst) or (kindLeft = longconst) then
ekind := longconst
else if (kindRight = uintconst) or (kindLeft = uintconst)
or (kindRight = ushortconst) or (kindLeft = ushortconst) then
ekind := uintconst
else
ekind := intconst;
{evaluate a constant operation}
unsigned := ekind in [uintconst,ulongconst];
op1 := IntVal(op^.left^.token);
op2 := IntVal(op^.right^.token);
dispose(op^.right);
op^.right := nil;
dispose(op^.left);
op^.left := nil;
case op^.token.kind of
barbarop : begin {||}
op1 := ord((op1 <> 0) or (op2 <> 0));
ekind := intconst;
end;
andandop : begin {&&}
op1 := ord((op1 <> 0) and (op2 <> 0));
ekind := intconst;
end;
carotch : op1 := op1 ! op2; {^}
barch : op1 := op1 | op2; {|}
andch : op1 := op1 & op2; {&}
eqeqop : begin {==}
op1 := ord(op1 = op2);
ekind := intconst;
end;
exceqop : begin {!=}
op1 := ord(op1 <> op2);
ekind := intconst;
end;
ltch : begin {<}
if unsigned then
op1 := ult(op1,op2)
else
op1 := ord(op1 < op2);
ekind := intconst;
end;
gtch : begin {>}
if unsigned then
op1 := ugt(op1,op2)
else
op1 := ord(op1 > op2);
ekind := intconst;
end;
lteqop : begin {<=}
if unsigned then
op1 := ule(op1,op2)
else
op1 := ord(op1 <= op2);
ekind := intconst;
end;
gteqop : begin {>=}
if unsigned then
op1 := uge(op1,op2)
else
op1 := ord(op1 >= op2);
ekind := intconst;
end;
ltltop : begin {<<}
op1 := op1 << op2;
ekind := kindLeft;
end;
gtgtop : begin {>>}
if kindLeft in [uintconst,ushortconst,ulongconst]
then
op1 := lshr(op1,op2)
else
op1 := op1 >> op2;
ekind := kindLeft;
end;
plusch : op1 := op1 + op2; {+}
minusch : op1 := op1 - op2; {-}
asteriskch : if unsigned then {*}
op1 := umul(op1,op2)
else
op1 := op1 * op2;
slashch : begin {/}
if op2 = 0 then begin
if not (kind in [normalExpression,
autoInitializerExpression]) then
Error(109)
else if ((lint & lintOverflow) <> 0) then
Error(129);
op2 := 1;
end; {if}
if unsigned then
op1 := udiv(op1,op2)
else
op1 := op1 div op2;
end;
percentch : begin {%}
if op2 = 0 then begin
if not (kind in [normalExpression,
autoInitializerExpression]) then
Error(109)
else if ((lint & lintOverflow) <> 0) then
Error(129);
op2 := 1;
end; {if}
if unsigned then
op1 := umod(op1,op2)
else
op1 := op1 - (op1 div op2) * op2;
end;
otherwise: Error(57);
end; {case}
if ((lint & lintOverflow) <> 0) then begin
if op^.token.kind in [plusch,minusch,asteriskch,slashch] then
if ekind = intConst then
if op1 <> long(op1).lsw then
Error(128);
if op^.token.kind in [ltltop,gtgtop] then begin
if ekind in [intConst,uintConst] then
if (op2 < 0) or (op2 > 15) then
Error(130);
if ekind in [longConst,ulongConst] then
if (op2 < 0) or (op2 > 31) then
Error(130);
end; {if}
end; {if}
op^.token.kind := ekind;
if ekind in [longconst,ulongconst] then begin
op^.token.lval := op1;
op^.token.class := longConstant;
end {if}
else begin
op^.token.ival := long(op1).lsw;
op^.token.class := intConstant;
end; {else}
goto 1;
end; {if}
end; {if}
2:
if kindRight in [intconst,uintconst,ushortconst,longconst,ulongconst,
longlongconst,ulonglongconst,charconst,scharconst,ucharconst]
then begin
if kindLeft in [intconst,uintconst,ushortconst,longconst,ulongconst,
longlongconst,ulonglongconst,charconst,scharconst,ucharconst]
then begin
if kind = preprocessorExpression then begin
kindLeft := PPKind(op^.left^.token);
kindRight := PPKind(op^.right^.token);
end; {if}
{do the usual binary conversions}
if (kindRight = ulonglongconst) or (kindLeft = ulonglongconst) then
ekind := ulonglongconst
else
ekind := longlongconst;
unsigned := ekind = ulonglongconst;
GetLongLongVal(llop1, op^.left^.token);
GetLongLongVal(llop2, op^.right^.token);
case op^.token.kind of
barbarop : begin {||}
llop1.lo :=
ord((llop1.lo <> 0) or (llop1.hi <> 0) or
(llop2.lo <> 0) or (llop2.hi <> 0));
llop1.hi := 0;
ekind := intconst;
end;
andandop : begin {&&}
llop1.lo :=
ord(((llop1.lo <> 0) or (llop1.hi <> 0)) and
((llop2.lo <> 0) or (llop2.hi <> 0)));
llop1.hi := 0;
ekind := intconst;
end;
carotch : begin {^}
llop1.lo := llop1.lo ! llop2.lo;
llop1.hi := llop1.hi ! llop2.hi;
end;
barch : begin {|}
llop1.lo := llop1.lo | llop2.lo;
llop1.hi := llop1.hi | llop2.hi;
end;
andch : begin {&}
llop1.lo := llop1.lo & llop2.lo;
llop1.hi := llop1.hi & llop2.hi;
end;
eqeqop : begin {==}
llop1.lo := ord((llop1.lo = llop2.lo) and
(llop1.hi = llop2.hi));
llop1.hi := 0;
ekind := intconst;
end;
exceqop : begin {!=}
llop1.lo := ord((llop1.lo <> llop2.lo) or
(llop1.hi <> llop2.hi));
llop1.hi := 0;
ekind := intconst;
end;
ltch : begin {<}
if unsigned then
llop1.lo := ult64(llop1, llop2)
else
llop1.lo := slt64(llop1, llop2);
llop1.hi := 0;
ekind := intconst;
end;
gtch : begin {>}
if unsigned then
llop1.lo := ugt64(llop1, llop2)
else
llop1.lo := sgt64(llop1, llop2);
llop1.hi := 0;
ekind := intconst;
end;
lteqop : begin {<=}
if unsigned then
llop1.lo := ule64(llop1, llop2)
else
llop1.lo := sle64(llop1, llop2);
llop1.hi := 0;
ekind := intconst;
end;
gteqop : begin {>=}
if unsigned then
llop1.lo := uge64(llop1, llop2)
else
llop1.lo := sge64(llop1, llop2);
llop1.hi := 0;
ekind := intconst;
end;
ltltop : begin {<<}
shl64(llop1, long(llop2.lo).lsw);
ekind := kindLeft;
end;
gtgtop : begin {>>}
if kindleft = ulonglongconst then
lshr64(llop1, long(llop2.lo).lsw)
else
ashr64(llop1, long(llop2.lo).lsw);
ekind := kindLeft;
end;
plusch : add64(llop1, llop2); {+}
minusch : sub64(llop1, llop2); {-}
asteriskch : umul64(llop1, llop2); {*}
slashch : begin {/}
if (llop2.lo = 0) and (llop2.hi = 0) then begin
if not (kind in [normalExpression,
autoInitializerExpression]) then
Error(109)
else if ((lint & lintOverflow) <> 0) then
Error(129);
llop2 := longlong1;
end; {if}
if unsigned then
udiv64(llop1, llop2)
else
div64(llop1, llop2);
end;
percentch : begin {%}
if (llop2.lo = 0) and (llop2.hi = 0) then begin
if not (kind in [normalExpression,
autoInitializerExpression]) then
Error(109)
else if ((lint & lintOverflow) <> 0) then
Error(129);
llop2 := longlong1;
end; {if}
if unsigned then
umod64(llop1, llop2)
else
rem64(llop1, llop2);
end;
otherwise: Error(57);
end; {case}
dispose(op^.right);
op^.right := nil;
dispose(op^.left);
op^.left := nil;
op^.token.kind := ekind;
if ekind in [longlongconst,ulonglongconst] then begin
op^.token.qval := llop1;
op^.token.class := longlongConstant;
end {if}
else if ekind in [longconst,ulongconst] then begin
op^.token.lval := llop1.lo;
op^.token.class := longConstant;
end {if}
else begin
op^.token.ival := long(llop1.lo).lsw;
op^.token.class := intConstant;
end; {else}
goto 1;
end; {if}
end; {if}
if op^.right^.token.kind in [intconst,uintconst,longconst,ulongconst,
longlongconst,ulonglongconst,floatconst,doubleconst,extendedconst,
compconst,charconst,scharconst,ucharconst,ushortconst] then
if op^.left^.token.kind in [intconst,uintconst,longconst,ulongconst,
longlongconst,ulonglongconst,floatconst,doubleconst,extendedconst,
compconst,charconst,scharconst,ucharconst,ushortconst] then
begin
if fenvAccess then
if kind in [normalExpression, autoInitializerExpression] then
goto 1;
if (op^.right^.token.kind = compConst)
and (op^.left^.token.kind = compConst) then
ekind := compconst
else if (op^.right^.token.kind in [extendedConst,compConst])
or (op^.left^.token.kind in [extendedConst,compConst]) then
ekind := extendedconst
else if (op^.right^.token.kind = doubleConst)
or (op^.left^.token.kind = doubleConst) then
ekind := doubleconst
else
ekind := floatconst;
rop1 := RealVal(op^.left^.token);
rop2 := RealVal(op^.right^.token);
dispose(op^.right);
op^.right := nil;
dispose(op^.left);
op^.left := nil;
case op^.token.kind of
barbarop : begin {||}
op1 := ord((rop1 <> 0.0) or (rop2 <> 0.0));
ekind := intconst;
end;
andandop : begin {&&}
op1 := ord((rop1 <> 0.0) and (rop2 <> 0.0));
ekind := intconst;
end;
eqeqop : begin {==}
op1 := ord(rop1 = rop2);
ekind := intconst;
end;
exceqop : begin {!=}
op1 := ord(rop1 <> rop2);
ekind := intconst;
end;
ltch : begin {<}
op1 := ord(rop1 < rop2);
ekind := intconst;
end;
gtch : begin {>}
op1 := ord(rop1 > rop2);
ekind := intconst;
end;
lteqop : begin {<=}
op1 := ord(rop1 <= rop2);
ekind := intconst;
end;
gteqop : begin {>=}
op1 := ord(rop1 >= rop2);
ekind := intconst;
end;
plusch : rop1 := rop1 + rop2; {+}
minusch : rop1 := rop1 - rop2; {-}
asteriskch : rop1 := rop1 * rop2; {*}
slashch : rop1 := rop1 / rop2; {/}
otherwise : Error(66); {illegal operation}
end; {case}
if ekind = intconst then begin
op^.token.ival := long(op1).lsw;
op^.token.class := intConstant;
op^.token.kind := intConst;
end {if}
else begin
op^.token.rval := rop1;
op^.token.class := realConstant;
op^.token.kind := ekind;
end; {else}
end; {if}
1:
end;
plusplusop, {prefix ++}
minusminusop, {prefix --}
opplusplus, {postfix ++}
opminusminus, {postfix --}
sizeofsy, {sizeof}
_Alignofsy, {_Alignof (erroneous uses)}
castoper, {(type)}
typedef, {(type-name)}
tildech, {~}
excch, {!}
uminus, {unary -}
uplus, {unary +}
uand, {unary &}
uasterisk: begin {unary *}
op^.left := Pop;
if op^.token.kind = sizeofsy then begin
op^.token.kind := ulongConst;
op^.token.class := longConstant;
kindLeft := op^.left^.token.kind;
if kindLeft = stringConst then
op^.token.lval := op^.left^.token.sval^.length
else begin
lCodeGeneration := codeGeneration;
codeGeneration := false;
GenerateCode(op^.left);
if kindLeft = dotch then
if isBitfield then
Error(49);
codeGeneration := lCodeGeneration and (numErrors = 0);
op^.token.lval := expressionType^.size;
with expressionType^ do
if (size = 0) or ((kind = arrayType) and (elements = 0)) then
Error(49);
end; {else}
op^.left := nil;
end {if sizeofsy}
else if op^.token.kind = _Alignofsy then begin
{error case: operand of _Alignof is not a parenthesized type-name}
Error(36);
op^.token.kind := ulongConst;
op^.token.class := longConstant;
op^.token.lval := 1;
dispose(op^.left);
end {else if _Alignofsy}
else if op^.token.kind = castoper then begin
class := op^.left^.token.class;
if class in [intConstant,longConstant,longlongconstant,
realConstant] then begin
tp := op^.castType;
while tp^.kind = definedType do
tp := tp^.dType;
if tp^.kind = scalarType then begin
baseType := tp^.baseType;
if fenvAccess then
if kind in [normalExpression, autoInitializerExpression] then
if (baseType in [cgReal,cgDouble,cgComp,cgExtended])
or (class = realConstant) then
goto 3;
if (baseType < cgString) or (baseType in [cgQuad,cgUQuad])
then begin
if class = realConstant then begin
rop1 := RealVal(op^.left^.token);
if baseType = cgUQuad then
CnvXULL(llop1, rop1)
else
CnvXLL(llop1, rop1);
end {if}
else begin {handle integer constants}
GetLongLongVal(llop1, op^.left^.token);
if op^.left^.token.kind = ulonglongconst then
rop1 := CnvULLX(llop1)
else
rop1 := CnvLLX(llop1);
end; {else if}
dispose(op^.left);
op^.left := nil;
if baseType in [cgByte,cgWord] then begin
if baseType = cgByte then
op^.token.kind := scharConst
else
op^.token.kind := intConst;
op^.token.class := intConstant;
if tp^.cType = ctBool then
op^.token.ival := ord(rop1 <> 0.0)
else
op^.token.ival := long(llop1.lo).lsw;
if baseType = cgByte then
with op^.token do begin
ival := ival & $00FF;
if (ival & $0080) <> 0 then
ival := ival | $FF00;
end; {with}
end {if}
else if baseType = cgUWord then begin
op^.token.kind := uintConst;
op^.token.class := intConstant;
op^.token.ival := long(llop1.lo).lsw;
end {else if}
else if baseType = cgUByte then begin
if tp^.cType = ctUChar then
op^.token.kind := ucharConst
else
op^.token.kind := charConst;
op^.token.class := intConstant;
op^.token.ival := long(llop1.lo).lsw;
op^.token.ival := op^.token.ival & $00FF;
end {else if}
else if baseType = cgLong then begin
op^.token.kind := longConst;
op^.token.class := longConstant;
op^.token.lval := llop1.lo;
end {else if}
else if baseType = cgULong then begin
op^.token.kind := ulongConst;
op^.token.class := longConstant;
op^.token.lval := llop1.lo;
end {else if}
else if baseType = cgQuad then begin
op^.token.kind := longlongConst;
op^.token.class := longlongConstant;
op^.token.qval := llop1;
end {else if}
else if baseType = cgUQuad then begin
op^.token.kind := ulonglongConst;
op^.token.class := longlongConstant;
op^.token.qval := llop1;
end {else if}
else begin
case baseType of
cgReal: op^.token.kind := floatConst;
cgDouble: op^.token.kind := doubleConst;
cgExtended: op^.token.kind := extendedConst;
cgComp: op^.token.kind := compConst;
end; {case}
op^.token.class := realConstant;
LimitPrecision(rop1, baseType);
op^.token.rval := rop1;
end; {else if}
end; {if}
3: end; {if}
end; {if}
end {else if castoper}
else if not (op^.token.kind in
[typedef,plusplusop,minusminusop,opplusplus,opminusminus,uand]) then
begin
if (kind <> preprocessorExpression) and (op^.left^.token.kind
in [intconst,uintconst,longconst,ulongconst,charconst,scharconst,
ucharconst,ushortconst]) then begin
{evaluate a constant operation}
ekind := op^.left^.token.kind;
if ekind in [charconst,scharconst,ucharconst] then
ekind := intconst;
op1 := IntVal(op^.left^.token);
dispose(op^.left);
op^.left := nil;
case op^.token.kind of
tildech : op1 := ~op1; {~}
excch : begin {!}
op1 := ord(op1 = 0);
ekind := intconst;
end;
uminus : op1 := -op1; {unary -}
uplus : ; {unary +}
uasterisk : Error(79); {unary *}
otherwise: Error(57);
end; {case}
op^.token.kind := ekind;
if ekind in [longconst,ulongconst] then begin
op^.token.class := longConstant;
op^.token.lval := op1;
end {if}
else begin
op^.token.class := intConstant;
op^.token.ival := long(op1).lsw;
end; {else}
end {if}
else if op^.left^.token.kind in [longlongconst,ulonglongconst,
intconst,uintconst,longconst,ulongconst,charconst,scharconst,
ucharconst,ushortconst] then begin
{evaluate a constant operation with long long operand}
ekind := op^.left^.token.kind;
if ekind in [charconst,scharconst,ucharconst] then
ekind := intconst;
if kind = preprocessorExpression then
ekind := PPKind(op^.left^.token);
GetLongLongVal(llop1, op^.left^.token);
dispose(op^.left);
op^.left := nil;
case op^.token.kind of
tildech : begin {~}
llop1.lo := ~llop1.lo;
llop1.hi := ~llop1.hi;
end;
excch : begin {!}
op1 := ord((llop1.hi = 0) and (llop1.lo = 0));
ekind := intconst;
end;
uminus : begin {unary -}
llop1.lo := ~llop1.lo;
llop1.hi := ~llop1.hi;
llop1.lo := llop1.lo + 1;
if llop1.lo = 0 then
llop1.hi := llop1.hi + 1;
end;
uplus : ; {unary +}
uasterisk : Error(79); {unary *}
otherwise: Error(57);
end; {case}
op^.token.kind := ekind;
if ekind in [longlongconst,ulonglongconst] then begin
op^.token.class := longlongConstant;
op^.token.qval := llop1;
end {if}
else begin
op^.token.class := intConstant;
op^.token.ival := long(op1).lsw;
end; {else}
end {else if}
else if op^.left^.token.kind in
[floatconst,doubleconst,extendedconst,compconst] then begin
if fenvAccess then
if kind in [normalExpression, autoInitializerExpression] then
goto 4;
ekind := op^.left^.token.kind;
rop1 := RealVal(op^.left^.token);
dispose(op^.left);
op^.left := nil;
case op^.token.kind of
uminus : begin {unary -}
op^.token.class := realConstant;
op^.token.kind := ekind;
op^.token.rval := -rop1;
end;
uplus : begin {unary +}
op^.token.class := realConstant;
op^.token.kind := ekind;
op^.token.rval := rop1;
end;
excch : begin {!}
op^.token.class := intConstant;
op^.token.kind := intconst;
op^.token.ival := ord(rop1 = 0.0);
end;
otherwise : begin {illegal operation}
Error(66);
op^.token.class := realConstant;
op^.token.kind := ekind;
op^.token.rval := rop1;
end;
end; {case}
end; {if}
end; {if}
4:
end;
otherwise: Error(57);
end; {case}
op^.next := stack; {place the operation on the operand stack}
stack := op;
end; {Operation}
procedure Skip;
{ skip all tokens in the remainder of the expression }
begin {Skip}
while not (token.kind in stopSym+[eofsy]) do
NextToken;
errorFound := true;
end; {Skip}
procedure DoGeneric;
{ process a generic selection expression }
label 10;
type
typeListPtr = ^typeList;
typeList = record
next: typeListPtr;
theType: typePtr;
end;
var
lCodeGeneration: boolean; {local copy of codeGeneration}
tempExpr: tokenPtr; {temporary to hold expression trees}
controllingType: typeRecord; {type of controlling expression}
typesSeen: typeListPtr; {types that already have associations}
tl: typeListPtr; {temporary type list pointer}
resultExpr: tokenPtr; {the result expression}
defaultExpr: tokenPtr; {the default expression}
currentType: typePtr; {the type for the current association}
typesMatch: boolean; {does the current type match}
foundMatch: boolean; {have we found a matching type?}
foundDefault: boolean; {have we found the default case?}
begin {DoGeneric}
if not expectingTerm then begin
Error(36);
Skip;
goto 1;
end; {if}
NextToken;
if token.kind <> lparench then begin
Error(36);
Skip;
goto 1;
end; {if}
new(op); {record it like a parenthesized expr}
op^.next := opStack;
op^.left := nil;
op^.middle := nil;
op^.right := nil;
opStack := op;
op^.token.kind := lparench;
op^.token.class := reservedSymbol;
parenCount := parenCount+1;
NextToken; {process the controlling expression}
tempExpr := ExpressionTree(normalExpression, [commach]);
lCodeGeneration := codeGeneration;
codeGeneration := false;
GenerateCode(tempExpr);
codeGeneration := lCodeGeneration and (numErrors = 0);
{get controlling type after conversions}
if expressionType^.kind = functionType then begin
controllingType.size := cgPointerSize;
controllingType.kind := pointerType;
controllingType.pType := expressionType;
end {if}
else if expressionType^.kind in [structType,unionType] then begin
controllingType.size := expressionType^.size;
controllingType.kind := definedType;
controllingType.dType := expressionType;
end {else if}
else
controllingType := expressionType^;
if controllingType.kind = arrayType then begin
controllingType.kind := pointerType;
controllingType.size := cgPointerSize;
end; {if}
controllingType.qualifiers := [];
controllingType.saveDisp := 0;
typesSeen := nil;
resultExpr := nil;
defaultExpr := nil;
foundMatch := false;
foundDefault := false;
while token.kind = commach do begin {process the generic associations}
NextToken;
typesMatch := false;
if token.kind <> defaultsy then begin
if not (token.kind in specifierQualifierListElement) then begin
Error(26);
while not (token.kind in [colonch,commach,rparench,eofsy]) do
NextToken;
end; {if}
currentType := TypeName; {get the type name}
if (currentType^.size = 0) or (currentType^.kind = functionType) then
Error(133);
tl := typesSeen; {check if it is a duplicate}
while tl <> nil do begin
if StrictCompTypes(currentType, tl^.theType) then begin
Error(158);
goto 10;
end; {if}
tl := tl^.next;
end; {while}
new(tl); {record it as seen}
tl^.next := typesSeen;
tl^.theType := currentType;
typesSeen := tl;
{see if the types match}
typesMatch := StrictCompTypes(currentType, controllingType);
if typesMatch then begin
if foundMatch then begin {sanity check - should never happen}
typesMatch := false;
Error(158);
end; {if}
foundMatch := true;
end; {if}
end {if}
else begin {handle default association}
NextToken;
currentType := nil;
if foundDefault then
Error(159);
foundDefault := true;
end; {else}
10:
if token.kind = colonch then {skip the colon}
NextToken
else
Error(29);
{get the expression in this association}
if (currentType = nil) and (defaultExpr = nil) and not foundMatch then
defaultExpr := ExpressionTree(kind, [commach,rparench])
else if typesMatch then
resultExpr := ExpressionTree(kind, [commach,rparench])
else
tempExpr := ExpressionTree(normalExpression, [commach,rparench]);
end; {while}
if token.kind <> rparench then
Error(12);
while typesSeen <> nil do begin {dispose of the list of types seen}
tl := typesSeen^.next;
dispose(typesSeen);
typesSeen := tl;
end; {while}
if not foundMatch then {use default if no match found}
if foundDefault then
resultExpr := defaultExpr;
if not (foundMatch or foundDefault) then begin
Error(160); {report error & synthesize a token}
resultExpr := pointer(Calloc(sizeof(tokenRecord)));
resultExpr^.token.kind := intconst;
resultExpr^.token.class := intConstant;
{resultExpr^.token.ival := 0;}
end; {if}
if resultExpr <> nil then begin
resultExpr^.next := stack; {stack the resulting expression}
stack := resultExpr;
end; {if}
expectingTerm := false;
end; {DoGeneric}
procedure DoCompoundLiteral;
{ process a compound literal expression }
label 1;
var
id: identPtr;
sp: tokenPtr;
begin {DoCompoundLiteral}
if kind in [preprocessorExpression,arrayExpression] then begin
op := opStack;
while op <> nil do begin
if op^.token.kind = sizeofsy then
goto 1;
op := op^.next;
end; {while}
Error(41);
errorFound := true;
end; {if}
1:
id := MakeCompoundLiteral(opStack^.castType);
opStack := opStack^.next;
{create an operand on the stack}
new(sp);
if id^.class = staticsy then
sp^.token.kind := ident
else
sp^.token.kind := compoundliteral;
sp^.token.class := identifier;
sp^.token.symbolPtr := id;
sp^.token.name := id^.name;
sp^.id := id;
sp^.next := stack;
sp^.left := nil;
sp^.middle := nil;
sp^.right := nil;
stack := sp;
ComplexTerm;
expectingTerm := false;
end; {DoCompoundLiteral}
begin {ExpressionTree}
opStack := nil;
stack := nil;
if token.kind = typedef then {handle typedefs that are hidden}
if FindSymbol(token,variableSpace,false,true) <> nil then
if token.symbolPtr^.class <> typedefsy then
token.kind := ident;
if token.kind in startExpression then begin
expressionValue := 0; {initialize the expression value}
expectingTerm := true; {the first item should be a term}
done := false; {convert the expression to postfix form}
parenCount := 0;
repeat {scan the token list...}
if token.kind in startTerm then begin
{we must expect a term or unary operand}
if not expectingTerm then begin
Error(36);
Skip;
goto 1;
end; {if}
if token.kind = ident then
{handle a complex operand}
DoOperand
else begin
{handle a constant operand}
new(sp);
sp^.token := token;
sp^.next := stack;
sp^.left := nil;
sp^.middle := nil;
sp^.right := nil;
stack := sp;
if kind in [preprocessorExpression,arrayExpression] then
if token.kind in [stringconst,floatconst,doubleconst,
extendedconst,compconst] then begin
if kind = arrayExpression then begin
op := opStack;
if token.kind <> stringconst then
if op <> nil then
if op^.token.kind = castoper then
if op^.casttype^.kind = scalarType then
if op^.casttype^.baseType in [cgByte,cgUByte,
cgWord,cgUWord,cgLong,cgULong,cgQuad,cgUQuad]
then goto 3;
while op <> nil do begin
if op^.token.kind = sizeofsy then
goto 3;
op := op^.next;
end; {while}
end; {if}
Error(41);
errorFound := true;
end; {if}
3:
NextToken;
ComplexTerm;
end; {else}
expectingTerm := false; {the next thing should be an operation}
end {else}
{handle a closing parenthesis}
else if (token.kind = rparench) and (parenCount > 0) then begin
if expectingTerm then begin {make sure it is in a legal spot}
Error(37);
Skip;
goto 1;
end; {if}
while opStack^.token.kind <> lparench do
Operation; {do pending operations}
op := opStack;
opStack := op^.next;
dispose(op);
parenCount := parenCount-1;
NextToken; {skip the ')'}
ComplexTerm; {handle subscripts, selection, etc.}
end {else}
else if token.kind = lparench then begin
{handle open paren and type casts}
if not expectingTerm then begin
Error(38);
Skip;
goto 1;
end; {if}
NextToken;
if token.kind in specifierQualifierListElement then begin
doingSizeof := false;
doingAlignof := false;
if opStack <> nil then
if opStack^.token.kind = sizeofsy then
doingSizeof := true
else if opStack^.token.kind = _Alignofsy then
doingAlignof := true;
tType := TypeName;
if doingSizeof or doingAlignof then begin
{handle a sizeof operator}
op := opStack;
opStack := op^.next;
dispose(op);
new(sp);
sp^.next := stack;
sp^.left := nil;
sp^.middle := nil;
sp^.right := nil;
sp^.token.kind := ulongconst;
sp^.token.class := longConstant;
if doingSizeof then
sp^.token.lval := tType^.size
else {if doingAlignof then}
sp^.token.lval := 1;
with tType^ do
if (size = 0) or ((kind = arrayType) and (elements = 0)) then
Error(133);
sp^.next := stack;
stack := sp;
expectingTerm := false;
end {if}
else {doing a cast} begin
{handle a type cast}
new(op); {stack the cast operator}
op^.left := nil;
op^.middle := nil;
op^.right := nil;
op^.castType := tType;
op^.token.kind := castoper;
op^.token.class := reservedWord;
op^.next := opStack;
opStack := op;
end; {else}
Match(rparench,12);
end {if}
else begin
new(op); {record the '('}
op^.next := opStack;
op^.left := nil;
op^.middle := nil;
op^.right := nil;
opStack := op;
op^.token.kind := lparench;
op^.token.class := reservedSymbol;
parenCount := parenCount+1;
end;
end {else if}
else if (token.kind = lbracech) {handle a compound literal}
and (opstack <> nil) and (opStack^.token.kind = castoper) then begin
DoCompoundLiteral
end {else if}
else if token.kind = _Genericsy then {handle _Generic}
DoGeneric
else begin {handle an operation...}
if expectingTerm then {convert unary operators to separate tokens}
if token.kind in [asteriskch,minusch,plusch,andch] then
case token.kind of
asteriskch: token.kind := uasterisk;
minusch : token.kind := uminus;
andch : token.kind := uand;
plusch : token.kind := uplus;
otherwise : Error(57);
end; {case}
if icp[token.kind] = notAnOperation then
done := true {end of expression found...}
else if (token.kind in stopSym) and (parenCount = 0)
and ((opStack = nil) or (opStack^.token.kind <> questionch)) then
done := true
else begin
if not (kind in [normalExpression, autoInitializerExpression]) then
if (token.kind in
[plusplusop,minusminusop,eqch,pluseqop,minuseqop,
opplusplus,opminusminus,
asteriskeqop,slasheqop,percenteqop,ltlteqop,
gtgteqop,caroteqop,bareqop,commach])
or ((kind = preprocessorExpression)
and (token.kind = sizeofsy))
or ((kind <> initializerExpression)
and (token.kind = uand)) then begin
Error(161);
errorFound := true;
end; {if}
if token.kind in {make sure we get what we want}
[plusplusop,minusminusop,sizeofsy,_Alignofsy,tildech,excch,
uasterisk,uminus,uplus,uand] then begin
if not expectingTerm then begin
Error(38);
Skip;
goto 1;
end; {if}
end {if}
else begin
if expectingTerm then begin
Error(37);
Skip;
goto 1;
end; {if}
expectingTerm := true;
{handle 2nd half of ternary operator}
if token.kind = colonch then begin
done2 := false; {do pending operations}
repeat
if opStack = nil then
done2 := true
else if opStack^.token.kind <> questionch then
Operation
else
done2 := true;
until done2;
if (opStack = nil) or
(opStack^.token.kind <> questionch) then begin
Error(39);
Skip;
goto 1;
end; {if}
op := opStack;
opStack := op^.next;
dispose(op);
end {if}
else begin
done2 := false; {do operations with less precedence}
repeat
if opStack = nil then
done2 := true
else if isp[opStack^.token.kind] >= icp[token.kind] then
Operation
else
done2 := true;
until done2;
end; {else}
end; {else}
new(op); {record the operation}
op^.next := opStack;
op^.left := nil;
op^.middle := nil;
op^.right := nil;
opStack := op;
op^.token := token;
NextToken;
end; {else}
end; {else}
2:
until done;
if parenCount > 0 then begin
Error(12);
errorFound := true;
end {if}
else begin
while opStack <> nil do {do pending operations}
Operation;
{there should be exactly one operand left}
if (stack = nil) or (stack^.next <> nil) then begin
Error(36);
errorFound := true;
end; {if}
end; {else}
end {if}
else begin {the start of an expression was not found}
Error(35);
if not (token.kind in stopSym) then
NextToken;
Skip;
end; {else}
1:
if errorFound then begin
while opStack <> nil do begin
op := opStack;
opStack := op^.next;
dispose(op);
end; {while}
while stack <> nil do begin
sp := stack;
stack := sp^.next;
DisposeTree(sp);
end; {while}
ExpressionTree := nil;
end {if}
else
ExpressionTree := stack;
end; {ExpressionTree}
procedure CompareToZero {op: pcodes};
{ Compare the result on tos to zero. }
{ }
{ This procedure is used by the logical statements to compare }
{ _any_ scalar result to zero, giving a boolean result. }
{ }
{ parameters: }
{ op - operation to use on the compare }
var
bt: baseTypeEnum; {base type of loaded value}
begin {CompareToZero}
if expressionType^.kind in [pointerType,arrayType] then
expressionType := uLongPtr;
if expressionType^.kind = scalarType then begin
bt := UsualUnaryConversions;
case bt of
cgByte,cgUByte,cgWord,cgUWord:
Gen1t(pc_ldc, 0, cgWord);
cgLong,cgULong:
GenLdcLong(0);
cgQuad,cgUQuad:
GenLdcQuad(longlong0);
cgReal,cgDouble,cgComp,cgExtended:
GenLdcReal(0.0);
otherwise:
Error(47);
end; {case}
expressionType := intPtr;
Gen0t(op, bt);
end {if}
else
Error(47);