ORCA-C/Expression.pas
Stephen Heumann f2414cd815 Create a new function that checks for compatible types strictly according to the C standards.
For now, this is only used for _Generic expressions. Eventually, it should probably replace the current CompTypes, but CompTypes currently performs somewhat looser checks that are suitable for some situations, so adjustments would be needed at some call sites.
2021-03-07 23:39:30 -06:00

4708 lines
174 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}
{---------------------------------------------------------------}
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 }
procedure TypeName; extern;
{ process a type name (used for casts and sizeof/_Alignof) }
{ }
{ outputs: }
{ typeSpec - 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. }
{-- 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 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)}
begin {AssignmentConversion}
kind1 := t1^.kind;
kind2 := t2^.kind;
if t1^.isConstant then
if genCode then
if checkConst 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
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);
end {if}
else if kind2 = arrayType then begin
if not CompTypes(t1^.ptype, t2^.atype) then
if t1^.ptype^.baseType <> cgVoid then
Error(47);
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
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}
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;
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^.isConstant := false;}
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);
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}
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 = uintconst 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 = uintconst 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 = uintconst then begin
result.lo := token.ival & $0000FFFF;
result.hi := 0;
end {else if}
else if token.kind = longconst then begin
result.lo := token.lval;
if result.lo < 0 then
result.hi := -1
else
result.hi := 0;
end {else if}
else if token.kind = ulongconst then begin
result.lo := token.lval;
result.hi := 0;
end {else if}
else {if token.kind in [longlongconst,ulonglongconst] then} begin
result := token.qval;
end; {else}
end; {LongLongVal}
function PPKind (token: tokenType): tokenEnum;
{ adjust kind of token for use in preprocessor expression }
begin {PPKind}
if token.kind in [intconst,longconst] then
PPKind := longlongconst
else if token.kind in [uintconst,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,
longconst,ulongconst,longlongconst,ulonglongconst,
charconst,scharconst,ucharconst] then
if op^.left^.token.kind in [intconst,uintconst,
longconst,ulongconst,longlongconst,ulonglongconst,
charconst,scharconst,ucharconst] then
if op^.middle^.token.kind in [intconst,uintconst,
longconst,ulongconst,longlongconst,ulonglongconst,
charconst,scharconst,ucharconst] then begin
GetLongLongVal(llop1, op^.left^.token);
if (llop1.lo <> 0) or (llop1.hi <> 0) then
op^.token := op^.middle^.token
else
op^.token := op^.right^.token;
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,longconst,ulongconst,
charconst,scharconst,ucharconst] then begin
if kindLeft in [intconst,uintconst,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) 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,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
Error(109);
op2 := 1;
end; {if}
if unsigned then
op1 := udiv(op1,op2)
else
op1 := op1 div op2;
end;
percentch : begin {%}
if op2 = 0 then begin
Error(109);
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,longconst,ulongconst,
longlongconst,ulonglongconst,charconst,scharconst,ucharconst]
then begin
if kindLeft in [intconst,uintconst,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
Error(109);
llop2 := longlong1;
end; {if}
if unsigned then
udiv64(llop1, llop2)
else
div64(llop1, llop2);
end;
percentch : begin {%}
if (llop2.lo = 0) and (llop2.hi = 0) then begin
Error(109);
llop2 := longlong1;
end; {if}
if unsigned then
umod64(llop1, llop2)
else
rem64(llop1, llop2);
end;
otherwise: Error(57);
end; {case}
dispose(op^.right);
op^.right := nil;
dispose(op^.left);
op^.left := nil;
op^.token.kind := ekind;
if ekind in [longlongconst,ulonglongconst] then begin
op^.token.qval := llop1;
op^.token.class := longlongConstant;
end {if}
else if ekind in [longconst,ulongconst] then begin
op^.token.lval := llop1.lo;
op^.token.class := longConstant;
end {if}
else begin
op^.token.ival := long(llop1.lo).lsw;
op^.token.class := intConstant;
end; {else}
goto 1;
end; {if}
end; {if}
if op^.right^.token.kind in [intconst,uintconst,longconst,ulongconst,
longlongconst,ulonglongconst,floatconst,doubleconst,extendedconst,
compconst,charconst,scharconst,ucharconst] then
if op^.left^.token.kind in [intconst,uintconst,longconst,ulongconst,
longlongconst,ulonglongconst,floatconst,doubleconst,extendedconst,
compconst,charconst,scharconst,ucharconst] 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 -}
uand, {unary &}
uasterisk: begin {unary *}
op^.left := Pop;
if op^.token.kind = sizeofsy then begin
op^.token.kind := ulongConst;
op^.token.class := longConstant;
if op^.left^.token.kind = stringConst then
op^.token.lval := op^.left^.token.sval^.length+1
else begin
lCodeGeneration := codeGeneration;
codeGeneration := false;
GenerateCode(op^.left);
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]) 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 -}
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] 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;
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;
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 := cgLongSize;
controllingType.saveDisp := 0;
controllingType.isConstant := false;
controllingType.kind := pointerType;
controllingType.pType := expressionType;
end {if}
else if expressionType^.kind in [structType,unionType] then begin
controllingType.size := expressionType^.size;
controllingType.saveDisp := 0;
controllingType.isConstant := false;
controllingType.kind := definedType;
controllingType.dType := expressionType;
end {else if}
else
controllingType := expressionType^;
if controllingType.kind = arrayType then
controllingType.kind := pointerType;
controllingType.isConstant := false;
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
TypeName; {get the type name}
currentType := typeSpec;
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);
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}
begin {ExpressionTree}
opStack := nil;
stack := nil;
if token.kind = typedef then {handle typedefs that are hidden}
if FindSymbol(token,allSpaces,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;
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 := typeSpec^.size
else {if doingAlignof then}
sp^.token.lval := 1;
with typeSpec^ 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 := typeSpec;
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 = _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 : begin
NextToken;
goto 2;
end;
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) 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(40);
errorFound := true;
end; {if}
if token.kind in {make sure we get what we want}
[plusplusop,minusminusop,sizeofsy,_Alignofsy,tildech,excch,
uasterisk,uminus,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);
end; {CompareToZero}
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 }
var
tl: tempPtr; {work pointer}
begin {FreeTemp}
new(tl);
tl^.next := tempList;
tl^.last := nil;
tl^.labelNum := labelNum;
tl^.size := size;
if tempList <> nil then
tempList^.last := tl;
tempList := tl;
end; {FreeTemp}
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. }
label 1;
var
lcodeGeneration: boolean; {local copy of codeGeneration}
ln: integer; {label number}
tl: tempPtr; {work pointer}
begin {GetTemp}
{try to find a temp from the existing list}
tl := tempList;
while tl <> nil do begin
if tl^.size = size then begin
{found an old one - use it}
if tl^.last = nil then
tempList := tl^.next
else
tl^.last^.next := tl^.next;
if tl^.next <> nil then
tl^.next^.last := tl^.last;
GetTemp := tl^.labelNum;
goto 1;
end; {if}
tl := tl^.next;
end; {while}
{none found - get a new one}
ln := GetLocalLabel;
GetTemp := ln;
lcodeGeneration := codeGeneration;
codeGeneration := true;
Gen2(dc_loc, ln, size);
codeGeneration := lCodeGeneration and (numErrors = 0);
1:
end; {GetTemp}
procedure LoadScalar (id: identPtr);
{ Load a scalar value. }
{ }
{ parameters: }
{ id - ident for value to load }
var
tp: baseTypeEnum; {base type}
begin {LoadScalar}
if id^.itype^.kind = scalarType then
tp := id^.itype^.baseType
else {if id^.itype^.kind in [pointerType,arrayType] then}
tp := cgULong;
case id^.storage of
stackFrame, parameter:
Gen2t(pc_lod, id^.lln, 0, tp);
external, global, private:
Gen1tName(pc_ldo, 0, tp, id^.name);
otherwise: ;
end; {case}
end; {LoadScalar}
procedure Cast(tp: typePtr);
{ Cast the current expression to the stated type }
{ }
{ parameters: }
{ tp - type to cast to }
{ }
{ inputs: }
{ expressionType - type of the expression to cast }
{ }
{ outputs: }
{ expressionType - set to result type }
var
et,rt: baseTypeEnum; {work variables}
begin {Cast}
if (tp^.kind = scalarType) and (tp^.cType = ctBool) then begin
CompareToZero(pc_neq);
end {if}
else if (tp^.kind = scalarType) and (expressionType^.kind = scalarType) then begin
rt := tp^.baseType;
et := expressionType^.baseType;
if (rt <> et) or (rt in [cgReal,cgDouble,cgComp]) then
if et <> cgVoid then
Gen2(pc_cnv, ord(et), ord(rt))
else
Error(40);
end {if}
else if (tp^.kind = enumType) and (expressionType^.kind = scalarType) then begin
if expressionType^.baseType <> cgVoid then begin
rt := cgWord;
et := Unary(expressionType^.baseType);
if rt <> et then
Gen2(pc_cnv, ord(et), ord(rt));
end {if}
else
Error(40);
end {if}
else if (tp^.kind = scalarType) and (expressionType^.kind = enumType) then begin
rt := Unary(tp^.baseType);
et := cgWord;
if rt <> et then
Gen2(pc_cnv, ord(et), ord(rt));
end {if}
else if tp^.kind = pointerType then begin
case expressionType^.kind of
scalarType:
if expressionType^.baseType in
[cgByte,cgUByte,cgWord,cgUWord,cgLong,cgULong] then
Gen2(pc_cnv, ord(Unary(expressionType^.baseType)),
ord(cgULong))
else if doDispose then
Error(40);
arrayType,pointerType: ;
functionType,enumConst,enumType,definedType,structType,unionType:
if doDispose then
Error(40);
otherwise: Error(57);
end; {case}
end {else if}
else if expressionType^.kind in [pointerType,arrayType] then begin
case tp^.kind of
scalarType:
if tp^.baseType in
[cgByte,cgUByte,cgWord,cgUWord,cgLong,cgULong] then
Gen2(pc_cnv, ord(cgULong),
ord(Unary(tp^.baseType)))
else if tp^.baseType = cgVoid then
Gen0t(pc_pop, UsualUnaryConversions)
else
Error(40);
otherwise:
Error(40);
end; {case}
end {else if}
else if expressionType^.kind in [structType,unionType] then begin
if tp^.kind = scalarType then
if tp^.baseType = cgVoid then
Gen0t(pc_pop, UsualUnaryConversions)
else Error(40)
else Error(40);
end {else if}
else
Error(40);
expressionType := tp;
end; {Cast}
procedure DoSelection {lType: typePtr; tree: tokenPtr; var size: longint};
{ Find the displacement & type for a selection operation }
{ }
{ parameters: }
{ lType - structure/union type }
{ tree - right-hand tree }
{ 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 }
label 1;
var
ip: identPtr; {for scanning for the field}
begin {DoSelection}
expressionType := intPtr; {set defaults in case there is an error}
size := 0;
if tree^.token.class = identifier then begin
while lType^.kind = definedType do
lType := lType^.dType;
if lType^.kind in [structType,unionType] then begin
ip := lType^.fieldList; {find a matching field}
while ip <> nil do begin
if ip^.name^ = tree^.token.name^ then begin
if ip^.isForwardDeclared then
ResolveForwardReference(ip);
size := ip^.disp; {match found - record parameters}
expressionType := ip^.itype;
bitDisp := ip^.bitDisp;
bitSize := ip^.bitSize;
isBitField := (bitSize+bitDisp) <> 0;
unsigned := (ip^.itype^.baseType in [cgUByte,cgUWord,cgULong])
or (ip^.itype^.cType = ctBool);
goto 1;
end; {if}
ip := ip^.next;
end; {while}
Error(81);
end {if}
else
Error(80);
end; {if}
1:
end; {DoSelection}
procedure L_Value(tree: tokenPtr);
{ Check for an l-value }
{ }
{ parameters: }
{ tree - expression tree to check }
var
kind: tokenEnum; {for efficiency}
begin {L_Value}
kind := tree^.token.kind;
{A variable identifier is an l-value unless it is a function or }
{non-parameter array }
if kind = ident then begin
if tree^.id^.itype^.kind = arrayType then begin
if tree^.id^.storage <> parameter then
if doDispose then {prevent spurious errors}
Error(78);
end {if}
else if tree^.id^.itype^.kind in
[functionType,enumConst,enumType] then
if doDispose then {prevent spurious errors}
Error(78);
end {if}
{e.field is an l-value if and only if e is an l-value}
else if kind = dotch then
L_Value(tree^.left)
{Bypass cast operators }
{following test removed to flag bug for: }
{ int *p; long l; }
{ (long) p = l; }
{else if kind = castoper then
L_Value(tree^.left)}
{The result of an array subscript (a[i]), indirect selection, }
{or the indirection operator all show up as the uasterisk }
{operator at this point. All are l-values, but nothing else }
{not already allowed is an l-value. }
else if kind <> uasterisk then
if doDispose then {prevent spurious errors}
Error(78);
end; {L_Value}
procedure ChangePointer (op: pcodes; size: longint; tp: baseTypeEnum);
{ Add or subtract an integer to a pointer }
{ }
{ The stack has a pointer and an integer (integer on TOS). }
{ The integer is removed, multiplied by size, and either }
{ added to or subtracted from the pointer; the result }
{ replaces the pointer on the stack }
{ }
{ parameters: }
{ op - operation (pc_adl or pc_sbl) }
{ size - size of one pointer element }
{ tp - type of the integer operand }
begin {ChangePointer}
if size = 0 then
Error(122);
case tp of
cgByte,cgUByte,cgWord,cgUWord: begin
if (size = long(size).lsw) and (op = pc_adl)
and smallMemoryModel and (tp in [cgUByte,cgUWord]) then begin
if size <> 1 then begin
Gen1t(pc_ldc, long(size).lsw, cgWord);
Gen0(pc_umi);
end; {if}
Gen0t(pc_ixa, cgUWord);
end {if}
else if smallMemoryModel and (size = long(size).lsw) then begin
if size <> 1 then begin
Gen1t(pc_ldc, long(size).lsw, cgWord);
Gen0(pc_umi);
end; {if}
Gen2(pc_cnv, ord(tp), ord(cgLong));
Gen0(op);
end {else if}
else begin
Gen2(pc_cnv, ord(tp), ord(cgLong));
if size <> 1 then begin
GenLdcLong(size);
Gen0(pc_mpl);
end; {if}
Gen0(op);
end;
end;
cgLong,cgULong,cgQuad,cgUQuad: begin
if tp in [cgQuad,cgUQuad] then
Gen2(pc_cnv, ord(tp), ord(cgLong));
if size <> 1 then begin
GenLdcLong(size);
if tp in [cgLong,cgQuad] then
Gen0(pc_mpl)
else
Gen0(pc_uml);
end; {if}
Gen0(op);
end;
otherwise:
Error(66);
end; {case}
end; {ChangePointer}
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 }
var
doingScalar: boolean; {temp; for assignment operators}
et: baseTypeEnum; {temp storage for a base type}
i: integer; {loop variable}
isString: boolean; {was the ? : a string?}
lType: typePtr; {type of operands}
kind: typeKind; {temp type kind}
size: longint; {size of an array element}
t1: integer; {temporary work space label number}
tlastwasconst: boolean; {temp lastwasconst}
tlastconst: longint; {temp lastconst}
tp: tokenPtr; {work pointer}
tType: typePtr; {temp type of operand}
lbitDisp,lbitSize: integer; {for temp storage}
lisBitField: boolean;
function ExpressionKind (tree: tokenPtr): typeKind;
{ returns the type of an expression }
{ }
{ This subroutine is used to see if + and - operations }
{ should do pointer addition. }
{ }
{ parameters: }
{ tree - top of the expression tree to check }
var
ldoDispose: boolean; {local copy of doDispose}
lcodeGeneration: boolean; {local copy of codeGeneration}
lexpressionType: typePtr; {local copy of expressionType}
begin {ExpressionKind}
ldoDispose := doDispose; {inhibit disposing of the tree}
doDispose := false;
lcodeGeneration := codeGeneration; {inhibit code generation}
codeGeneration := false;
lexpressionType := expressionType; {save the expression type}
GenerateCode(tree); {get the type}
while expressionType^.kind = definedType do
expressionType := expressionType^.dType;
ExpressionKind := expressionType^.kind;
doDispose := ldoDispose; {restore the volatile variables}
codeGeneration := lCodeGeneration and (numErrors = 0);
expressionType := lexpressionType;
end; {ExpressionKind}
procedure LoadAddress (tree: tokenPtr);
{ load the address of an l-value }
{ }
{ parameters: }
{ tree - top of the expression tree to load the }
{ address of }
{ }
{ variables: }
{ expressionType - result type of the expression }
{ isBitField - this variable is set to false so that }
{ it can be used to see if DoSelection was called }
{ and located a bit field }
label 1;
var
eType: typePtr; {work pointer}
i: integer; {loop variable}
size: longint; {disp in record}
tname: stringPtr; {temp name pointer}
begin {LoadAddress}
isBitField := false;
if tree^.token.kind = ident then begin
{load the address of an identifier}
with tree^.id^ do begin
tname := name;
if itype^.kind = functionType then begin
if itype^.isPascal then begin
tname := pointer(Malloc(length(name^)+1));
CopyString(pointer(tname), pointer(name));
for i := 1 to length(tname^) do
if tname^[i] in ['a'..'z'] then
tname^[i] := chr(ord(tname^[i]) & $5F);
end; {if}
end; {if}
case storage of
stackFrame: Gen2(pc_lda, lln, 0);
parameter: if itype^.kind = arrayType then
Gen2t(pc_lod, pln, 0, cgULong)
else
Gen2(pc_lda, pln, 0);
external,
global,
private: Gen1Name(pc_lao, 0, tname);
otherwise: ;
end; {case}
eType := pointer(Malloc(sizeof(typeRecord)));
eType^.size := cgLongSize;
eType^.saveDisp := 0;
eType^.isConstant := false;
eType^.kind := pointerType;
eType^.pType := iType;
expressionType := eType;
end; {with}
end {if}
else if tree^.token.kind = uasterisk then begin
{load the address of the item pointed to by the pointer}
GenerateCode(tree^.left);
isBitField := false;
if not (expressionType^.kind in [pointerType,arrayType,functionType]) then
Error(79);
end {else if}
else if tree^.token.kind = dotch then begin
{load the address of a field of a record}
LoadAddress(tree^.left);
eType := expressionType;
if eType^.kind in [arrayType,pointerType] then begin
if eType^.kind = arrayType then
eType := eType^.aType
else if eType^.kind = pointerType then
eType := eType^.pType;
DoSelection(eType, tree^.right, size);
if size <> 0 then
if size & $00007FFF = size then
Gen1t(pc_inc, long(size).lsw, cgULong)
else begin
GenLdcLong(size);
Gen0(pc_adl);
end; {else}
eType := pointer(Malloc(sizeof(typeRecord)));
eType^.size := cgLongSize;
eType^.saveDisp := 0;
eType^.isConstant := false;
eType^.kind := pointerType;
eType^.pType := expressionType;
expressionType := eType;
end {if}
else
Error(79);
end {else if}
else if tree^.token.kind = castoper then begin
{load the address of a field of a record}
LoadAddress(tree^.left);
expressionType := tree^.castType;
if expressionType^.kind <> arrayType then begin
eType := pointer(Malloc(sizeof(typeRecord)));
eType^.size := cgLongSize;
eType^.saveDisp := 0;
eType^.isConstant := false;
eType^.kind := pointerType;
eType^.pType := expressionType;
expressionType := eType;
end; {if}
end {else if}
else if ExpressionKind(tree) in [arrayType,pointerType] then
GenerateCode(tree)
else begin
expressionType := intPtr; {set default type in case of error}
if doDispose then {prevent spurious errors}
Error(78);
end; {else}
1:
end; {LoadAddress}
procedure DoIncDec (tree: tokenPtr; pc_l, pc_g, pc_i: pcodes);
{ do ++ and -- }
{ }
{ parameters: }
{ tree - tree to generate the instruction for }
{ pc_l - op code for a local ++ or -- }
{ pc_g - op code for a global ++ or -- }
{ pc_i - op code for an indirect ++ or -- }
label 1;
var
baseType: baseTypeEnum; {type of operation}
lSize: longint; {number to inc or dec by}
iSize: integer; {number to inc or dec by}
tp: baseTypeEnum; {type of operand}
procedure IncOrDec (inc: boolean);
{ Increment or decrement a number on TOS }
{ }
{ parameters: }
{ inc - increment the number? }
begin {IncOrDec}
case expressionType^.kind of
scalarType:
case tp of
cgByte,cgUByte,cgWord,cgUWord: begin
Gen1t(pc_ldc, 1, cgWord);
if inc then
Gen0(pc_adi)
else
Gen0(pc_sbi);
if expressionType^.cType = ctBool then begin
CompareToZero(pc_neq);
expressionType := boolPtr;
end {if}
end;
cgLong,cgULong: begin
GenLdcLong(1);
if inc then
Gen0(pc_adl)
else
Gen0(pc_sbl);
end;
cgQuad,cgUQuad: begin
GenLdcQuad(longlong1);
if inc then
Gen0(pc_adq)
else
Gen0(pc_sbq);
end;
cgReal,cgDouble,cgComp,cgExtended: begin
GenLdcReal(1.0);
if inc then
Gen0(pc_adr)
else
Gen0(pc_sbr);
end;
otherwise: Error(57);
end; {case}
pointerType,arrayType: begin
GenldcLong(expressionType^.pType^.size);
if inc then
Gen0(pc_adl)
else
Gen0(pc_sbl);
end;
otherwise: ;
end; {case}
end; {IncOrDec}
begin {DoIncDec}
L_Value(tree);
if (tree^.token.kind = ident)
and ((tree^.id^.iType^.kind in [scalarType,pointerType])
or ((tree^.id^.iType^.kind = arrayType) and (tree^.id^.storage = parameter)))
then
with tree^.id^ do begin
{check for ++ or -- of a constant}
if iType^.isConstant then
Error(93);
{do an efficient ++ or -- on a named location}
if iType^.kind = scalarType then begin
iSize := 1;
baseType := iType^.baseType;
if (baseType in [cgReal,cgDouble,cgComp,cgExtended,cgQuad,cgUQuad])
or (iType^.cType = ctBool) then begin
{do real or bool inc or dec}
LoadScalar(tree^.id); {load the value}
if pc_l in [pc_lli,pc_lld] then
if iType^.cType = ctBool then begin
t1 := GetTemp(cgWordSize);
Gen2t(pc_cop, t1, 0, cgWord);
end; {if}
tp := baseType;
expressionType := iType;
IncOrDec(pc_l in [pc_lli,pc_lil]); {do the ++ or --}
case storage of {save the result}
stackFrame, parameter:
Gen2t(pc_cop, lln, 0, baseType);
external, global, private:
Gen1tName(pc_cpo, 0, baseType, name);
otherwise: ;
end; {case}
{correct the value for postfix ops}
if pc_l in [pc_lli,pc_lld] then
if iType^.cType = ctBool then begin
Gen0t(pc_pop, cgWord);
Gen2t(pc_lod, t1, 0, cgWord);
Gen0t(pc_bno, cgWord);
FreeTemp(t1, cgWordSize);
end {if}
else
IncOrDec(pc_l = pc_lld);
if iType^.cType = ctBool then
expressionType := boolPtr
else if baseType = cgQuad then
expressionType := longLongPtr
else if baseType = cgUQuad then
expressionType := ulongLongPtr
else
expressionType := doublePtr;
goto 1;
end; {else if}
end {if}
else {if iType^.kind in [pointerType,arrayType] then} begin
lSize := iType^.pType^.size;
if lSize = 0 then
Error(122);
if long(lSize).msw <> 0 then begin
{handle inc/dec of >64K}
LoadScalar(tree^.id);
GenLdcLong(lSize);
if pc_l in [pc_lli,pc_lil] then
Gen0(pc_adl)
else
Gen0(pc_sbl);
with tree^.id^ do
case storage of
stackFrame, parameter:
Gen2t(pc_cop, lln, 0, cgULong);
external, global, private:
Gen1tName(pc_cpo, 0, cgULong, name);
otherwise: ;
end; {case}
if pc_l in [pc_lli,pc_lld] then begin
GenLdcLong(lSize);
if pc_l = pc_lld then
Gen0(pc_adl)
else
Gen0(pc_sbl);
end; {if}
goto 1;
end; {if}
baseType := cgULong;
iSize := long(lSize).lsw;
end; {else}
case storage of
stackFrame, parameter:
Gen2t(pc_l, lln, iSize, baseType);
external, global, private:
Gen2tName(pc_g, iSize, 0, baseType, name);
otherwise: ;
end; {case}
expressionType := itype;
end {with}
else begin
{do an indirect ++ or --}
LoadAddress(tree); {get the address to save to}
if expressionType^.kind = arrayType then
expressionType := expressionType^.aType
else if expressionType^.kind = pointerType then
expressionType := expressionType^.pType;
if expressionType^.kind = scalarType then
if expressionType^.baseType in
[cgByte,cgUByte,cgWord,cgUWord,cgReal,cgDouble,cgComp,cgExtended] then
tp := expressionType^.baseType
else
tp := UsualUnaryConversions
else
tp := UsualUnaryConversions;
if (tp in [cgByte,cgUByte,cgWord,cgUword])
and (expressionType^.cType <> ctBool)
and not isBitField then
Gen0t(pc_i, tp) {do indirect inc/dec}
else begin
t1 := GetTemp(cgLongSize);
Gen2t(pc_str, t1, 0, cgULong);
Gen2t(pc_lod, t1, 0, cgULong);
Gen2t(pc_lod, t1, 0, cgULong);
FreeTemp(t1, cgLongSize);
{load the value}
if isBitField then begin
if unsigned then
Gen2t(pc_lbu, bitDisp, bitSize, tp)
else
Gen2t(pc_lbf, bitDisp, bitSize, tp);
end {if}
else
Gen1t(pc_ind, 0, tp);
if pc_l in [pc_lli,pc_lld] then
if expressionType^.cType = ctBool then begin
t1 := GetTemp(cgWordSize);
Gen2t(pc_cop, t1, 0, cgWord);
end; {if}
IncOrDec(pc_l in [pc_lli,pc_lil]); {do the ++ or --}
if isBitField then {copy the value}
Gen2t(pc_cbf, bitDisp, bitSize, tp)
else
Gen0t(pc_cpi, tp);
Gen0t(pc_bno, tp);
if pc_l in [pc_lli,pc_lld] then {correct the value for postfix ops}
if expressionType^.cType = ctBool then begin
Gen0t(pc_pop, cgWord);
Gen2t(pc_lod, t1, 0, cgWord);
Gen0t(pc_bno, cgWord);
FreeTemp(t1, cgWordSize);
end {if}
else
IncOrDec(pc_l = pc_lld);
end; {else}
end; {else}
1:
end; {DoIncDec}
procedure FunctionCall (tree: tokenPtr);
{ generate the actual function call }
var
fName: stringPtr; {uppercase file name}
fntype: typePtr; {temp function type}
ftree: tokenPtr; {function address tree}
ftype: typePtr; {function type}
i: integer; {loop variable}
indirect: boolean; {is this an indirect call?}
ldoDispose: boolean; {local copy of doDispose}
lcodeGeneration: boolean; {local copy of codeGeneration}
procedure FunctionParms (parms: tokenPtr; fType: typePtr);
{ Generate a function call. }
{ }
{ parameters: }
{ parms - parameter list }
{ fType - function type }
var
kind: typeKind; {for expression kinds}
ldoDispose: boolean; {local copy of doDispose}
lnumErrors: integer; {number of errors before type check}
numParms: integer; {# of parameters generated}
parameters: parameterPtr; {next prototyped parameter}
pCount: integer; {# of parameters prototyped}
prototype: boolean; {is the function prototyped?}
tp: tokenPtr; {work pointers}
fp, tfp: fmtArgPtr;
fmt: fmt_type;
procedure Reverse;
{ Reverse the parameter list }
var
p1,p2,p3: tokenPtr; {work pointers}
begin {Reverse}
p3 := parms; {remove the last entry}
p1 := parms;
p2 := nil;
while p3^.right <> nil do begin
p2 := p3;
p3 := p3^.right;
end; {while}
if p2 <> nil then
p2^.right := nil
else
p1 := nil;
while p1 <> nil do begin {reverse the remaining parms}
p2 := p1;
p1 := p1^.right;
p2^.right := p3;
p3 := p2;
end; {while}
parms := p3;
end; {Reverse}
begin {FunctionParms}
{check the validity of the parameter list}
if ftype^.isPascal then {reverse parms for pascal calls}
Reverse;
tp := parms; {set up to check types}
prototype := ftype^.prototyped;
parameters := ftype^.parameterList;
pCount := 1;
fmt := fmt_none;
fp := nil;
if ((lint & lintPrintf) <> 0) and fType^.varargs and not indirect then
fmt := FormatClassify(ftree^.id^.name^);
while parameters <> nil do begin {count the prototypes}
pCount := pCount+1;
parameters := parameters^.next;
end; {while}
parameters := ftype^.parameterList;
if prototype then begin {check for wrong # of parms}
while tp <> nil do begin {count the parms}
pCount := pCount-1;
tp := tp^.right;
end; {while}
tp := parms;
if (pCount > 0) or ((pCount <> 0) and not ftype^.varargs) then
Error(85);
end; {if}
tp := parms;
{generate the parameters}
numParms := 0;
lDoDispose := doDispose;
doDispose := false;
while tp <> nil do begin
if tp^.middle <> nil then begin
lnumErrors := numErrors;
kind := ExpressionKind(tp^.middle);
if numErrors = lnumErrors then
if kind in [structType,unionType] then begin
GenerateCode(tp^.middle);
if expressionType^.size & $FFFF8000 <> 0 then
Error(61);
Gen1t(pc_ldc, long(expressionType^.size).lsw, cgWord);
Gen0(pc_psh);
end {else if}
else
GenerateCode(tp^.middle);
if fmt <> fmt_none then begin
new(tfp);
tfp^.next := fp;
tfp^.tk := tp^.middle;
tfp^.ty := expressionType;
fp := tfp;
end;
if prototype then begin
if pCount = 0 then begin
if parameters <> nil then begin
AssignmentConversion(parameters^.parameterType,
expressionType, lastWasConst, lastConst, true, false);
end; {if}
parameters := parameters^.next;
end {if}
else
pCount := pCount+1;
end; {if}
Gen0t(pc_stk, UsualUnaryConversions);
if numParms <> 0 then
Gen0t(pc_bno, UsualUnaryConversions);
numParms := numParms+1;
end; {if}
tp := tp^.right;
end; {while}
if fmt <> fmt_none then FormatCheck(fmt, fp);
doDispose := lDoDispose;
if numParms = 0 then
Gen0(pc_nop);
if ftype^.isPascal then {restore parm order}
Reverse;
if doDispose then begin {dispose of leaf nodes}
DisposeTree(parms^.middle);
DisposeTree(parms^.right);
end; {if}
end; {FunctionParms}
begin {FunctionCall}
{find the type of the function}
indirect := true; {assume an indirect call}
ftree := tree^.left; {get the function tree}
if ftree^.token.kind = ident then {check for direct calls}
if ftree^.id^.itype^.kind = functionType then begin
indirect := false;
fType := ftree^.id^.itype; {get the function type}
end; {if}
if indirect then begin {get type for indirect call}
ldoDispose := doDispose;
doDispose := false;
lcodeGeneration := codeGeneration;
codeGeneration := false;
GenerateCode(ftree);
doDispose := ldoDispose;
codeGeneration := lCodeGeneration and (numErrors = 0);
ftype := expressionType;
while ftype^.kind in [pointerType,arrayType] do
ftype := ftype^.ptype;
end; {if}
{make sure the identifier is really a function}
if ftype^.kind <> functionType then
Error(114)
else begin
{generate function parameters}
FunctionParms (tree, fType);
{generate the function call}
expressionType := ftype^.fType;
if expressionType^.kind in [structType,unionType] then
expressionType := uLongPtr;
if (ftype^.toolNum = 0) and (ftype^.dispatcher = 0) then begin
if indirect then begin
fntype := expressionType;
GenerateCode(ftree);
expressionType := fntype;
Gen1t(pc_cui, ord(fType^.varargs and strictVararg),
UsualUnaryConversions);
end {if}
else begin
fname := ftree^.id^.name;
if ftype^.isPascal then begin
fname := pointer(Malloc(length(fname^)+1));
CopyString(pointer(fname), pointer(ftree^.id^.name));
for i := 1 to length(fname^) do
if fName^[i] in ['a'..'z'] then
fName^[i] := chr(ord(fName^[i]) & $5F);
end; {if}
Gen1tName(pc_cup, ord(fType^.varargs and strictVararg),
UsualUnaryConversions, fname);
end; {else}
if fType^.varargs then
hasVarargsCall := true;
end {if}
else
GenTool(pc_tl1, ftype^.toolNum, long(ftype^.ftype^.size).lsw,
ftype^.dispatcher);
expressionType := ftype^.fType;
lastWasConst := false;
end; {else}
end; {FunctionCall}
procedure CompareCompatible (var t1,t2: typePtr);
{ Make sure that it is legal to compare t1 to t2 }
begin {CompareCompatible}
if (t1^.kind = functionType) or (t2^.kind = functionType) then begin
if not CompTypes(t1, t2) then
Error(47);
end {if}
else if t1^.kind in [pointerType,arrayType] then begin
if t2^.kind in [pointerType,arrayType] then begin
if (t1^.ptype = voidPtr) or (t2^.ptype = voidPtr) then
else if not CompTypes(t1^.ptype, t2^.ptype) then
Error(47);
t2 := ulongPtr;
end {if}
else if (not lastwasconst) or (lastconst <> 0) then
Error(47);
t1 := ulongPtr;
end {if}
else if expressionType^.kind in [pointerType,arrayType] then begin
if (not tlastwasconst) or (tlastconst <> 0) then
Error(47);
t2 := ulongPtr;
end; {else if}
end; {CompareCompatible}
procedure CheckDivByZero (var divisor: tokenType; opType: typePtr);
{ Check for division by (constant) zero. }
{ }
{ parameters: }
{ divisor - token for divisor }
{ opType - type of the result of the operation }
begin {CheckDivByZero}
if opType^.kind = scalarType then
if opType^.baseType in
[cgByte,cgWord,cgUByte,cgUWord,cgLong,cgULong,cgQuad,cgUQuad] then
if ((divisor.class = intConstant) and (divisor.ival = 0))
or ((divisor.class = longConstant) and (divisor.lval = 0))
or ((divisor.class = longlongConstant)
and (divisor.qval.lo = 0) and (divisor.qval.hi = 0))
or ((divisor.class = realConstant) and (divisor.rval = 0.0)) then
Error(129);
end; {CheckDivByZero}
procedure CheckShiftOverflow (var shiftCountTok: tokenType; opType: typePtr);
{ Check for invalid (too large or negative) shift count. }
{ }
{ parameters: }
{ shiftCountTok - token for shift count }
{ opType - type of the result of the operation }
var
shiftCount: longint;
begin {CheckShiftOverflow}
if shiftCountTok.class = intConstant then
shiftCount := shiftCountTok.ival
else if shiftCountTok.class = longConstant then
shiftCount := shiftCountTok.lval
else if shiftCountTok.class = longlongConstant then begin
if shiftCountTok.qval.hi = 0 then
shiftCount := shiftCountTok.qval.lo
else
shiftCount := -1;
end {else if}
else
shiftCount := 0;
if (shiftCount <> 0) and (opType^.kind = scalarType) then begin
if opType^.baseType in [cgByte,cgWord,cgUByte,cgUWord] then
if (shiftCount < 0) or (shiftCount > 15) then
Error(130);
if opType^.baseType in [cgLong,cgULong] then
if (shiftCount < 0) or (shiftCount > 31) then
Error(130);
if opType^.baseType in [cgQuad,cgUQuad] then
if (shiftCount < 0) or (shiftCount > 63) then
Error(130);
end; {if}
end; {CheckShiftOverflow}
begin {GenerateCode}
lastwasconst := false;
case tree^.token.kind of
parameterOper:
FunctionCall(tree);
ident: begin
tType := tree^.id^.itype;
while tType^.kind = definedType do
tType := tType^.dType;
case tType^.kind of
scalarType: begin
LoadScalar(tree^.id);
expressionType := tree^.id^.itype;
end;
pointerType: begin
LoadScalar(tree^.id);
expressionType := tree^.id^.itype;
end;
arrayType: begin
LoadAddress(tree);
expressionType := expressionType^.ptype;
end;
functionType:
LoadAddress(tree);
structType, unionType: begin
LoadAddress(tree);
if expressionType^.kind = pointerType then
expressionType := expressionType^.ptype;
end;
enumConst: begin
Gen1t(pc_ldc, tree^.id^.itype^.eval, cgWord);
expressionType := intPtr;
end;
end; {case}
end;
intConst,uintConst,charConst,scharConst,ucharConst: begin
Gen1t(pc_ldc, tree^.token.ival, cgWord);
lastwasconst := true;
lastconst := tree^.token.ival;
if tree^.token.kind = intConst then
expressionType := intPtr
else if tree^.token.kind = uintConst then
expressionType := uIntPtr
else if tree^.token.kind = charConst then
expressionType := charPtr
else if tree^.token.kind = scharConst then
expressionType := scharPtr
else {if tree^.token.kind = ucharConst then}
expressionType := ucharPtr;
end; {case intConst,uintConst,charConst,scharConst,ucharConst}
longConst,ulongConst: begin
GenLdcLong(tree^.token.lval);
if tree^.token.kind = longConst then
expressionType := longPtr
else
expressionType := ulongPtr;
lastwasconst := true;
lastconst := tree^.token.lval;
end; {case longConst}
longlongConst,ulonglongConst: begin
GenLdcQuad(tree^.token.qval);
if tree^.token.kind = longlongConst then
expressionType := longlongPtr
else
expressionType := ulonglongPtr;
if (tree^.token.qval.hi = 0) and (tree^.token.qval.lo >= 0) then begin
lastwasconst := true;
lastconst := tree^.token.qval.lo;
end; {if}
end; {case longlongConst}
floatConst: begin
GenLdcReal(tree^.token.rval);
expressionType := floatPtr;
end; {case floatConst}
doubleConst: begin
GenLdcReal(tree^.token.rval);
expressionType := doublePtr;
end; {case doubleConst}
extendedConst: begin
GenLdcReal(tree^.token.rval);
expressionType := extendedPtr;
end; {case extendedConst}
compConst: begin
GenLdcReal(tree^.token.rval);
expressionType := compPtr;
end; {case compConst}
stringConst: begin
GenS(pc_lca, tree^.token.sval);
expressionType := stringTypePtr;
end; {case stringConst}
eqch: begin {=}
L_Value(tree^.left);
with tree^.left^ do begin
if token.kind = ident then
kind := id^.itype^.kind
else
kind := definedType;
if kind = arrayType then
if id^.storage = parameter then
kind := pointerType;
if (token.kind = ident)
and (kind in [scalarType,pointerType]) then begin
GenerateCode(tree^.right);
with tree^.left^.id^ do begin
if itype^.kind in [pointerType,arrayType] then
lType := uLongPtr
else
lType := itype;
AssignmentConversion(itype, expressionType, lastWasConst,
lastConst, true, true);
case storage of
stackFrame, parameter:
Gen2t(pc_cop, lln, 0, lType^.baseType);
external, global, private:
Gen1tName(pc_cpo, 0, lType^.baseType, name);
otherwise: ;
end; {case}
end; {with}
end {if}
else begin
LoadAddress(tree^.left);
lType := expressionType;
lisBitField := isBitField;
lbitDisp := bitDisp;
lbitSize := bitSize;
if lType^.kind = arrayType then
lType := lType^.aType
else if lType^.kind = pointerType then
lType := lType^.pType;
GenerateCode(tree^.right);
AssignmentConversion(lType, expressionType, lastWasConst,
lastConst, true, true);
case lType^.kind of
scalarType:
if lisBitField then
Gen2t(pc_cbf, lbitDisp, lbitSize, lType^.baseType)
else
Gen0t(pc_cpi, lType^.baseType);
pointerType:
Gen0t(pc_cpi, cgULong);
structType,unionType:
Gen2(pc_mov, long(lType^.size).msw, long(lType^.size).lsw);
otherwise:
Error(47);
end; {case}
end; {else}
end; {with}
end; {=}
pluseqop, {+=}
minuseqop, {-=}
asteriskeqop, {*=}
slasheqop, {/=}
percenteqop, {%=}
ltlteqop, {<<=}
gtgteqop, {>>=}
andeqop, {&=}
caroteqop, {^=}
bareqop: with tree^.left^ do {|=}
begin
L_Value(tree^.left);
if (token.kind = ident)
and ((id^.itype^.kind in [scalarType,pointerType])
or ((id^.itype^.kind = arrayType) and (id^.storage = parameter))) then begin
doingScalar := true;
LoadScalar(id);
lType := id^.itype;
t1 := 0;
end {if}
else begin
doingScalar := false;
LoadAddress(tree^.left);
lisBitField := isBitField;
lbitDisp := bitDisp;
lbitSize := bitSize;
t1 := GetTemp(cgLongSize);
Gen2t(pc_str, t1, 0, cgULong);
Gen2t(pc_lod, t1, 0, cgULong);
Gen2t(pc_lod, t1, 0, cgULong);
lType := expressionType^.pType;
if isBitField then begin
if unsigned then
Gen2t(pc_lbu, bitDisp, bitSize, lType^.baseType)
else
Gen2t(pc_lbf, bitDisp, bitSize, lType^.baseType);
end {if}
else if lType^.kind = pointerType then
Gen1t(pc_ind, 0, cgULong)
else
Gen1t(pc_ind, 0, lType^.baseType);
end; {else}
if lType^.isConstant then
Error(93);
if doingScalar
and (ltype^.kind = arrayType) and (id^.storage = parameter) then
kind := pointerType
else
kind := lType^.kind;
GenerateCode(tree^.right);
if expressionType^.kind <> scalarType then
Error(66);
if tree^.token.kind in [gtgteqop,ltlteqop] then
if kind = scalarType then
if expressionType^.kind = scalarType then begin
if expressionType^.baseType in
[cgReal,cgDouble,cgComp,cgExtended,cgVoid] then
Error(66);
et := UsualUnaryConversions;
if ltype^.baseType in [cgQuad,cgUQuad] then begin
if not (et in [cgWord,cgUWord]) then begin
Gen2(pc_cnv, et, ord(cgWord));
end; {if}
expressionType := lType;
end {if}
else
if et <> Unary(ltype^.baseType) then begin
Gen2(pc_cnv, et, ord(Unary(ltype^.baseType)));
expressionType := lType;
end; {if}
end; {if}
if kind <> pointerType then
et := UsualBinaryConversions(lType)
else
et := ccPointer;
case tree^.token.kind of
pluseqop:
if kind = pointerType then begin
ChangePointer(pc_adl, lType^.pType^.size, UsualUnaryConversions);
expressionType := lType;
end
else if et in [cgWord,cgUWord] then
Gen0(pc_adi)
else if et in [cgLong,cgULong] then
Gen0(pc_adl)
else if et in [cgQuad,cgUQuad] then
Gen0(pc_adq)
else if et in [cgReal,cgDouble,cgComp,cgExtended] then
Gen0(pc_adr)
else
Error(66);
minuseqop:
if kind = pointerType then begin
ChangePointer(pc_sbl, lType^.pType^.size, UsualUnaryConversions);
expressionType := lType;
end
else if et in [cgWord,cgUWord] then
Gen0(pc_sbi)
else if et in [cgLong,cgULong] then
Gen0(pc_sbl)
else if et in [cgQuad,cgUQuad] then
Gen0(pc_sbq)
else if et in [cgReal,cgDouble,cgComp,cgExtended] then
Gen0(pc_sbr)
else
Error(66);
asteriskeqop:
if et = cgWord then
Gen0(pc_mpi)
else if et = cgUWord then
Gen0(pc_umi)
else if et = cgLong then
Gen0(pc_mpl)
else if et = cgULong then
Gen0(pc_uml)
else if et = cgQuad then
Gen0(pc_mpq)
else if et = cgUQuad then
Gen0(pc_umq)
else if et in [cgReal,cgDouble,cgComp,cgExtended] then
Gen0(pc_mpr)
else
Error(66);
slasheqop:
if et = cgWord then
Gen0(pc_dvi)
else if et = cgUWord then
Gen0(pc_udi)
else if et = cgLong then
Gen0(pc_dvl)
else if et = cgULong then
Gen0(pc_udl)
else if et = cgQuad then
Gen0(pc_dvq)
else if et = cgUQuad then
Gen0(pc_udq)
else if et in [cgReal,cgDouble,cgComp,cgExtended] then
Gen0(pc_dvr)
else
Error(66);
percenteqop:
if et = cgWord then
Gen0(pc_mod)
else if et = cgUWord then
Gen0(pc_uim)
else if et = cgLong then
Gen0(pc_mdl)
else if et = cgULong then
Gen0(pc_ulm)
else if et = cgQuad then
Gen0(pc_mdq)
else if et = cgUQuad then
Gen0(pc_uqm)
else
Error(66);
ltlteqop:
if et in [cgWord,cgUWord] then
Gen0(pc_shl)
else if et in [cgLong,cgULong] then
Gen0(pc_sll)
else if et in [cgQuad,cgUQuad] then
Gen0(pc_slq)
else
Error(66);
gtgteqop:
if et = cgWord then
Gen0(pc_shr)
else if et = cgUWord then
Gen0(pc_usr)
else if et = cgLong then
Gen0(pc_slr)
else if et = cgULong then
Gen0(pc_vsr)
else if et = cgQuad then
Gen0(pc_sqr)
else if et = cgUQuad then
Gen0(pc_wsr)
else
Error(66);
andeqop:
if et in [cgWord,cgUWord] then
Gen0(pc_bnd)
else if et in [cgLong,cgULong] then
Gen0(pc_bal)
else if et in [cgQuad,cgUQuad] then
Gen0(pc_baq)
else
Error(66);
caroteqop:
if et in [cgWord,cgUWord] then
Gen0(pc_bxr)
else if et in [cgLong,cgULong] then
Gen0(pc_blx)
else if et in [cgQuad,cgUQuad] then
Gen0(pc_bqx)
else
Error(66);
bareqop:
if et in [cgWord,cgUWord] then
Gen0(pc_bor)
else if et in [cgLong,cgULong] then
Gen0(pc_blr)
else if et in [cgQuad,cgUQuad] then
Gen0(pc_bqr)
else
Error(66);
otherwise: Error(57);
end; {case}
if ((lint & lintOverflow) <> 0) then begin
if tree^.token.kind in [slasheqop,percenteqop] then
CheckDivByZero(tree^.right^.token, lType)
else if tree^.token.kind in [ltlteqop,gtgteqop] then
CheckShiftOverflow(tree^.right^.token, lType);
end; {if}
AssignmentConversion(lType,expressionType,false,0,true,true);
if doingScalar then begin
if kind = pointerType then
lType := uLongPtr;
case id^.storage of
stackFrame, parameter:
Gen2t(pc_cop, id^.lln, 0, lType^.baseType);
external, global, private:
Gen1tName(pc_cpo, 0, lType^.baseType, id^.name);
otherwise: ;
end; {case}
end {if}
else begin
if lisBitField then
Gen2t(pc_cbf, lbitDisp, lbitSize, lType^.baseType)
else begin
if ltype^.kind in [pointerType,arrayType] then
lType := uLongPtr;
Gen0t(pc_cpi, lType^.baseType);
end; {else}
Gen0t(pc_bno, lType^.baseType);
end; {else}
if t1 <> 0 then
FreeTemp(t1, cgLongSize);
end; {with}
commach: begin {,}
GenerateCode(tree^.left);
if expressionType^.baseType <> cgVoid then
Gen0t(pc_pop, UsualUnaryConversions);
GenerateCode(tree^.right);
Gen0t(pc_bno, UsualUnaryConversions);
{result type is already in expressionType}
end; {case commach}
barbarop: begin {||}
GenerateCode(tree^.left);
if expressionType^.kind in [pointerType,arrayType] then
expressionType := uLongPtr
else begin
et := UsualUnaryConversions;
if et in [cgReal,cgDouble,cgComp,cgExtended] then begin
GenLdcReal(0.0);
Gen0t(pc_neq, cgExtended);
expressionType := intPtr;
end {if}
else if et in [cgQuad,cgUQuad] then begin
GenLdcQuad(longlong0);
Gen0t(pc_neq, et);
expressionType := intPtr;
end; {else if}
end; {else}
lType := expressionType;
GenerateCode(tree^.right);
if expressionType^.kind in [pointerType,arrayType] then
expressionType := uLongPtr
else begin
et := UsualUnaryConversions;
if et in [cgReal,cgDouble,cgComp,cgExtended] then begin
GenLdcReal(0.0);
Gen0t(pc_neq, cgExtended);
expressionType := intPtr;
end {if}
else if et in [cgQuad,cgUQuad] then begin
GenLdcQuad(longlong0);
Gen0t(pc_neq, et);
expressionType := intPtr;
end; {else if}
end; {else}
case UsualBinaryConversions(lType) of
cgByte,cgUByte,cgWord,cgUWord:
Gen0(pc_ior);
cgLong,cgULong:
Gen0(pc_lor);
otherwise:
error(66);
end; {case}
expressionType := intPtr;
end; {case barbarop}
andandop: begin {&&}
GenerateCode(tree^.left);
if expressionType^.kind in [pointerType,arrayType] then
expressionType := uLongPtr
else begin
et := UsualUnaryConversions;
if et in [cgReal,cgDouble,cgComp,cgExtended] then begin
GenLdcReal(0.0);
Gen0t(pc_neq, cgExtended);
expressionType := intPtr;
end {if}
else if et in [cgQuad,cgUQuad] then begin
GenLdcQuad(longlong0);
Gen0t(pc_neq, et);
expressionType := intPtr;
end; {else if}
end; {else}
lType := expressionType;
GenerateCode(tree^.right);
if expressionType^.kind in [pointerType,arrayType] then
expressionType := uLongPtr
else begin
et := UsualUnaryConversions;
if et in [cgReal,cgDouble,cgComp,cgExtended] then begin
GenLdcReal(0.0);
Gen0t(pc_neq, cgExtended);
expressionType := intPtr;
end {if}
else if et in [cgQuad,cgUQuad] then begin
GenLdcQuad(longlong0);
Gen0t(pc_neq, et);
expressionType := intPtr;
end; {else if}
end; {else}
case UsualBinaryConversions(lType) of
cgByte,cgUByte,cgWord,cgUWord:
Gen0(pc_and);
cgLong,cgULong:
Gen0(pc_lnd);
otherwise:
error(66);
end; {case}
expressionType := intPtr;
end; {case andandop}
carotch: begin {^}
GenerateCode(tree^.left);
lType := expressionType;
GenerateCode(tree^.right);
if (lType^.kind <> scalarType) or (expressionType^.kind <> scalarType) then
Error(66)
else case UsualBinaryConversions(lType) of
cgByte,cgUByte,cgWord,cgUWord:
Gen0(pc_bxr);
cgLong,cgULong:
Gen0(pc_blx);
cgQuad,cgUQuad:
Gen0(pc_bqx);
otherwise:
error(66);
end; {case}
end; {case carotch}
barch: begin {|}
GenerateCode(tree^.left);
lType := expressionType;
GenerateCode(tree^.right);
if (lType^.kind <> scalarType) or (expressionType^.kind <> scalarType) then
Error(66)
else case UsualBinaryConversions(lType) of
cgByte,cgUByte,cgWord,cgUWord:
Gen0(pc_bor);
cgLong,cgULong:
Gen0(pc_blr);
cgQuad,cgUQuad:
Gen0(pc_bqr);
otherwise:
error(66);
end; {case}
end; {case barch}
andch: begin {&}
GenerateCode(tree^.left);
lType := expressionType;
GenerateCode(tree^.right);
if (lType^.kind <> scalarType) or (expressionType^.kind <> scalarType) then
Error(66)
else case UsualBinaryConversions(lType) of
cgByte,cgUByte,cgWord,cgUWord:
Gen0(pc_bnd);
cgLong,cgULong:
Gen0(pc_bal);
cgQuad,cgUQuad:
Gen0(pc_baq);
otherwise:
error(66);
end; {case}
end; {case andch}
ltltop: begin {<<}
GenerateCode(tree^.left);
if (expressionType^.kind <> scalarType) then
error(66);
et := UsualUnaryConversions;
lType := expressionType;
GenerateCode(tree^.right);
if (expressionType^.kind <> scalarType)
or not (expressionType^.baseType in
[cgByte,cgUByte,cgWord,cgUWord,cgLong,cgULong,cgQuad,cgUQuad]) then
error(66);
if et in [cgQuad,cgUQuad] then begin
if not (expressionType^.baseType in [cgWord,cgUWord]) then
Gen2(pc_cnv, ord(expressionType^.baseType), ord(cgWord));
end {if}
else
if expressionType^.baseType <> et then
Gen2(pc_cnv, ord(expressionType^.baseType), ord(et));
case et of
cgByte,cgUByte,cgWord,cgUWord:
Gen0(pc_shl);
cgLong,cgULong:
Gen0(pc_sll);
cgQuad,cgUQuad:
Gen0(pc_slq);
otherwise:
error(66);
end; {case}
expressionType := lType;
if ((lint & lintOverflow) <> 0) then
CheckShiftOverflow(tree^.right^.token, expressionType);
end; {case ltltop}
gtgtop: begin {>>}
GenerateCode(tree^.left);
if (expressionType^.kind <> scalarType) then
error(66);
et := UsualUnaryConversions;
lType := expressionType;
GenerateCode(tree^.right);
if (expressionType^.kind <> scalarType)
or not (expressionType^.baseType in
[cgByte,cgUByte,cgWord,cgUWord,cgLong,cgULong,cgQuad,cgUQuad]) then
error(66);
if et in [cgQuad,cgUQuad] then begin
if not (expressionType^.baseType in [cgWord,cgUWord]) then
Gen2(pc_cnv, ord(expressionType^.baseType), ord(cgWord));
end {if}
else
if expressionType^.baseType <> et then
Gen2(pc_cnv, ord(expressionType^.baseType), ord(et));
case et of
cgByte,cgWord:
Gen0(pc_shr);
cgUByte,cgUWord:
Gen0(pc_usr);
cgLong:
Gen0(pc_slr);
cgULong:
Gen0(pc_vsr);
cgQuad:
Gen0(pc_sqr);
cgUQuad:
Gen0(pc_wsr);
otherwise:
error(66);
end; {case}
expressionType := lType;
if ((lint & lintOverflow) <> 0) then
CheckShiftOverflow(tree^.right^.token, expressionType);
end; {case gtgtop}
plusch: begin {+}
if ExpressionKind(tree^.right) in [arrayType,pointerType] then begin
tree^.middle := tree^.right;
tree^.right := tree^.left;
tree^.left := tree^.middle;
end; {if}
GenerateCode(tree^.left);
lType := expressionType;
GenerateCode(tree^.right);
if lType^.kind in [arrayType,pointerType] then begin
if expressionType^.kind <> scalarType then
error(66);
{pointer addition}
et := UsualUnaryConversions;
expressionType := lType;
if lType^.kind = arrayType then
lType := lType^.aType
else
lType := lType^.pType;
ChangePointer(pc_adl, lType^.size, et);
if expressionType^.kind = arrayType then begin
tType := pointer(Malloc(sizeof(typeRecord)));
tType^.size := cgLongSize;
tType^.saveDisp := 0;
tType^.isConstant := false;
tType^.kind := pointerType;
tType^.pType := expressionType^.aType;
expressionType := tType;
end; {if}
end {if}
else begin
{scalar addition}
case UsualBinaryConversions(lType) of
cgByte,cgUByte,cgWord,cgUWord:
Gen0(pc_adi);
cgLong,cgULong:
Gen0(pc_adl);
cgQuad,cgUQuad:
Gen0(pc_adq);
cgReal,cgDouble,cgComp,cgExtended:
Gen0(pc_adr);
otherwise:
error(66);
end; {case}
end; {else}
end; {case plusch}
minusch: begin {-}
GenerateCode(tree^.left);
lType := expressionType;
GenerateCode(tree^.right);
if lType^.kind in [pointerType,arrayType] then begin
if lType^.kind = arrayType then
size := lType^.aType^.size
else
size := lType^.pType^.size;
if expressionType^.kind in [arrayType,pointerType] then begin
{subtraction of two pointers}
if size = 0 then
Error(122)
{NOTE: assumes aType & pType overlap in typeRecord}
else if not CompTypes(lType^.aType, expressionType^.aType) then
Error(47);
Gen0(pc_sbl);
if size <> 1 then begin
GenLdcLong(size);
Gen0(pc_dvl);
end; {if}
lType := longPtr;
end {if}
else
{subtract a scalar from a pointer}
ChangePointer(pc_sbl, size, UsualUnaryConversions);
expressionType := lType;
if expressionType^.kind = arrayType then begin
tType := pointer(Malloc(sizeof(typeRecord)));
tType^.size := cgLongSize;
tType^.saveDisp := 0;
tType^.isConstant := false;
tType^.kind := pointerType;
tType^.pType := expressionType^.aType;
expressionType := tType;
end; {if}
end {if}
else begin
{scalar subtraction}
if expressionType^.kind <> scalarType then
error(66)
else case UsualBinaryConversions(lType) of
cgByte,cgUByte,cgWord,cgUWord:
Gen0(pc_sbi);
cgLong,cgULong:
Gen0(pc_sbl);
cgQuad,cgUQuad:
Gen0(pc_sbq);
cgReal,cgDouble,cgComp,cgExtended:
Gen0(pc_sbr);
otherwise:
error(66);
end; {case}
end; {else}
end; {case minusch}
asteriskch: begin {*}
GenerateCode(tree^.left);
lType := expressionType;
GenerateCode(tree^.right);
if (lType^.kind <> scalarType) or (expressionType^.kind <> scalarType) then
Error(66)
else case UsualBinaryConversions(lType) of
cgByte,cgWord:
Gen0(pc_mpi);
cgUByte,cgUWord:
Gen0(pc_umi);
cgLong:
Gen0(pc_mpl);
cgULong:
Gen0(pc_uml);
cgQuad:
Gen0(pc_mpq);
cgUQuad:
Gen0(pc_umq);
cgReal,cgDouble,cgComp,cgExtended:
Gen0(pc_mpr);
otherwise:
error(66);
end; {case}
end; {case asteriskch}
slashch: begin {/}
GenerateCode(tree^.left);
lType := expressionType;
GenerateCode(tree^.right);
if (lType^.kind <> scalarType) or (expressionType^.kind <> scalarType) then
Error(66)
else case UsualBinaryConversions(lType) of
cgByte,cgWord:
Gen0(pc_dvi);
cgUByte,cgUWord:
Gen0(pc_udi);
cgLong:
Gen0(pc_dvl);
cgULong:
Gen0(pc_udl);
cgQuad:
Gen0(pc_dvq);
cgUQuad:
Gen0(pc_udq);
cgReal,cgDouble,cgComp,cgExtended:
Gen0(pc_dvr);
otherwise:
error(66);
end; {case}
if ((lint & lintOverflow) <> 0) then
CheckDivByZero(tree^.right^.token, expressionType);
end; {case slashch}
percentch: begin {%}
GenerateCode(tree^.left);
lType := expressionType;
GenerateCode(tree^.right);
if (lType^.kind <> scalarType) or (expressionType^.kind <> scalarType) then
Error(66)
else case UsualBinaryConversions(lType) of
cgByte,cgWord:
Gen0(pc_mod);
cgUByte,cgUWord:
Gen0(pc_uim);
cgLong:
Gen0(pc_mdl);
cgULong:
Gen0(pc_ulm);
cgQuad:
Gen0(pc_mdq);
cgUQuad:
Gen0(pc_uqm);
otherwise:
error(66);
end; {case}
if ((lint & lintOverflow) <> 0) then
CheckDivByZero(tree^.right^.token, expressionType);
end; {case percentch}
eqeqop, {==}
exceqop: begin {!=}
GenerateCode(tree^.left);
lType := expressionType;
tlastwasconst := lastwasconst;
tlastconst := lastconst;
GenerateCode(tree^.right);
CompareCompatible(ltype, expressionType);
if tree^.token.kind = eqeqop then
Gen0t(pc_equ, UsualBinaryConversions(lType))
else
Gen0t(pc_neq, UsualBinaryConversions(lType));
expressionType := intPtr;
end; {case exceqop,eqeqop}
lteqop, {<=}
gteqop, {>=}
ltch, {<}
gtch: begin {>}
GenerateCode(tree^.left);
lType := expressionType;
GenerateCode(tree^.right);
CompareCompatible(ltype, expressionType);
if tree^.token.kind = lteqop then
Gen0t(pc_leq, UsualBinaryConversions(lType))
else if tree^.token.kind = gteqop then
Gen0t(pc_geq, UsualBinaryConversions(lType))
else if tree^.token.kind = ltch then
Gen0t(pc_les, UsualBinaryConversions(lType))
else {if tree^.token.kind = gtch then}
Gen0t(pc_grt, UsualBinaryConversions(lType));
expressionType := intPtr;
end; {case lteqop,gteqop,ltch,gtch}
uminus: begin {unary -}
GenerateCode(tree^.left);
if expressionType^.kind <> scalarType then
error(66)
else case UsualUnaryConversions of
cgByte,cgUByte,cgWord,cgUWord:
Gen0(pc_ngi);
cgLong,cgULong:
Gen0(pc_ngl);
cgQuad,cgUQuad:
Gen0(pc_ngq);
cgReal,cgDouble,cgComp,cgExtended:
Gen0(pc_ngr);
otherwise:
error(66);
end; {case}
end; {case uminus}
tildech: begin {~}
GenerateCode(tree^.left);
if expressionType^.kind <> scalarType then
error(66)
else case UsualUnaryConversions of
cgByte,cgUByte,cgWord,cgUWord:
Gen0(pc_bnt);
cgLong,cgULong:
Gen0(pc_bnl);
cgQuad,cgUQuad:
Gen0(pc_bnq);
otherwise:
error(66);
end; {case}
end; {case tildech}
excch: begin {!}
GenerateCode(tree^.left);
if expressionType^.kind = pointerType then
expressionType := uLongPtr;
case UsualUnaryConversions of
cgByte,cgUByte,cgWord,cgUWord:
Gen0(pc_not);
cgLong,cgULong: begin
GenLdcLong(0);
Gen0t(pc_equ, cgLong);
end;
cgQuad,cgUQuad: begin
GenLdcQuad(longlong0);
Gen0t(pc_equ, cgQuad);
end;
cgReal,cgDouble,cgComp,cgExtended: begin
GenLdcReal(0.0);
Gen0t(pc_equ, cgExtended);
end;
otherwise:
error(66);
end; {case}
expressionType := intPtr;
end; {case excch}
plusplusop: {prefix ++}
DoIncDec(tree^.left, pc_lil, pc_gil, pc_iil);
opplusplus: {postfix ++}
DoIncDec(tree^.left, pc_lli, pc_gli, pc_ili);
minusminusop: {prefix --}
DoIncDec(tree^.left, pc_ldl, pc_gdl, pc_idl);
opminusminus: {postfix --}
DoIncDec(tree^.left, pc_lld, pc_gld, pc_ild);
uand: {unary & (address operator)}
LoadAddress(tree^.left);
uasterisk: begin {unary * (indirection)}
GenerateCode(tree^.left);
lType := expressionType;
if lType^.kind in [functiontype,arrayType,pointerType] then begin
if lType^.kind = arrayType then
lType := lType^.aType
else if lType^.kind = pointerType then
lType := lType^.pType;
expressionType := lType;
if lType^.kind = scalarType then
if lType^.baseType = cgVoid then
Gen1t(pc_ind, 0, cgULong)
else
Gen1t(pc_ind, 0, lType^.baseType)
else if lType^.kind = pointerType then
Gen1t(pc_ind, 0, cgULong)
else if not
((lType^.kind in [functionType,arrayType,structType,unionType])
or ((lType^.kind = definedType) and {handle const struct/union}
(lType^.dType^.kind in [structType,unionType]))) then
Error(79);
end {if}
else
Error(79);
end; {case uasterisk}
dotch: begin {.}
LoadAddress(tree^.left);
lType := expressionType;
if lType^.kind in [arrayType,pointerType] then begin
if lType^.kind = arrayType then
lType := lType^.aType
else if lType^.kind = pointerType then
lType := lType^.pType;
DoSelection(lType, tree^.right, size);
if (size & $00007FFF) <> size then begin
GenLdcLong(size);
Gen0(pc_adl);
size := 0;
end; {else}
kind := expressionType^.kind;
if kind = scalarType then begin
et := expressionType^.baseType;
if isBitField then begin
GenLdcLong(size);
Gen0(pc_adl);
if unsigned then
Gen2t(pc_lbu, bitDisp, bitSize, et)
else
Gen2t(pc_lbf, bitDisp, bitSize, et);
end {if}
else
Gen1t(pc_ind, long(size).lsw, et);
end {if}
else if kind = pointerType then
Gen1t(pc_ind, long(size).lsw, cgULong)
else if kind = enumType then
Gen1t(pc_ind, long(size).lsw, cgWord)
else if size <> 0 then
Gen1t(pc_inc, long(size).lsw, cgULong);
end {if}
else
Error(79);
end; {case dotch}
colonch: begin {? :}
GenerateCode(tree^.left); {evaluate the condition}
CompareToZero(pc_neq);
GenerateCode(tree^.middle); {evaluate true expression}
lType := expressionType;
tlastwasconst := lastwasconst;
tlastconst := lastconst;
GenerateCode(tree^.right); {evaluate false expression}
isString := false; {handle string operands}
if lType^.kind in [arrayType,pointerType] then
if lType^.aType^.baseType = cgUByte then begin
with expressionType^ do
if kind in [arrayType,pointerType] then begin
if aType^.baseType = cgUByte then
isString := true
else if (kind = pointerType)
and (CompTypes(lType,expressionType)) then
{it's all OK}
else
Error(47)
end {if}
else if (kind = scalarType)
and lastWasConst
and (lastConst = 0) then
et := UsualBinaryConversions(lType)
{it's all OK}
else
Error(47);
lType := voidPtrPtr;
expressionType := voidPtrPtr;
end; {if}
with expressionType^ do
if kind in [arrayType,pointerType] then
if aType^.baseType in [cgByte,cgUByte] then begin
if kind = pointerType then begin
if tlastwasconst and (tlastconst = 0) then
{it's all OK}
else if CompTypes(lType, expressionType) then
{it's all OK}
else
Error(47);
end {if}
else
Error(47);
et := UsualBinaryConversions(lType);
lType := voidPtrPtr;
expressionType := voidPtrPtr;
end; {if}
{generate the operation}
if lType^.kind in [structType, unionType, arrayType] then begin
if not CompTypes(lType, expressionType) then
Error(47);
Gen0(pc_bno);
Gen0t(pc_tri, cgULong);
end {if}
else begin
if expressionType^.kind = pointerType then
tType := expressionType
else
tType := lType;
if (expressionType^.kind = scalarType)
and (expressionType^.baseType = cgVoid)
and (lType^.kind = scalarType)
and (lType^.baseType = cgVoid) then
et := cgVoid
else
et := UsualBinaryConversions(lType);
Gen0(pc_bno);
Gen0t(pc_tri, et);
end; {else}
if isString then {set the type for strings}
expressionType := stringTypePtr;
end; {case colonch}
castoper: begin {(cast)}
GenerateCode(tree^.left);
Cast(tree^.castType);
end; {case castoper}
otherwise:
Error(57);
end; {case}
if doDispose then
dispose(tree);
end; {GenerateCode}
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 expression }
label 1;
var
lcodeGeneration: boolean; {local copy of codeGeneration}
ldoDispose: boolean; {local copy of doDispose}
tree: tokenPtr; {expression tree}
castValue: tokenPtr; {element being type cast}
begin {Expression}
errorFound := false; {no error so far}
tree := ExpressionTree(kind, stopSym); {create the expression tree}
if kind = normalExpression then begin {generate code from the expression tree}
if not errorFound then begin
doDispose := true;
GenerateCode(tree);
end {if}
else
expressionType := intPtr; {set default type in case of error}
end {if}
else begin {record the expression for an initializer}
initializerTree := tree;
isConstant := false;
llExpressionValue.lo := 0;
llExpressionValue.hi := 0;
expressionIsLongLong := false;
if errorFound then begin
DisposeTree(initializerTree);
initializerTree := nil;
expressionType := intPtr; {set default type in case of error}
end {if}
else begin
ldoDispose := doDispose; {find the expression type}
doDispose := false;
lcodeGeneration := codeGeneration;
codeGeneration := false;
GenerateCode(tree);
doDispose := ldoDispose;
codeGeneration := lCodeGeneration and (numErrors = 0);
{record the expression}
if tree^.token.kind = castoper then begin
castValue := tree^.left;
while castValue^.token.kind = castoper do
castValue := castValue^.left;
if castValue^.token.kind in
[intconst,uintconst,charconst,scharconst,ucharconst] then begin
expressionValue := castValue^.token.ival;
isConstant := true;
expressionType := tree^.castType;
if (castValue^.token.kind = uintconst)
or (expressionType^.kind = pointerType) then
expressionValue := expressionValue & $0000FFFF;
goto 1;
end; {if}
if castValue^.token.kind in [longconst,ulongconst] then begin
expressionValue := castValue^.token.lval;
isConstant := true;
expressionType := tree^.castType;
goto 1;
end; {if}
end; {if}
if tree^.token.kind in [intconst,charconst,scharconst,ucharconst] then
begin
expressionValue := tree^.token.ival;
if tree^.token.kind = intconst then
expressionType := intPtr
else if tree^.token.kind = charconst then
expressionType := charPtr
else if tree^.token.kind = scharconst then
expressionType := scharPtr
else {if tree^.token.kind = ucharconst then}
expressionType := ucharPtr;
isConstant := true;
end {else if}
else if tree^.token.kind = uintconst then begin
expressionValue := tree^.token.ival;
expressionValue := expressionValue & $0000FFFF;
expressionType := uIntPtr;
isConstant := true;
end {else if}
else if tree^.token.kind = longconst then begin
expressionValue := tree^.token.lval;
expressionType := longPtr;
isConstant := true;
end {else if}
else if tree^.token.kind = ulongconst then begin
expressionValue := tree^.token.lval;
expressionType := ulongPtr;
isConstant := true;
end {else if}
else if tree^.token.kind = longlongconst then begin
llExpressionValue := tree^.token.qval;
expressionIsLongLong := true;
if ((llExpressionValue.hi = 0) and (llExpressionValue.lo >= 0))
or ((llExpressionValue.hi = -1) and (llExpressionValue.lo < 0)) then
expressionValue := llExpressionValue.lo
else if llExpressionValue.hi < 0 then
expressionValue := $80000000
else
expressionValue := $7fffffff;
expressionType := longLongPtr;
isConstant := true;
end {else if}
else if tree^.token.kind = ulonglongconst then begin
llExpressionValue := tree^.token.qval;
expressionIsLongLong := true;
if llExpressionValue.hi = 0 then
expressionValue := llExpressionValue.lo
else
expressionValue := $FFFFFFFF;
expressionType := ulongLongPtr;
isConstant := true;
end {else if}
else if tree^.token.kind in
[floatconst,doubleconst,extendedconst,compconst] then begin
realExpressionValue := tree^.token.rval;
if tree^.token.kind = extendedconst then
expressionType := extendedPtr
else if tree^.token.kind = doubleconst then
expressionType := doublePtr
else if tree^.token.kind = floatconst then
expressionType := floatPtr
else {if tree^.token.kind = compconst then}
expressionType := compPtr;
isConstant := true;
if kind in [arrayExpression,preprocessorExpression] then begin
expressionType := intPtr;
expressionValue := 1;
Error(47);
end; {if}
end {else if}
else if tree^.token.kind = stringconst then begin
expressionValue := ord4(tree^.token.sval);
expressionType := stringTypePtr;
isConstant := true;
if kind in [arrayExpression,preprocessorExpression] then begin
expressionType := intPtr;
expressionValue := 1;
Error(47);
end; {if}
end {else if}
else if kind in [arrayExpression,preprocessorExpression] then begin
DisposeTree(initializerTree);
expressionValue := 1;
end; {else if}
end; {else}
end; {else}
1:
end; {Expression}
procedure GetLLExpressionValue {var val: longlong};
{ get the value of the last integer constant expression as a }
{ long long (whether it had long long type or not). }
begin {GetLLExpressionValue}
if expressionIsLongLong then
val := llExpressionValue
else begin
val.lo := expressionValue;
val.hi := 0;
if expressionValue < 0 then
if expressionType^.kind = scalarType then
if expressionType^.baseType in [cgByte,cgWord,cgLong] then
val.hi := -1;
end;
end; {GetLLExpressionValue}
procedure InitExpression;
{ initialize the expression handler }
begin {InitExpression}
startTerm := [ident,intconst,uintconst,longconst,ulongconst,longlongconst,
ulonglongconst,floatconst,doubleconst,extendedconst,compconst,
charconst,scharconst,ucharconst,stringconst];
startExpression:= startTerm +
[lparench,asteriskch,andch,plusch,minusch,excch,tildech,sizeofsy,
plusplusop,minusminusop,typedef,_Alignofsy,_Genericsy];
end; {InitExpression}
end.
{$append 'expression.asm'}