ORCA-C/Parser.pas
Stephen Heumann 61a382de0b Report parameter type errors the same way with and without strict type checks.
They were being reported as "type conflict" by default, but as "duplicate symbol" if strict checks were used.
2022-01-12 18:31:04 -06:00

4757 lines
174 KiB
ObjectPascal

{$optimize 1}
{---------------------------------------------------------------}
{ }
{ Parser }
{ }
{ External Subroutines: }
{ }
{ DoDeclaration - process a variable or function declaration }
{ DoStatement - process a statement from a function }
{ AutoInit - generate code to initialize an auto variable }
{ InitParser - initialize the parser }
{ Match - insure that the next token is of the specified type }
{ TermParser - shut down the parser }
{ DeclarationSpecifiers - handle a type specifier }
{ }
{---------------------------------------------------------------}
unit Parser;
{$LibPrefix '0/obj/'}
interface
uses CCommon, Table, MM, CGI, Scanner, Header, Symbol, Expression, Asm;
{$segment 'parser'}
{---------------------------------------------------------------}
procedure DoDeclaration (doingPrototypes: boolean);
{ process a variable or function declaration }
{ }
{ parameters: }
{ doingPrototypes - are we processing a parameter list? }
procedure DoStatement;
{ process a statement from a function }
procedure TypeName;
{ process a type name (used for casts and sizeof/_Alignof) }
{ }
{ outputs: }
{ typeSpec - pointer to the type }
procedure AutoInit (variable: identPtr; line: integer);
{ generate code to initialize an auto variable }
{ }
{ parameters: }
{ variable - the variable to initialize }
{ line - line number (used for debugging) }
function MakeFuncIdentifier: identPtr;
{ Make the predefined identifier __func__. }
{ }
{ It is inserted in the symbol table as if the following }
{ declaration appeared at the beginning of the function body: }
{ }
{ static const char __func__[] = "function-name"; }
{ }
{ This must only be called within a function body. }
function MakeCompoundLiteral(tp: typePtr): identPtr;
{ Make the identifier for a compound literal. }
{ }
{ parameters: }
{ tp - the type of the compound literal }
procedure InitParser;
{ Initialize the parser }
procedure Match (kind: tokenEnum; err: integer);
{ 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 TermParser;
{ shut down the parser }
{---------------------------------------------------------------}
implementation
const
maxBitField = 32; {max # of bits in a bit field}
type
identList = ^identNode; {list of ids; used for initializers}
identNode = record
next: identList;
id: identPtr;
end;
{ The switch record is used to record the values for the }
{ switch jump table. The linked list of entries is in order }
{ of increasing switch value (val). }
switchPtr = ^switchRecord; {switch label table entry}
switchRecord = record
next,last: switchPtr; {doubly linked list (for inserts)}
lab: integer; {label to branch to}
val: longlong; {switch value}
end;
{token stack}
{-----------}
tokenStackPtr = ^tokenStackRecord;
tokenStackRecord = record
next: tokenStackPtr;
token: tokenType;
end;
{statement stack}
{---------------}
statementPtr = ^statementRecord;
{kinds of nestable statements}
statementKind = (compoundSt,ifSt,elseSt,doSt,whileSt,forSt,switchSt);
statementRecord = record {element of the statement stack}
next: statementPtr; {next element on the stack}
breakLab, continueLab: integer; {branch points for break, continue}
case kind: statementKind of
compoundSt: (
doingDeclaration: boolean; {doing declarations? (or statements)}
lFenvAccess: boolean; {previous value of fenvAccess just}
);
ifSt: (
ifLab: integer; {branch point}
);
elseSt: (
elseLab: integer; {branch point}
);
doSt: (
doLab: integer; {branch point}
);
whileSt: (
whileTop: integer; {label at top of while loop}
whileEnd: integer; {label at bottom of while loop}
);
forSt: (
forLoop: integer; {branch here to loop}
e3List: tokenStackPtr; {tokens for last expression}
);
switchSt: (
maxVal: longint; {max switch value}
ln: integer; {temp var number}
size: integer; {temp var size}
labelCount: integer; {# of switch labels}
switchExit: integer; {branch point}
switchLab: integer; {branch point}
switchList: switchPtr; {list of labels and values}
switchDefault: integer; {default branch point}
);
end;
var
firstCompoundStatement: boolean; {are we doing a function level compound statement?}
fType: typePtr; {return type of the current function}
functionName: stringPtr; {name of the current function}
isForwardDeclared: boolean; {is the field list component }
{ referencing a forward struct/union? }
isFunction: boolean; {is the declaration a function?}
isPascal: boolean; {has the pascal modifier been used?}
{ (set by DoDeclaration)}
returnLabel: integer; {label for exit point}
skipDeclarator: boolean; {for enum,struct,union with no declarator}
statementList: statementPtr; {list of open statements}
savedVolatile: boolean; {saved copy of volatile}
doingForLoopClause1: boolean; {doing the first clause of a for loop?}
compoundLiteralNumber: integer; {number of compound literal}
compoundLiteralToAllocate: identPtr; {compound literal that needs space allocated}
vaInfoLLN: integer; {label number of internal va info (0 for none)}
{parameter processing variables}
{------------------------------}
lastParameter: identPtr; {next parameter to process}
numberOfParameters: integer; {number of indeclared parameters}
pfunc: identPtr; {func. for which parms are being defined}
protoType: typePtr; {type from a parameter list}
protoVariable: identPtr; {variable from a parameter list}
{type info for the current declaration}
{-------------------------------------}
storageClass: tokenEnum; {storage class of the declaration}
{ typeSpec: typePtr; (in CCommon) {type specifier}
declarationModifiers: tokenSet; {all storage class specifiers, type }
{qualifiers, function specifiers, & }
{alignment specifiers in declaration}
{syntactic classes of tokens}
{---------------------------}
{ specifierQualifierListElement: tokenSet; (in CCommon)}
{ topLevelDeclarationStart: tokenSet; (in CCommon)}
localDeclarationStart: tokenSet;
declarationSpecifiersElement: tokenSet;
structDeclarationStart: tokenSet;
{-- External procedures ----------------------------------------}
function slt64(a,b: longlong): boolean; extern;
function sgt64(a,b: longlong): boolean; extern;
{-- Parser Utility Procedures ----------------------------------}
procedure Match {kind: tokenEnum; err: integer};
{ 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 }
begin {Match}
if token.kind = kind then
NextToken
else
Error(err);
end; {Match}
procedure SkipStatement;
{ Skip the remainder of the current statement }
var
bracketCount: integer; {for error skip}
begin {SkipStatement}
bracketCount := 0;
while (token.kind <> eofsy) and
((token.kind <> semicolonch) or (bracketCount <> 0)) do begin
if token.kind = lbrackch then
bracketCount := bracketCount+1;
if token.kind = rbrackch then
if bracketCount <> 0 then
bracketCount := bracketCount-1;
NextToken;
end; {while}
if token.kind = semicolonch then
NextToken;
end; {SkipStatement}
procedure GotoLabel (op: pcodes);
{ Find a label in the goto label list, creating one if one }
{ does not already exist. Generate the label or a jump to it }
{ based on op. }
{ }
{ parameters: }
{ op - operation code to create }
label 1;
var
gt: gotoPtr; {work pointer}
begin {GotoLabel}
gt := gotoList; {try to find an existing label}
while gt <> nil do begin
if gt^.name^ = token.name^ then
goto 1;
gt := gt^.next;
end; {while}
gt := pointer(Malloc(sizeof(gotoRecord))); {no label record exists: create one}
gt^.next := gotoList;
gotoList := gt;
gt^.name := token.name;
gt^.lab := GenLabel;
gt^.defined := false;
1:
if op = dc_lab then begin
if gt^.defined then
Error(77)
else begin
gt^.defined := true;
Gen1(dc_lab, gt^.lab);
end; {else}
end {if}
else
Gen1(pc_ujp, gt^.lab);
end; {GotoLabel}
{-- Statements -------------------------------------------------}
procedure CompoundStatement (makeSymbols: boolean);
{ handle a compound statement }
{ }
{ Parameters: }
{ makeSymbols - create a symbol table? (False for a }
{ function's outer wrapper, true for imbedded statements) }
var
stPtr: statementPtr; {for creating a compound statement record}
begin {CompoundStatement}
new(stPtr); {create a statement record}
stPtr^.lFenvAccess := fenvAccess; {save existing value of fenvAccess}
Match(lbracech,27); {make sure there is an opening '{'}
stPtr^.next := statementList;
statementList := stPtr;
stPtr^.kind := compoundSt;
if makeSymbols then {create a symbol table}
PushTable;
stPtr^.doingDeclaration := true; {allow declarations}
end; {CompoundStatement}
procedure EndCompoundStatement;
{ finish off a compound statement }
var
dumpLocal: boolean; {dump the local memory pool?}
tl: tempPtr; {work pointer}
stPtr: statementPtr; {work pointer}
begin {EndCompoundStatement}
while compoundLiteralToAllocate <> nil do begin {allocate compound literals}
Gen2(dc_loc, compoundLiteralToAllocate^.lln,
long(compoundLiteralToAllocate^.itype^.size).lsw);
compoundLiteralToAllocate := compoundLiteralToAllocate^.clnext;
end {while};
dumpLocal := false;
stPtr := statementList; {pop the statement record}
statementList := stPtr^.next;
doingFunction := statementList <> nil; {see if we're done with the function}
if not doingFunction then begin {if so, finish it off}
if doingMain then begin {executing to the end of main returns 0}
if fType^.kind = scalarType then begin
if fType^.baseType in [cgByte,cgUByte,cgWord,cgUWord] then begin
Gen1t(pc_ldc, 0, fType^.baseType);
Gen2t(pc_str, 0, 0, fType^.baseType);
end {if}
else if fType^.baseType in [cgLong,cgULong] then begin
GenLdcLong(0);
Gen2t(pc_str, 0, 0, fType^.baseType);
end; {else if}
end {if}
else if fType^.kind = enumType then begin
Gen1t(pc_ldc, 0, cgWord);
Gen2t(pc_str, 0, 0, cgWord);
end; {else if}
end; {if}
Gen1(dc_lab, returnLabel);
if vaInfoLLN <> 0 then begin {clean up variable args, if any}
Gen2(pc_lda, vaInfoLLN, 0);
Gen0t(pc_stk, cgULong);
Gen1tName(pc_cup, -1, cgVoid, @'__va_end');
end; {if}
with fType^ do {generate the pc_ret instruction}
case kind of
scalarType : Gen0t(pc_ret, baseType);
arrayType : ;
structType ,
unionType ,
pointerType : Gen0t(pc_ret, cgULong);
functionType: ;
enumConst : ;
enumType : Gen0t(pc_ret, cgWord);
definedType : ;
otherwise: Error(57);
end; {case}
Gen0 (dc_enp); {finish the segment}
CheckGotoList; {make sure all labels are declared}
while tempList <> nil do begin {dump the local labels}
tl := tempList;
tempList := tl^.next;
dispose(tl);
end; {while}
dumpLocal := true; {dump the local pool}
nameFound := false; {no pc_nam for the next function (yet)}
volatile := savedVolatile; {local volatile vars are out of scope}
fIsNoreturn := false; {not doing a noreturn function}
functionTable := nil;
functionName := nil;
end; {if}
PopTable; {remove this symbol table}
fenvAccess := stPtr^.lFenvAccess; {restore old value of fenvAccess}
dispose(stPtr); {dump the record}
if dumpLocal then begin
useGlobalPool := true; {start using the global memory pool}
LInit; {dispose of the local memory pool}
end; {if}
NextToken; {remove the rbracech token}
end; {EndCompoundStatement}
procedure Statement;
{ handle a statement }
label 1;
var
lToken,tToken: tokenType; {for look-ahead}
lPrintMacroExpansions: boolean; {local copy of printMacroExpansions}
function GetSwitchRecord: statementPtr;
{ Find the enclosing switch statement }
{ }
{ Returns a pointer to the closest switch statement record, }
{ or nil if there are none. }
label 1;
var
stPtr: statementPtr; {work pointer}
begin {GetSwitchRecord}
stPtr := statementList;
while stPtr <> nil do begin
if stPtr^.kind = switchSt then
goto 1;
stPtr := stPtr^.next;
end; {while}
1: GetSwitchRecord := stPtr;
end; {GetSwitchRecord}
procedure AssignmentStatement;
{ handle an assignment statement }
begin {AssignmentStatement}
if token.kind in startExpression then begin
Expression(normalExpression, [semicolonch]);
if expressionType^.baseType <> cgVoid then
Gen0t(pc_pop, UsualUnaryConversions);
if token.kind = semicolonch then
NextToken
else begin
Error(22);
SkipStatement;
end; {else}
end {if}
else begin
NextToken;
Error(92);
end; {else}
end; {AssignmentStatement}
procedure BreakStatement;
{ handle a break statement }
label 1,2;
var
stPtr: statementPtr; {work pointer}
begin {BreakStatement}
stPtr := statementList; {find the proper statement}
while stPtr <> nil do begin
if stPtr^.kind in [whileSt,doSt,forSt,switchSt] then
goto 1;
stPtr := stPtr^.next;
end; {while}
Error(76);
goto 2;
1: if stPtr^.breakLab = 0 then {if there is no break label, create one}
stPtr^.breakLab := GenLabel;
Gen1(pc_ujp, stPtr^.breakLab); {branch to the break label}
2:
NextToken; {skip the 'break' token}
Match(semicolonch,22); {insist on a closing ';'}
end; {BreakStatement}
procedure CaseStatement;
{ handle a case statement }
var
stPtr: statementPtr; {switch record for this case label}
swPtr,swPtr2: switchPtr; {work pointers for inserting new entry}
val: longlong; {case label value}
begin {CaseStatement}
while token.kind = casesy do begin
NextToken; {skip the 'case' token}
stPtr := GetSwitchRecord; {get the proper switch record}
Expression(arrayExpression, [colonch]); {evaluate the branch condition}
GetLLExpressionValue(val);
if stPtr^.size = cgLongSize then begin {convert out-of-range values}
if val.lo < 0 then
val.hi := -1
else
val.hi := 0;
end {if}
else if stPtr^.size = cgWordSize then begin
if long(val.lo).lsw < 0 then begin
val.hi := -1;
val.lo := val.lo | $FFFF0000;
end {if}
else begin
val.hi := 0;
val.lo := val.lo & $0000FFFF;
end; {else}
end; {else if}
if stPtr = nil then
Error(72)
else begin
new(swPtr2); {create the new label table entry}
swPtr2^.lab := GenLabel;
Gen1(dc_lab, swPtr2^.lab);
swPtr2^.val := val;
swPtr := stPtr^.switchList;
if val.lo > stPtr^.maxVal then
stPtr^.maxVal := val.lo;
if swPtr = nil then begin {enter it in the table}
swPtr2^.last := nil;
swPtr2^.next := nil;
stPtr^.switchList := swPtr2;
stPtr^.labelCount := 1;
end {if}
else begin
while (swPtr^.next <> nil) and slt64(swPtr^.val, val) do
swPtr := swPtr^.next;
if (swPtr^.val.lo = val.lo) and (swPtr^.val.hi = val.hi) then
Error(73)
else if sgt64(swPtr^.val, val) then begin
swPtr2^.next := swPtr;
if swPtr^.last = nil then
stPtr^.switchList := swPtr2
else
swPtr^.last^.next := swPtr2;
swPtr2^.last := swPtr^.last;
swPtr^.last := swPtr2;
end {else if}
else begin {at end of list}
swPtr2^.next := nil;
swPtr2^.last := swPtr;
swPtr^.next := swPtr2;
end; {else}
stPtr^.labelCount := stPtr^.labelCount + 1;
end; {else}
end; {else}
Match(colonch,29); {get the colon}
end; {while}
Statement; {process the labeled statement}
end; {CaseStatement}
procedure ContinueStatement;
{ handle a continue statement }
label 1,2;
var
stPtr: statementPtr; {work pointer}
begin {ContinueStatement}
stPtr := statementList; {find the proper statement}
while stPtr <> nil do begin
if stPtr^.kind in [whileSt,doSt,forSt] then
goto 1;
stPtr := stPtr^.next;
end; {while}
Error(75);
goto 2;
1: if stPtr^.continueLab = 0 then {if there is no continue label, create one}
stPtr^.continueLab := GenLabel;
Gen1(pc_ujp, stPtr^.continueLab); {branch to the continue label}
2:
NextToken; {skip the 'continue' token}
Match(semicolonch,22); {insist on a closing ';'}
end; {ContinueStatement}
procedure DefaultStatement;
{ handle a default statement }
var
stPtr: statementPtr; {work pointer}
begin {DefaultStatement}
NextToken; {skip the 'default' token}
Match(colonch,29); {get the colon}
stPtr := GetSwitchRecord; {record the presense of a default label}
if stPtr = nil then
Error(72)
else if stPtr^.switchDefault <> 0 then
Error(74)
else begin
stPtr^.switchDefault := GenLabel;
Gen1(dc_lab, stPtr^.switchDefault);
end; {else}
Statement; {process the labeled statement}
end; {DefaultStatement}
procedure DoStatement;
{ handle a do statement }
var
lab: integer; {branch label}
stPtr: statementPtr; {work pointer}
begin {DoStatement}
NextToken; {skip the 'do' token}
new(stPtr); {create a statement record}
stPtr^.next := statementList;
statementList := stPtr;
stPtr^.kind := doSt;
lab := GenLabel; {create the branch label}
Gen1(dc_lab, lab);
stPtr^.doLab := lab;
stPtr^.breakLab := 0;
stPtr^.continueLab := 0;
if c99Scope then PushTable;
if c99Scope then PushTable;
Statement; {process the first loop body statement}
end; {DoStatement}
procedure ForStatement;
{ handle a for statement }
var
errorFound: boolean; {did we find an error?}
forLoop, continueLab, breakLab: integer; {branch points}
lType: typePtr; {type of "left" expression}
parencount: integer; {number of unmatched '(' chars}
stPtr: statementPtr; {work pointer}
tl,tk: tokenStackPtr; {for forming expression list}
begin {ForStatement}
NextToken; {skip the 'for' token}
new(stPtr); {create a statement record}
stPtr^.next := statementList;
statementList := stPtr;
stPtr^.kind := forSt;
forLoop := GenLabel; {create the branch labels}
continueLab := GenLabel;
breakLab := GenLabel;
stPtr^.forLoop := forLoop;
stPtr^.continueLab := continueLab;
stPtr^.breakLab := breakLab;
if c99Scope then PushTable;
Match(lparench,13); {evaluate the start condition}
if allowMixedDeclarations and (token.kind in localDeclarationStart) then begin
doingForLoopClause1 := true;
DoDeclaration(false);
doingForLoopClause1 := false;
end {if}
else if token.kind <> semicolonch then begin
Expression(normalExpression, [semicolonch]);
Gen0t(pc_pop, UsualUnaryConversions);
Match(semicolonch,22);
end {else if}
else
NextToken;
Gen1(dc_lab, forLoop); {this label points to the condition}
if token.kind <> semicolonch then {handle the loop test}
begin {evaluate the expression}
Expression(normalExpression, [semicolonch]);
CompareToZero(pc_neq); {Evaluate the condition}
Gen1(pc_fjp, breakLab);
end; {if}
Match(semicolonch,22);
tl := nil; {collect the tokens for the last expression}
parencount := 0;
errorFound := false;
while (token.kind <> eofsy)
and ((token.kind <> rparench) or (parencount <> 0))
and (token.kind <> semicolonch) do begin
new(tk); {place the token in the list}
tk^.next := tl;
tl := tk;
tk^.token := token;
if token.kind = lparench then {allow parens in the expression}
parencount := parencount+1
else if token.kind = rparench then
parencount := parencount-1;
NextToken; {next token}
end; {while}
if errorFound then {if an error was found, dump the list}
while tl <> nil do begin
tk := tl;
tl := tl^.next;
dispose(tk);
end; {while}
stPtr^.e3List := tl; {save the list}
Match(rparench,12); {get the closing for loop paren}
if c99Scope then PushTable;
Statement; {process the first loop body statement}
end; {ForStatement}
procedure IfStatement;
{ handle an if statement }
var
lab: integer; {branch label}
lType: typePtr; {type of "left" expression}
stPtr: statementPtr; {work pointer}
begin {IfStatement}
NextToken; {skip the 'if' token}
if c99Scope then PushTable;
Match(lparench, 13); {evaluate the condition}
Expression(normalExpression, [rparench]);
Match(rparench, 12);
lab := GenLabel; {create the branch label}
CompareToZero(pc_neq); {evaluate the condition}
Gen1(pc_fjp, lab);
new(stPtr); {create a statement record}
stPtr^.next := statementList;
statementList := stPtr;
stPtr^.kind := ifSt;
stPtr^.ifLab := lab;
if c99Scope then PushTable;
Statement; {process the 'true' statement}
end; {IfStatement}
procedure GotoStatement;
{ handle a goto statement }
begin {GotoStatement}
NextToken; {skip the 'goto' token}
if token.kind in [ident,typedef] then begin
GotoLabel(pc_ujp); {jump to the label}
NextToken; {skip the token}
end {if}
else
Error(9); {flag the error}
Match(semicolonch, 22); {insist on a closing ';'}
end; {GotoStatement}
procedure LabelStatement;
{ handle a labeled statement }
begin {LabelStatement}
GotoLabel(dc_lab); {define the label}
NextToken; {skip the label}
if token.kind = colonch then {if present, skip the colon}
NextToken
else begin {bad statement - flag error and skip it}
Error(31);
SkipStatement;
end; {else}
end; {LabelStatement}
procedure ReturnStatement;
{ handle a return statement }
var
id: identPtr; {structure id}
size: longint; {size of the struct/union}
tk: tokenType; {structure name token}
begin {ReturnStatement}
if fIsNoreturn then
if (lint & lintReturn) <> 0 then
Error(153);
NextToken; {skip the 'return' token}
if token.kind <> semicolonch then {if present, evaluate the return value}
begin
if fType^.kind in [structType,unionType] then begin
tk.kind := ident;
tk.class := identifier;
tk.name := @'@struct';
tk.symbolPtr := nil;
id := FindSymbol(tk, variableSpace, false, true);
Gen1Name(pc_lao, 0, id^.name);
size := fType^.size;
end {if}
else if fType^.kind = scalarType then
if fType^.baseType in [cgQuad,cgUQuad] then
Gen2t(pc_lod, 0, 0, cgULong);
Expression(normalExpression, [semicolonch]);
AssignmentConversion(fType, expressionType, lastWasConst, lastConst,
true, false);
case fType^.kind of
scalarType: if fType^.baseType in [cgQuad,cgUQuad] then
Gen0t(pc_sto, fType^.baseType)
else
Gen2t(pc_str, 0, 0, fType^.baseType);
enumType: Gen2t(pc_str, 0, 0, cgWord);
pointerType: Gen2t(pc_str, 0, 0, cgULong);
structType,
unionType: begin
Gen2(pc_mov, long(size).msw, long(size).lsw);
Gen0t(pc_pop, cgULong);
end;
otherwise: ;
end; {case}
end {if}
else begin
if (fType^.kind <> scalarType) or (fType^.baseType <> cgVoid) then
if ((lint & lintC99Syntax) <> 0) or ((lint & lintReturn) <> 0) then
Error(152);
end; {else}
Gen1(pc_ujp, returnLabel); {branch to the exit point}
Match(semicolonch, 22); {insist on a closing ';'}
end; {ReturnStatement}
procedure SwitchStatement;
{ handle a switch statement }
var
stPtr: statementPtr; {work pointer}
tp: typePtr; {for checking type}
begin {SwitchStatement}
NextToken; {skip the 'switch' token}
new(stPtr); {create a statement record}
stPtr^.next := statementList;
statementList := stPtr;
stPtr^.kind := switchSt;
stPtr^.maxVal := -maxint4;
stPtr^.labelCount := 0;
stPtr^.switchLab := GenLabel;
stPtr^.switchExit := GenLabel;
stPtr^.breakLab := stPtr^.switchExit;
stPtr^.switchList := nil;
stPtr^.switchDefault := 0;
if c99Scope then PushTable;
Match(lparench, 13); {evaluate the condition}
Expression(normalExpression,[rparench]);
Match(rparench, 12);
tp := expressionType; {make sure the expression is integral}
while tp^.kind = definedType do
tp := tp^.dType;
case tp^.kind of
scalarType:
if tp^.baseType in [cgQuad,cgUQuad] then begin
stPtr^.size := cgQuadSize;
stPtr^.ln := GetTemp(cgQuadSize);
Gen2t(pc_str, stPtr^.ln, 0, cgQuad);
end {if}
else if tp^.baseType in [cgLong,cgULong] then begin
stPtr^.size := cgLongSize;
stPtr^.ln := GetTemp(cgLongSize);
Gen2t(pc_str, stPtr^.ln, 0, cgLong);
end {if}
else if tp^.baseType in [cgByte,cgUByte,cgWord,cgUWord] then begin
stPtr^.size := cgWordSize;
stPtr^.ln := GetTemp(cgWordSize);
Gen2t(pc_str, stPtr^.ln, 0, cgWord);
end {else if}
else
Error(71);
enumType: begin
stPtr^.size := cgWordSize;
stPtr^.ln := GetTemp(cgWordSize);
Gen2t(pc_str, stPtr^.ln, 0, cgWord);
end;
otherwise:
Error(71);
end; {case}
Gen1(pc_ujp, stPtr^.switchLab); {branch to the xjp instruction}
if c99Scope then PushTable;
Statement; {process the loop body statement}
end; {SwitchStatement}
procedure WhileStatement;
{ handle a while statement }
var
lType: typePtr; {type of "left" expression}
stPtr: statementPtr; {work pointer}
top, endl: integer; {branch points}
begin {WhileStatement}
NextToken; {skip the 'while' token}
new(stPtr); {create a statement record}
stPtr^.next := statementList;
statementList := stPtr;
stPtr^.kind := whileSt;
top := GenLabel; {create the branch labels}
endl := GenLabel;
stPtr^.whileTop := top;
stPtr^.whileEnd := endl;
stPtr^.breakLab := endl;
stPtr^.continueLab := top;
Gen1(dc_lab, top); {define the top label}
if c99Scope then PushTable;
Match(lparench, 13); {evaluate the condition}
Expression(normalExpression, [rparench]);
Match(rparench, 12);
CompareToZero(pc_neq); {evaluate the condition}
Gen1(pc_fjp, endl);
if c99Scope then PushTable;
Statement; {process the first loop body statement}
end; {WhileStatement}
begin {Statement}
1:
{if trace names are enabled and a line # is due, generate it}
if traceBack or debugFlag then
if nameFound or debugFlag then
if lastLine <> lineNumber then begin
lastLine := lineNumber;
Gen2(pc_lnm, lineNumber, ord(debugType));
end; {if}
{handle the statement}
case token.kind of
asmsy: begin
NextToken;
AsmStatement;
end;
breaksy: BreakStatement;
casesy: CaseStatement;
continuesy: ContinueStatement;
defaultsy: DefaultStatement;
dosy: DoStatement;
elsesy: begin Error(25); SkipStatement; end;
forsy: ForStatement;
gotosy: GotoStatement;
typedef,
ident: begin
lPrintMacroExpansions := printMacroExpansions;
printMacroExpansions := false;
lToken := token;
NextToken;
tToken := token;
PutBackToken(token, true);
token := lToken;
printMacroExpansions := lPrintMacroExpansions;
if tToken.kind = colonch then begin
LabelStatement;
goto 1;
end {if}
else
AssignmentStatement;
end;
ifsy: IfStatement;
lbracech: CompoundStatement(true);
returnsy: ReturnStatement;
semicolonch: NextToken;
switchsy: SwitchStatement;
whilesy: WhileStatement;
otherwise: AssignmentStatement;
end; {case}
end; {Statement}
procedure EndDoStatement;
{ finish off a do statement }
var
lType: typePtr; {type of "left" expression}
stPtr: statementPtr; {work pointer}
begin {EndDoStatement}
if c99Scope then PopTable;
stPtr := statementList; {get the statement record}
if token.kind = whilesy then begin {if a while clause exists, process it}
NextToken; {skip the 'while' token}
if stPtr^.continueLab <> 0 then {create the continue label}
Gen1(dc_lab, stPtr^.continueLab);
Match(lparench, 13); {evaluate the condition}
Expression(normalExpression, [rparench]);
Match(rparench, 12);
CompareToZero(pc_equ); {evaluate the condition}
Gen1(pc_fjp, stPtr^.doLab);
Match(semicolonch, 22); {process the closing ';'}
end {if}
else
Error(30); {'while' expected}
if stPtr^.breakLab <> 0 then {create the break label}
Gen1(dc_lab, stPtr^.breakLab);
statementList := stPtr^.next; {pop the statement record}
dispose(stPtr);
if c99Scope then PopTable;
end; {EndDoStatement}
procedure EndIfStatement;
{ finish off an if statement }
var
lab1,lab2: integer; {branch labels}
stPtr: statementPtr; {work pointer}
begin {EndIfStatement}
if c99Scope then PopTable;
stPtr := statementList; {get the label to branch to}
lab1 := stPtr^.ifLab;
statementList := stPtr^.next; {pop the statement record}
dispose(stPtr);
if token.kind = elsesy then begin {if an else clause exists, process it}
NextToken; {skip 'else'}
lab2 := GenLabel; {create the branch label}
Gen1(pc_ujp, lab2); {branch past the else clause}
Gen1(dc_lab, lab1); {create label for if to branch to}
new(stPtr); {create a statement record}
stPtr^.next := statementList;
statementList := stPtr;
stPtr^.kind := elseSt;
stPtr^.elseLab := lab2;
if c99Scope then PushTable;
Statement; {evaluate the else clause}
end {if}
else begin
Gen1(dc_lab, lab1); {create label for if to branch to}
if c99Scope then PopTable;
end; {else}
end; {EndIfStatement}
procedure EndElseStatement;
{ finish off an else clause }
var
stPtr: statementPtr; {work pointer}
begin {EndElseStatement}
if c99Scope then PopTable;
stPtr := statementList; {create the label to branch to}
Gen1(dc_lab, stPtr^.elseLab);
statementList := stPtr^.next; {pop the statement record}
dispose(stPtr);
if c99Scope then PopTable;
end; {EndElseStatement}
procedure EndForStatement;
{ finish off a for statement }
var
ltoken: tokenType; {for putting ; on stack}
stPtr: statementPtr; {work pointer}
tl,tk: tokenStackPtr; {for forming expression list}
lPrintMacroExpansions: boolean; {local copy of printMacroExpansions}
begin {EndForStatement}
if c99Scope then PopTable;
stPtr := statementList;
Gen1(dc_lab, stPtr^.continueLab); {define the continue label}
tl := stPtr^.e3List; {place the expression back in the list}
if tl <> nil then begin
PutBackToken(token, false);
ltoken.kind := semicolonch;
ltoken.class := reservedSymbol;
PutBackToken(ltoken, false);
while tl <> nil do begin
PutBackToken(tl^.token, false);
tk := tl;
tl := tl^.next;
dispose(tk);
end; {while}
lPrintMacroExpansions := printMacroExpansions; {inhibit token echo}
printMacroExpansions := false;
NextToken; {evaluate the expression}
Expression(normalExpression, [semicolonch]);
Gen0t(pc_pop, UsualUnaryConversions);
NextToken; {skip the semicolon}
printMacroExpansions := lPrintMacroExpansions;
end; {if}
Gen1(pc_ujp, stPtr^.forLoop); {loop to the test}
Gen1(dc_lab, stPtr^.breakLab); {create the exit label}
statementList := stPtr^.next; {pop the statement record}
dispose(stPtr);
if c99Scope then PopTable;
end; {EndForStatement}
procedure EndSwitchStatement;
{ finish off a switch statement }
const
sparse = 5; {label to tableSize ratio for sparse table}
var
default: integer; {default label}
ltp: baseTypeEnum; {base type}
minVal: integer; {min switch value}
stPtr: statementPtr; {work pointer}
{copies of vars (for efficiency)}
{-------------------------------}
exitLab: integer; {label at the end of the jump table}
isLong: boolean; {is the case expression long?}
isLongLong: boolean; {is the case expression long long?}
swPtr,swPtr2: switchPtr; {switch label table list}
begin {EndSwitchStatement}
if c99Scope then PopTable;
stPtr := statementList; {get the statement record}
exitLab := stPtr^.switchExit; {get the exit label}
isLong := stPtr^.size = cgLongSize; {get the long flag}
isLongLong := stPtr^.size = cgQuadSize; {get the long long flag}
swPtr := stPtr^.switchList; {Skip further generation if there were}
if swPtr <> nil then begin { no labels. }
default := stPtr^.switchDefault; {get a default label}
if default = 0 then
default := exitLab;
Gen1(pc_ujp, exitLab); {branch past the indexed jump}
Gen1(dc_lab, stPtr^.switchLab); {create the label for the xjp table}
if isLongLong then {decide on a base type}
ltp := cgQuad
else if isLong then
ltp := cgLong
else
ltp := cgWord;
if isLong or isLongLong
or (((stPtr^.maxVal-swPtr^.val.lo) div stPtr^.labelCount) > sparse) then
begin
{Long expressions and sparse switch statements are handled as a }
{series of if-goto tests. }
while swPtr <> nil do begin {generate the compares}
if isLongLong then
GenLdcQuad(swPtr^.val)
else if isLong then
GenLdcLong(swPtr^.val.lo)
else
Gen1t(pc_ldc, long(swPtr^.val.lo).lsw, cgWord);
Gen2t(pc_lod, stPtr^.ln, 0, ltp);
Gen0t(pc_equ, ltp);
Gen1(pc_tjp, swPtr^.lab);
swPtr2 := swPtr;
swPtr := swPtr^.next;
dispose(swPtr2);
end; {while}
Gen1(pc_ujp, default); {anything else goes to default}
end {if}
else begin
{compact word switch statements are handled with xjp}
minVal := long(swPtr^.val.lo).lsw; {record the min label value}
Gen2t(pc_lod, stPtr^.ln, 0, ltp); {get the value}
Gen1t(pc_dec, minVal, cgWord); {adjust the range}
Gen1(pc_xjp, ord(stPtr^.maxVal-minVal+1)); {do the indexed jump}
while swPtr <> nil do begin {generate the jump table}
while minVal < swPtr^.val.lo do begin
Gen1(pc_add, default);
minVal := minVal+1;
end; {while}
minVal := minVal+1;
Gen1(pc_add, swPtr^.lab);
swPtr2 := swPtr;
swPtr := swPtr^.next;
dispose(swPtr2);
end; {while}
Gen1(pc_add, default);
end; {if}
Gen1(dc_lab, exitLab); {generate the default label}
end {if}
else begin
Gen1(pc_ujp, exitLab); {branch past the indexed jump}
Gen1(dc_lab, stPtr^.switchLab); {create the label for the xjp table}
default := stPtr^.switchDefault; {if there is one, jump to the default label}
if default <> 0 then
Gen1(pc_ujp, default);
Gen1(dc_lab, exitLab); {generate the default label}
end; {else}
FreeTemp(stPtr^.ln, stPtr^.size); {release temp variable}
statementList := stPtr^.next; {pop the statement record}
dispose(stPtr);
if c99Scope then PopTable;
end; {EndSwitchStatement}
procedure EndWhileStatement;
{ finish off a while statement }
var
stPtr: statementPtr; {work pointer}
begin {EndWhileStatement}
if c99Scope then PopTable;
stPtr := statementList; {loop to the test}
Gen1(pc_ujp, stPtr^.whileTop);
Gen1(dc_lab, stPtr^.whileEnd); {create the exit label}
statementList := stPtr^.next; {pop the statement record}
dispose(stPtr);
if c99Scope then PopTable;
end; {EndWhileStatement}
{-- Type declarations ------------------------------------------}
procedure Declarator(tPtr: typePtr; var variable: identPtr; space: spaceType;
doingPrototypes: boolean);
{ handle a declarator }
{ }
{ parameters: }
{ tPtr - pointer to the type to use }
{ variable - pointer to variable being defined }
{ space - variable space to use }
{ doingPrototypes - are we compiling prototype parameter }
{ declarations? }
label 1;
type
typeDefPtr = ^typeDefRecord; {for stacking type records}
typeDefRecord = record
next: typeDefPtr;
typeDef: typePtr;
end;
pointerListPtr = ^pointerList; {for stacking pointer types}
pointerList = record
next: pointerListPtr;
qualifiers: typeQualifierSet;
end;
var
i: integer; {loop variable}
lastWasIdentifier: boolean; {for deciding if the declarator is a function}
lastWasPointer: boolean; {was the last type a pointer?}
newName: stringPtr; {new symbol name}
parameterStorage: boolean; {is the new symbol in a parm list?}
state: stateKind; {declaration state of the variable}
tPtr2: typePtr; {work pointer}
tsPtr: typeDefPtr; {work pointer}
typeStack: typeDefPtr; {stack of type definitions}
firstIteration: boolean; {first iteration of type-unstacking loop?}
{for checking function compatibility}
{-----------------------------------}
checkParms: boolean; {do we need to do type checking on the parm?}
compatible: boolean; {are the parameters compatible?}
ftoken: tokenType; {for checking extern functions}
p1,p2,p3: parameterPtr; {used to trace parameter lists}
pt1,pt2: typePtr; {parameter types}
t1: typePtr; {function type}
tk1,tk2: typeKind; {parameter type kinds}
unnamedParm: boolean; {is this an unnamed prototype?}
procedure StackDeclarations;
{ stack the declaration operators }
var
cp,cpList: pointerListPtr; {pointer list}
done,done2: boolean; {for loop termination}
isPtr: boolean; {is the parenthesized expr a ptr?}
isVoid: boolean; {is the type specifier void?}
wp: parameterPtr; {used to build prototype var list}
pvar: identPtr; {work pointer}
tPtr2: typePtr; {work pointer}
ttPtr: typeDefPtr; {work pointer}
parencount: integer; {for skipping in parm list}
gotStatic: boolean; {got 'static' in array declarator?}
{variables used to preserve states}
{ across recursive calls }
{---------------------------------}
lisFunction: boolean; {local copy of isFunction}
lisPascal: boolean; {local copy of isPascal}
lLastParameter: identPtr; {next parameter to process}
lstorageClass: tokenEnum; {storage class of the declaration}
ltypeSpec: typePtr; {type specifier}
luseGlobalPool: boolean; {local copy of useGlobalPool}
lPrintMacroExpansions: boolean; {local copy of printMacroExpansions}
begin {StackDeclarations}
lastWasIdentifier := false; {used to see if the declaration is a fn}
cpList := nil;
if token.kind = typedef then
token.kind := ident;
case token.kind of
ident: begin {handle 'ident'}
if space = fieldListSpace then
variable := nil
else
variable := FindSymbol(token, space, true, true);
newName := token.name;
if variable = nil then begin
if storageClass = typedefsy then begin
tPtr2 := pointer(Calloc(sizeof(typeRecord)));
{tPtr2^.size := 0;}
{tPtr2^.saveDisp := 0;}
tPtr2^.kind := definedType;
{tPtr^.qualifiers := [];}
tPtr2^.dType := tPtr;
end {if}
else
tPtr2 := tPtr;
if doingParameters then begin
if not doingPrototypes then
if not (tPtr2^.kind in
[enumConst,structType,unionType,definedType,pointerType])
then Error(50);
parameterStorage := true;
end; {if}
end {if}
else
checkParms := true;
NextToken;
if token.kind = eqch then
state := initialized;
lastWasIdentifier := true;
end;
asteriskch: begin {handle '*' 'declarator'}
while token.kind = asteriskch do begin
NextToken;
new(cp);
cp^.next := cpList;
cpList := cp;
cp^.qualifiers := [];
while token.kind in [_Alignassy..whilesy] do begin
if token.kind = constsy then
cpList^.qualifiers := cpList^.qualifiers + [tqConst]
else if token.kind = volatilesy then begin
cpList^.qualifiers := cpList^.qualifiers + [tqVolatile];
volatile := true
end {else if}
else if token.kind = restrictsy then {always allowed for now}
cpList^.qualifiers := cpList^.qualifiers + [tqRestrict]
else
Error(9);
NextToken;
end; {while}
end; {while}
StackDeclarations;
end;
lparench: begin {handle '(' 'declarator' ')'}
NextToken;
isPtr := token.kind = asteriskch;
StackDeclarations;
Match(rparench,12);
if isPtr then
lastWasIdentifier := false;
end;
otherwise:
if doingPrototypes then begin {allow for unnamed parameters}
pvar := pointer(Calloc(sizeof(identRecord)));
{pvar^.next := nil;}
{pvar^.saved := 0;}
pvar^.name := @'?';
pvar^.itype := tPtr;
{pvar^.disp := 0;}
{pvar^.bitDisp := 0;}
{pvar^.bitsize := 0;}
{pvar^.initialized := false;}
{pvar^.iPtr := nil;}
{pvar^.isForwardDeclared := false;}
pvar^.class := autosy;
pvar^.storage := parameter;
variable := pvar;
lastWasIdentifier := true;
newName := nil;
unnamedParm := true;
end; {if}
end; {case}
while token.kind in [lparench,lbrackch] do begin
{handle function declarations}
if token.kind = lparench then begin
lisPascal := isPascal; {preserve this flag}
PushTable; {create a symbol table}
{determine if it's a function}
isFunction := lastWasIdentifier or isFunction;
tPtr2 := pointer(GCalloc(sizeof(typeRecord))); {create the function type}
{tPtr2^.size := 0;}
{tPtr2^.saveDisp := 0;}
tPtr2^.kind := functionType;
{tPtr2^.qualifiers := [];}
{tPtr2^.varargs := false;}
{tPtr2^.prototyped := false;}
{tPtr2^.overrideKR := false;}
{tPtr2^.parameterList := nil;}
{tPtr2^.isPascal := false;}
{tPtr2^.toolNum := 0;}
{tPtr2^.dispatcher := 0;}
new(ttPtr);
ttPtr^.next := typeStack;
typeStack := ttPtr;
ttPtr^.typeDef := tPtr2;
NextToken; {skip the '(' token}
isVoid := token.kind = voidsy;
if token.kind = typedef then
if token.symbolPtr^.itype^.kind = scalarType then
if token.symbolPtr^.itype^.baseType = cgVoid then
isVoid := true;
if isVoid then begin {check for a void prototype}
lPrintMacroExpansions := printMacroExpansions;
printMacroExpansions := false;
NextToken;
printMacroExpansions := lPrintMacroExpansions;
if token.kind = rparench then begin
PutBackToken(token, false);
NextToken;
tPtr2^.prototyped := true;
end
else begin
PutBackToken(token, false);
token.kind := voidsy;
token.class := reservedSymbol;
end; {else}
end; {if}
{see if we are doing a prototyped list}
if token.kind in declarationSpecifiersElement then begin
{handle a prototype variable list}
numberOfParameters := 0; {don't allow K&R parm declarations}
luseGlobalPool := useGlobalPool; {use global memory}
useGlobalPool := true;
done2 := false;
lisFunction := isFunction; {preserve global variables}
ltypeSpec := typeSpec;
lstorageClass := storageClass;
with tPtr2^ do begin
prototyped := true; {it is prototyped}
repeat {collect the declarations}
if token.kind in declarationSpecifiersElement then begin
lLastParameter := lastParameter;
DoDeclaration(true);
lastParameter := lLastParameter;
if protoType <> nil then begin
wp := pointer(Malloc(sizeof(parameterRecord)));
wp^.next := parameterList;
parameterList := wp;
wp^.parameter := protoVariable;
wp^.parameterType := protoType;
if protoVariable <> nil then begin
protoVariable^.pnext := lastParameter;
lastParameter := protoVariable;
end; {if}
end; {if}
if token.kind = commach then begin
NextToken;
if token.kind = dotch then begin
NextToken;
Match(dotch,89);
Match(dotch,89);
varargs := true;
done2 := true;
end; {if}
end {if}
else
done2 := true;
end {if}
else begin
Error(26);
parencount := 0;
while (token.kind <> eofsy)
and ((parencount > 0) or (token.kind <> rparench)) do
begin
if token.kind = rparench then
parencount := parencount-1
else if token.kind = lparench then
parencount := parencount+1;
NextToken;
end; {while}
done2 := true;
end; {else}
until done2;
end; {with}
isFunction := lisFunction; {restore global variables}
storageClass := lstorageClass;
typeSpec := ltypeSpec;
useGlobalPool := luseGlobalPool;
end {if prototype}
else if token.kind = ident then begin
{handle a K&R variable list}
if (lint & lintNotPrototyped) <> 0 then
Error(105);
if doingFunction or doingPrototypes then
Error(12)
else begin
numberOfParameters := 0; {no function parms yet}
end; {else}
repeat {make a list of parameters}
if not doingFunction then begin
if token.kind <> ident then begin
Error(9);
while not (token.kind in [rparench,commach,ident]) do
NextToken;
end; {if}
if token.kind = ident then begin
pvar := NewSymbol(token.name, nil, ident, variableSpace,
declared);
pvar^.storage := parameter;
pvar^.pnext := lastParameter;
lastParameter := pvar;
numberOfParameters := numberOfParameters+1;
pvar^.bitdisp := numberOfParameters;
NextToken;
end; {if}
end; {if}
if token.kind = commach then begin
NextToken;
done := false;
end {if}
else
done := true;
until done or (token.kind = eofsy);
end {else if}
else if (lint & lintNotPrototyped) <> 0 then
if not tPtr2^.prototyped then
Error(105);
Match(rparench,12); {insist on a closing ')' token}
isPascal := lisPascal; {restore this flag}
end {if}
{handle array declarations}
else {if token.kind = lbrackch then} begin
lastWasIdentifier := false;
tPtr2 := pointer(Calloc(sizeof(typeRecord)));
{tPtr2^.size := 0;}
{tPtr2^.saveDisp := 0;}
{tPtr2^.qualifiers := [];}
tPtr2^.kind := arrayType;
{tPtr2^.elements := 0;}
NextToken;
gotStatic := false;
if doingParameters and (typeStack = nil) then begin
tPtr2^.kind := pointerType; {adjust to pointer type}
tPtr2^.size := cgPointerSize;
if token.kind = staticsy then begin
gotStatic := true;
NextToken;
end; {if}
while token.kind in [constsy,volatilesy,restrictsy] do begin
if token.kind = constsy then
tPtr2^.qualifiers := tPtr2^.qualifiers + [tqConst]
else if token.kind = volatilesy then begin
tPtr2^.qualifiers := tPtr2^.qualifiers + [tqVolatile];
volatile := true;
end {else}
else {if token.kind = restrictsy then}
tPtr2^.qualifiers := tPtr2^.qualifiers + [tqRestrict];
NextToken;
end; {while}
if not gotStatic then
if token.kind = staticsy then begin
gotStatic := true;
NextToken;
end; {if}
end; {if}
new(ttPtr);
ttPtr^.next := typeStack;
typeStack := ttPtr;
ttPtr^.typeDef := tPtr2;
if token.kind <> rbrackch then begin
Expression(arrayExpression, [rbrackch,semicolonch]);
if expressionValue <= 0 then begin
Error(45);
expressionValue := 1;
end; {if}
tPtr2^.elements := expressionValue;
end {if}
else if gotStatic then
Error(35);
Match(rbrackch,24);
end; {else if}
end; {while}
{stack pointer type records}
while cpList <> nil do begin
tPtr2 := pointer(Malloc(sizeof(typeRecord)));
tPtr2^.size := cgPointerSize;
tPtr2^.saveDisp := 0;
tPtr2^.qualifiers := cpList^.qualifiers;
tPtr2^.kind := pointerType;
new(ttPtr);
ttPtr^.next := typeStack;
typeStack := ttPtr;
ttPtr^.typeDef := tPtr2;
cp := cpList;
cpList := cp^.next;
dispose(cp);
end; {for}
end; {StackDeclarations}
begin {Declarator}
newName := nil; {no identifier, yet}
unnamedParm := false; {not an unnamed parameter}
if storageClass = externsy then {decide on a storage state}
state := declared
else
state := defined;
typeStack := nil; {no types so far}
parameterStorage := false; {symbol is not in a parameter list}
checkParms := false; {assume we won't need to check for parameter type errors}
StackDeclarations; {stack the type records}
firstIteration := true;
while typeStack <> nil do begin {reverse the type stack}
tsPtr := typeStack;
typeStack := tsPtr^.next;
if isFunction and (not useGlobalPool) then begin
tPtr2 := pointer(GMalloc(sizeof(typeRecord)));
tPtr2^ := tsPtr^.typeDef^;
tPtr2^.saveDisp := 0;
end {if}
else
tPtr2 := tsPtr^.typeDef;
dispose(tsPtr);
if tPtr^.kind = functionType then
if not firstIteration then
PopTable; {balance push in StackDeclarations}
case tPtr2^.kind of
pointerType: begin
tPtr2^.pType := tPtr;
end;
functionType: begin
while tPtr^.kind = definedType do
tPtr := tPtr^.dType;
tPtr2^.fType := Unqualify(tPtr);
if tPtr^.kind in [functionType,arrayType] then
Error(103);
end;
arrayType: begin
tPtr2^.size := tPtr^.size * tPtr2^.elements;
tPtr2^.aType := tPtr;
end;
otherwise: ;
end; {case}
tPtr := tPtr2;
firstIteration := false;
end; {while}
if doingParameters then {adjust array parameters to pointers}
if tPtr^.kind = arrayType then begin
tPtr2 := pointer(Calloc(sizeof(typeRecord)));
tPtr2^.size := cgPointerSize;
{tPtr2^.qualifiers := [];}
{tPtr2^.saveDisp := 0;}
tPtr2^.kind := pointerType;
tPtr2^.pType := tPtr^.aType;
tPtr := tPtr2;
end; {if}
if checkParms then begin {check for parameter type conflicts}
with variable^ do begin
if doingParameters then begin
if itype = nil then begin
itype := tPtr;
numberOfParameters := numberOfParameters-1;
if pfunc^.itype^.prototyped then begin
pfunc^.itype^.overrideKR := true;
p1 := nil;
for i := 1 to bitdisp do begin
p2 := pfunc^.itype^.parameterList;
while (p2^.next <> p1) and (p2 <> nil) do
p2 := p2^.next;
p1 := p2;
end; {for}
compatible := false;
if CompTypes(p1^.parameterType, tPtr) then
compatible := true
else begin
tk1 := p1^.parameterType^.kind;
tk2 := tPtr^.kind;
if (tk1 = arrayType) and (tk2 = pointerType) then
compatible :=
CompTypes(p1^.parameterType^.aType, tPtr^.pType)
else if (tk1 = pointerType) and (tk2 = arrayType) then
compatible :=
CompTypes(p1^.parameterType^.pType, tPtr^.aType);
end; {else}
if not compatible then
Error(47);
end; {if}
end {if}
else
Error(42);
storage := parameter;
parameterStorage := true;
end; {if}
end; {with}
end {if}
else if doingParameters then
if not doingPrototypes then
if pfunc^.itype^.prototyped then
if tPtr^.kind in
[enumConst,structType,unionType,definedType,pointerType]
then Error(50);
if tPtr^.kind = functionType then begin {declare the identifier}
if variable <> nil then begin
if isPascal then begin
{reverse the parameter list}
p2 := tptr^.parameterList;
p1 := nil;
while p2 <> nil do begin
p3 := p2;
p2 := p2^.next;
p3^.next := p1;
p1 := p3;
end; {while}
tPtr^.parameterList := p1;
end; {if}
t1 := variable^.itype;
if CompTypes(t1, tPtr) then begin
if t1^.prototyped and tPtr^.prototyped then begin
p2 := tPtr^.parameterList;
p1 := t1^.parameterList;
while (p1 <> nil) and (p2 <> nil) do begin
if p1^.parameter = nil then
pt1 := p1^.parameterType
else
pt1 := p1^.parameter^.itype;
if p2^.parameter = nil then
pt2 := p2^.parameterType
else
pt2 := p2^.parameter^.itype;
compatible := false;
if CompTypes(pt1, pt2) then
compatible := true
else begin
tk1 := pt1^.kind;
tk2 := pt2^.kind;
if (tk1 = arrayType) and (tk2 = pointerType) then
compatible := CompTypes(pt1^.aType, pt2^.pType)
else if (tk1 = pointerType) and (tk2 = arrayType) then
compatible := CompTypes(pt1^.pType, pt2^.aType)
end; {else}
if not compatible then begin
Error(47);
goto 1;
end; {if}
p1 := p1^.next;
p2 := p2^.next;
end; {while}
if p1 <> p2 then
Error(47);
end; {if}
end {if}
else
if (t1^.kind = functionType) and CompTypes(t1^.fType,tPtr^.fType) then
Error(47)
else
Error(42);
1:
if isPascal then begin
{reverse the parameter list}
p2 := tptr^.parameterList;
p1 := nil;
while p2 <> nil do begin
p3 := p2;
p2 := p2^.next;
p3^.next := p1;
p1 := p3;
end; {while}
tPtr^.parameterList := p1;
end; {if}
end; {if}
end; {if}
if tPtr^.kind = functionType then
state := declared;
if newName <> nil then {declare the variable}
variable := NewSymbol(newName, tPtr, storageClass, space, state)
else if unnamedParm then
variable^.itype := tPtr
else begin
if token.kind <> semicolonch then
Error(9);
variable := nil;
end; {else}
if variable <> nil then begin
if parameterStorage then
variable^.storage := parameter;
if isForwardDeclared then begin {handle forward declarations}
tPtr := variable^.itype;
lastWasPointer := false;
while tPtr^.kind in
[pointerType,arrayType,functionType,definedType] do begin
if tPtr^.kind = pointerType then
lastWasPointer := true
else if tPtr^.kind <> definedType then
lastWasPointer := false;
tPtr := tPtr^.pType;
end; {while}
if ((tPtr <> typeSpec) and (not (tPtr^.kind in [structType,unionType])))
then begin
Error(107);
SkipStatement;
end; {if}
variable^.isForwardDeclared := true;
end; {if}
end; {if}
end; {Declarator}
procedure Initializer (var variable: identPtr);
{ handle a variable initializer }
{ }
{ paramaters: }
{ variable - ptr to the identifier begin initialized }
var
bitcount: integer; {# if bits initialized}
bitvalue: longint; {bit field initializer value}
done: boolean; {for loop termination}
errorFound: boolean; {used to remove bad initializations}
iPtr,jPtr,kPtr: initializerPtr; {for reversing the list}
ip: identList; {used to place an id in the list}
luseGlobalPool: boolean; {local copy of useGlobalPool}
procedure InitializeBitField;
{ If bit fields have been initialized, fill them in }
{ }
{ Inputs: }
{ bitcount - # of bits initialized }
{ bitvalue - value of initializer }
var
iPtr: initializerPtr; {for creating an initializer entry}
begin {InitializeBitField}
if bitcount <> 0 then begin {skip if there has been no initializer}
{ writeln('InitializeBitField; bitcount = ', bitcount:1); {debug}
{create the initializer entry}
iPtr := pointer(Malloc(sizeof(initializerRecord)));
iPtr^.next := variable^.iPtr;
variable^.iPtr := iPtr;
iPtr^.isConstant := isConstant;
iPtr^.count := 1;
iPtr^.bitdisp := 0;
iPtr^.bitsize := 0;
iPtr^.isStructOrUnion := false;
iPtr^.iVal := bitvalue;
if bitcount <= 8 then
iPtr^.itype := cgUByte
else if bitcount <= 16 then
iPtr^.itype := cgUWord
else if bitcount > 24 then
iPtr^.itype := cgULong
else begin {3-byte bitfield: split into two parts}
iPtr^.itype := cgUWord;
iPtr^.iVal := bitvalue & $0000FFFF;
bitcount := bitcount - 16;
bitvalue := bitvalue >> 16;
InitializeBitField;
end;
bitcount := 0; {reset the bit field values}
bitvalue := 0;
end; {if}
end; {InitializeBitField}
procedure GetInitializerValue (tp: typePtr; bitsize,bitdisp: integer);
{ get the value of an initializer from a single expression }
{ }
{ parameters: }
{ tp - type of the variable being initialized }
{ bitsize - size of bit field (0 for non-bit fields) }
{ bitdisp - disp of bit field; unused if bitsize = 0 }
label 1,2,3;
var
bitmask: longint; {used to add a value to a bit field}
bKind: baseTypeEnum; {type of constant}
etype: typePtr; {expression type}
i: integer; {loop variable}
ip: identPtr; {ident in pointer constant}
iPtr: initializerPtr; {for creating an initializer entry}
kind: tokenEnum; {kind of constant}
offset, offset2: longint; {integer offset from a pointer}
operator: tokenEnum; {operator for constant pointers}
tKind: typeKind; {type of constant}
tree: tokenPtr; {for evaluating pointer constants}
function Subscript (tree: tokenPtr): typePtr;
{ handle subscripts in a pointer constant }
{ }
{ parameters: }
{ tree - subscript operators }
{ }
{ returns: type of the variable }
{ }
{ variables: }
{ iPtr - initializer location to store the array name }
{ offset - bytes past the start of the array }
var
ip: identPtr; {ident pointer}
rtree: tokenPtr; {work pointer}
tp: typePtr; {for tracking types}
select: longint; {selector size}
size: longint; {subscript value}
begin {Subscript}
if tree^.token.kind = uasterisk then begin
tree := tree^.left;
if tree^.token.kind = plusch then begin
rtree := tree^.right;
if rtree^.token.kind in
[intconst,uintconst,ushortconst,charconst,scharconst,ucharconst] then
size := rtree^.token.ival
else if rtree^.token.kind in [longconst,ulongconst] then
size := rtree^.token.lval
else if rtree^.token.kind in [longlongconst,ulonglongconst] then begin
size := rtree^.token.qval.lo;
with rtree^.token.qval do
if not (((hi = 0) and (lo & $ff000000 = 0)) or
((hi = -1) and (lo & $ff000000 = $ff000000))) then
Error(6);
end {else if}
else begin
Error(18);
errorFound := true;
end; {else}
tp := Subscript(tree^.left);
if tp^.kind <> arrayType then
Error(47)
else begin
tp := tp^.atype;
offset := offset + size*tp^.size;
Subscript := tp;
end; {else}
end {if}
else begin
Error(47);
errorFound := true;
Subscript := intPtr;
end; {else}
end {if}
else if tree^.token.kind = dotch then begin
tp := Subscript(tree^.left);
while tp^.kind = definedType do
tp := tp^.dType;
if tp^.kind in [structType,unionType] then begin
DoSelection(tp, tree^.right, select);
Subscript := expressionType;
offset := offset+select;
if isBitField then
Error(106);
end {if}
else begin
Error(47);
errorFound := true;
Subscript := intPtr;
end; {else}
end {else if}
else if tree^.token.kind = ident then begin
ip := FindSymbol(tree^.token, allSpaces, false, true);
if ip = nil then begin
Error(31);
errorFound := true;
Subscript := intPtr;
iPtr^.pName := @'?';
end {if}
else begin
Subscript := ip^.itype;
iPtr^.pName := ip^.name;
end; {else}
end {else if}
else begin
Error(47);
errorFound := true;
Subscript := intPtr;
end; {else}
end; {Subscript}
begin {GetInitializerValue}
if token.kind in [dotch,lbrackch] then begin
{designated initializer: give error and skip over it}
Error(150);
while token.kind in [dotch,lbrackch] do begin
if token.kind = lbrackch then begin
NextToken;
Expression(arrayExpression, [rbrackch]);
if token.kind = rbrackch then
NextToken;
end {if}
else {if token.kind = dotch then} begin
NextToken;
if token.kind in [ident,typedef] then
NextToken;
end {if}
end; {while}
if token.kind = eqch then
NextToken;
end; {if}
if variable^.storage = stackFrame then
Expression(autoInitializerExpression, [commach,rparench,rbracech])
else
Expression(initializerExpression, [commach,rparench,rbracech]);
if bitsize = 0 then begin
iPtr := pointer(Malloc(sizeof(initializerRecord)));
iPtr^.next := variable^.iPtr;
variable^.iPtr := iPtr;
iPtr^.isConstant := isConstant;
iPtr^.count := 1;
iPtr^.bitdisp := 0;
iPtr^.bitsize := 0;
iPtr^.isStructOrUnion := false;
end; {if}
etype := expressionType;
AssignmentConversion(tp, expressionType, isConstant, expressionValue,
false, false);
if variable^.storage = external then
variable^.storage := global;
if isConstant and (variable^.storage in [external,global,private]) then begin
if bitsize = 0 then begin
if etype^.baseType in [cgQuad,cgUQuad] then begin
iPtr^.qVal := llExpressionValue;
end {if}
else begin
iPtr^.qval.hi := 0;
iPtr^.iVal := expressionValue;
end; {else}
iPtr^.itype := tp^.baseType;
InitializeBitField;
end; {if}
case tp^.kind of
scalarType: begin
bKind := tp^.baseType;
if (etype^.baseType in [cgByte..cgULong,cgQuad,cgUQuad])
and (bKind in [cgByte..cgULong,cgQuad,cgUQuad]) then begin
if bKind in [cgLong,cgULong,cgQuad,cgUQuad] then
if eType^.baseType = cgUByte then
iPtr^.iVal := iPtr^.iVal & $000000FF
else if eType^.baseType = cgUWord then
iPtr^.iVal := iPtr^.iVal & $0000FFFF;
if bKind in [cgQuad,cgUQuad] then
if etype^.baseType in [cgByte..cgULong] then
if (etype^.baseType in [cgByte,cgWord,cgLong])
and (iPtr^.iVal < 0) then
iPtr^.qVal.hi := -1
else
iPtr^.qVal.hi := 0;
goto 3;
end; {if}
if bKind in [cgReal,cgDouble,cgComp,cgExtended] then begin
if etype^.baseType in [cgByte..cgULong] then
iPtr^.rVal := expressionValue
else if etype^.baseType in
[cgReal,cgDouble,cgComp,cgExtended] then
iPtr^.rval := realExpressionValue;
goto 3;
end; {if}
Error(47);
errorFound := true;
goto 2;
3: if bitsize <> 0 then begin
{set up a bit field value}
if bitdisp < bitcount then
InitializeBitField;
bitmask := 0;
for i := 1 to bitsize do
bitmask := (bitmask << 1) | 1;
bitmask := bitmask & expressionValue;
for i := 1 to bitdisp do
bitmask := bitmask << 1;
bitvalue := bitvalue | bitmask;
bitcount := bitcount + bitsize;
end; {if}
end;
arrayType: begin
if tp^.aType^.kind = scalarType then
if tp^.aType^.baseType in [cgByte,cgUByte] then
if eType^.baseType = cgString then
goto 2;
Error(46);
errorFound := true;
end;
pointerType:
if (etype = stringTypePtr) or (etype = utf16StringTypePtr)
or (etype = utf32StringTypePtr) then begin
iPtr^.isConstant := true;
iPtr^.iType := ccPointer;
iPtr^.pval := 0;
iPtr^.pPlus := false;
iPtr^.isName := false;
iPtr^.pStr := longstringPtr(expressionValue);
end {if}
else if etype^.kind = scalarType then
if etype^.baseType in [cgByte..cgULong] then
if expressionValue = 0 then
iPtr^.iType := cgULong
else begin
Error(47);
errorFound := true;
end {else}
else if etype^.baseType in [cgQuad,cgUQuad] then
if (llExpressionValue.hi = 0) and
(llExpressionValue.lo = 0) then
iPtr^.iType := cgULong
else begin
Error(47);
errorFound := true;
end {else}
else begin
Error(48);
errorFound := true;
end {else}
else if etype^.kind = pointerType then begin
iPtr^.iType := cgULong;
iPtr^.pval := expressionValue;
end {else if}
else begin
Error(48);
errorFound := true;
end; {else}
structType,unionType,enumType: begin
Error(46);
errorFound := true;
end;
otherwise:
Error(57);
end; {case}
2: DisposeTree(initializerTree);
end {if}
else begin
if ((tp^.kind = pointerType)
or ((tp^.kind = scalarType) and (tp^.baseType in [cgLong,cgULong])))
and (bitsize = 0)
then begin
iPtr^.iType := ccPointer;
if variable^.storage in [external,global,private] then begin
{do pointer constants with + or -}
iPtr^.isConstant := true;
tree := initializerTree;
while tree^.token.kind = castoper do
tree := tree^.left;
offset := 0;
operator := tree^.token.kind;
while operator in [plusch,minusch] do begin
with tree^.right^.token do
if kind in [intConst,uintconst,ushortconst,longConst,
ulongconst,longlongConst,ulonglongconst,charconst,
scharconst,ucharconst] then begin
if kind in [intConst,charconst,scharconst,ucharconst] then
offSet2 := ival
else if kind in [uintConst,ushortconst] then
offset2 := ival & $0000ffff
else if kind in [longConst,ulongconst] then begin
offset2 := lval;
if (lval & $ff000000 <> 0)
and (lval & $ff000000 <> $ff000000) then
Error(6);
end {else if}
else {if kind = longlongConst then} begin
offset2 := qval.lo;
with qval do
if not (((hi = 0) and (lo & $ff000000 = 0)) or
((hi = -1) and (lo & $ff000000 = $ff000000))) then
Error(6);
end; {else}
if operator = plusch then
offset := offset + offset2
else
offset := offset - offset2;
end {if}
else begin
Error(47);
errorFound := true;
end; {else}
tree := tree^.left;
operator := tree^.token.kind;
end; {if}
kind := tree^.token.kind;
if kind = ident then begin
{handle names of functions or static arrays}
ip := FindSymbol(tree^.token, allSpaces, false, true);
if ip = nil then begin
Error(31);
errorFound := true;
end {if}
else begin
tKind := ip^.itype^.kind;
if tKind = functionType then begin
if operator in [plusch,minusch] then begin
Error(47);
errorFound := true;
end; {if}
end {if}
else if (tKind = arrayType)
and (ip^.storage in [external,global,private]) then begin
offset := offset*ip^.itype^.atype^.size;
end {else if}
else if tKind = pointerType then begin
Error(48);
errorFound := true;
end {else if}
else begin
Error(47);
errorFound := true;
end; {else}
iPtr^.pval := offset;
iPtr^.pPlus := true;
iPtr^.isName := true;
iPtr^.pName := ip^.name;
end; {if}
end {if}
else if kind = uand then begin
tree := tree^.left;
iPtr^.pPlus := true;
iPtr^.isName := true;
if tree^.token.kind = ident then begin
ip := FindSymbol(tree^.token, allSpaces, false, true);
if ip = nil then begin
Error(31);
errorFound := true;
end {if}
else
if ip^.storage in [external,global,private] then begin
offset := offset*ip^.itype^.size;
iPtr^.pName := ip^.name;
end {if}
else begin
Error(47);
errorFound := true;
end; {else}
end {if}
else begin
tp := Subscript(tree);
if offset > 0 then
iPtr^.pPlus := true
else begin
iPtr^.pPlus := false;
offset := -offset;
end; {else}
end; {else}
iPtr^.pval := offset;
end {else if}
else if kind in [dotch,uasterisk] then begin
iPtr^.isName := true;
tp := Subscript(tree);
if offset > 0 then
iPtr^.pPlus := true
else begin
iPtr^.pPlus := false;
offset := -offset;
end; {else}
iPtr^.pval := offset;
end {else if}
else if kind = stringConst then begin
iPtr^.pval := offset;
iPtr^.pPlus := true;
iPtr^.isName := false;
iPtr^.pStr := tree^.token.sval;
end {else if}
else begin
Error(47);
errorFound := true;
end; {else}
DisposeTree(initializerTree);
goto 1;
end; {if}
end {if}
else if tp^.kind in [structType,unionType] then
iPtr^.isStructOrUnion := true;
{handle auto variables}
if bitsize <> 0 then begin
iPtr := pointer(Malloc(sizeof(initializerRecord)));
iPtr^.next := variable^.iPtr;
variable^.iPtr := iPtr;
iPtr^.isConstant := isConstant;
iPtr^.count := 1;
iPtr^.bitdisp := bitdisp;
iPtr^.bitsize := bitsize;
iPtr^.isStructOrUnion := false;
end; {if}
if variable^.storage in [external,global,private] then begin
Error(41);
errorFound := true;
end; {else}
iPtr^.isConstant := false;
iPtr^.iTree := initializerTree;
iPtr^.bitdisp := bitdisp;
iPtr^.bitsize := bitsize;
end; {else}
1:
end; {GetInitializerValue}
procedure InitializeTerm (tp: typePtr; bitsize,bitdisp: integer;
main: boolean);
{ initialize one level of the type }
{ }
{ parameters: }
{ tp - pointer to the type being initialized }
{ bitsize - size of bit field (0 for non-bit fields) }
{ bitdisp - disp of bit field; unused if bitsize = 0 }
{ main - is this a call from the main level? }
var
bitCount: integer; {# of bits in a union}
braces: boolean; {is the initializer inclosed in braces?}
count,maxCount: longint; {for tracking the size of an initializer}
ep: tokenPtr; {for forming string expression}
iPtr: initializerPtr; {for creating an initializer entry}
ip: identPtr; {for tracing field lists}
kind: typeKind; {base type of an initializer}
ktp: typePtr; {array type with definedTypes removed}
lPrintMacroExpansions: boolean; {local copy of printMacroExpansions}
stringElementType: typePtr; {element type of string literal}
stringLength: integer; {elements in a string literal}
procedure Fill (count: longint; tp: typePtr);
{ fill in unspecified space in an initialized array with 0 }
{ }
{ parameters: }
{ count - ^ elements of this type to create }
{ tp - ptr to type of elements to create }
var
i: longint; {loop variable}
iPtr: initializerPtr; {for creating an initializer entry}
tk: tokenPtr; {expression record}
ip: identPtr; {pointer to next field in a structure}
begin {Fill}
{ writeln('Fill tp^.kind = ', ord(tp^.kind):1, '; count = ', count:1); {debug}
InitializeBitField; {if needed, do the bit field}
if tp^.kind = arrayType then
{fill an array}
Fill(count*tp^.elements ,tp^.aType)
else if tp^.kind = structType then begin
{fill a structure}
if variable^.storage in [external,global,private] then
Fill(count * tp^.size, sCharPtr)
else begin
i := count;
while i <> 0 do begin
ip := tp^.fieldList;
while ip <> nil do begin
Fill(1, ip^.iType);
ip := ip^.next;
end; {while}
i := i-1;
end; {while}
end; {else}
end {else if}
else if tp^.kind = unionType then begin
{fill a union}
if variable^.storage in [external,global,private] then
Fill(count * tp^.size, sCharPtr)
else
Fill(count, tp^.fieldList^.iType);
end {else if}
else
{fill a single value}
while count <> 0 do begin
iPtr := pointer(Calloc(sizeof(initializerRecord)));
iPtr^.next := variable^.iPtr;
variable^.iPtr := iPtr;
iPtr^.isConstant := variable^.storage in [external,global,private];
{iPtr^.bitdisp := 0;}
{iPtr^.bitsize := 0;}
{iPtr^.isStructOrUnion := false;}
if iPtr^.isConstant then begin
if tp^.kind = scalarType then
iPtr^.itype := tp^.baseType
else if tp^.kind = pointertype then begin
iPtr^.itype := cgULong;
{iPtr^.iVal := 0;}
end {else if}
else begin
iPtr^.itype := cgWord;
Error(47);
errorFound := true;
end; {else}
end {if}
else begin
new(tk);
tk^.next := nil;
tk^.left := nil;
tk^.middle := nil;
tk^.right := nil;
tk^.token.kind := intconst;
tk^.token.class := intConstant;
tk^.token.ival := 0;
iPtr^.iTree := tk;
end; {else}
if count < 16384 then begin
iPtr^.count := long(count).lsw;
count := 0;
end {if}
else begin
iPtr^.count := 16384;
count := count-16384;
end; {else}
end; {while}
end; {Fill}
procedure RecomputeSizes (tp: typePtr);
{ a size has been inferred from an initializer - set the }
{ appropriate type size values }
{ }
{ parameters: }
{ tp - type to check }
begin {RecomputeSizes}
if tp^.aType^.kind = arrayType then
RecomputeSizes(tp^.aType);
with tp^ do
size := aType^.size*elements;
end; {RecomputeSizes}
begin {InitializeTerm}
braces := false; {allow for an opening brace}
if token.kind = lbracech then begin
NextToken;
braces := true;
end; {if}
{handle arrays}
while tp^.kind = definedType do
tp := tp^.dType;
kind := tp^.kind;
if kind = arrayType then begin
ktp := tp^.atype;
while ktp^.kind = definedType do
ktp := ktp^.dType;
kind := ktp^.kind;
{handle string constants}
if token.kind = stringConst then
stringElementType := StringType(token.prefix)^.aType;
if (token.kind = stringConst) and (kind = scalarType) and
(((ktp^.baseType in [cgByte,cgUByte])
and (stringElementType = charPtr))
or CompTypes(ktp,stringElementType)) then begin
stringLength := token.sval^.length div ord(stringElementType^.size);
if tp^.elements = 0 then begin
tp^.elements := stringLength;
RecomputeSizes(variable^.itype);
end {if}
else if tp^.elements < stringLength-1 then begin
Error(44);
errorFound := true;
end; {else if}
with ktp^ do begin
iPtr := pointer(Malloc(sizeof(initializerRecord)));
iPtr^.next := variable^.iPtr;
variable^.iPtr := iPtr;
iPtr^.count := 1;
iPtr^.bitdisp := 0;
iPtr^.bitsize := 0;
iPtr^.isStructOrUnion := false;
if (variable^.storage in [external,global,private]) then begin
iPtr^.isConstant := true;
iPtr^.itype := cgString;
iPtr^.sval := token.sval;
count := tp^.elements - stringLength;
if count > 0 then
Fill(count, stringElementType)
else if count = -1 then begin
iPtr^.sval := pointer(GMalloc(token.sval^.length+2));
CopyLongString(iPtr^.sval, token.sval);
iPtr^.sval^.length :=
iPtr^.sval^.length - ord(stringElementType^.size);
end; {else if}
end {if}
else begin
iPtr^.isConstant := false;
new(ep);
iPtr^.iTree := ep;
ep^.next := nil;
ep^.left := nil;
ep^.middle := nil;
ep^.right := nil;
ep^.token := token;
end; {else}
end; {with}
NextToken;
end {if}
{handle arrays not initialized with a string constant}
else if kind in
[scalarType,pointerType,enumType,arrayType,structType,unionType] then
begin
count := 0; {get the expressions|initializers}
maxCount := tp^.elements;
if token.kind <> rbracech then
repeat
InitializeTerm(ktp, 0, 0, false);
count := count+1;
if count <> maxCount then begin
if token.kind = commach then begin
NextToken;
done := token.kind = rbracech;
end {if}
else
done := true;
end {if}
else
done := true;
until done or (token.kind = eofsy) or (count = maxCount);
if maxCount <> 0 then begin
count := maxCount-count;
if count <> 0 then {if there weren't enough initializers...}
Fill(count,ktp); { fill in the blank spots}
end {if}
else begin
tp^.elements := count; {set the array size}
RecomputeSizes(variable^.itype);
end; {else}
end {else if}
else begin
Error(47);
errorFound := true;
end; {else}
end {if}
{handle structures and unions}
else if kind in [structType, unionType] then begin
if braces or (not main) then begin
count := tp^.size;
ip := tp^.fieldList;
bitCount := 0;
lPrintMacroExpansions := printMacroExpansions;
while (ip <> nil) and (ip^.itype^.size > 0) do begin
if ip^.isForwardDeclared then
ResolveForwardReference(ip);
if token.kind = rbracech then begin {initialize this field to 0}
printMacroExpansions := false; {inhibit token echo}
PutBackToken(token, false);
PutBackToken(token, false);
token.kind := intconst;
token.class := intConstant;
token.ival := 0;
PutBackToken(token, false);
token.kind := lbracech;
token.class := reservedSymbol;
end; {if}
if ip^.bitSize = 0 then
if bitCount > 0 then begin
InitializeBitField;
bitCount := (bitCount+7) div 8;
count := count-bitCount;
bitCount := 0;
end; {if}
InitializeTerm(ip^.itype, ip^.bitsize, ip^.bitdisp, false);
if ip^.bitSize <> 0 then begin
bitCount := bitCount + ip^.bitSize;
if bitCount > maxBitField then begin
count := count - (maxBitField div 8);
bitCount := ip^.bitSize;
end; {if}
end {if}
else begin
count := count-ip^.itype^.size;
end; {else}
{ writeln('Initializer: ', ip^.bitsize:10, ip^.bitdisp:10, bitCount:10); {debug}
if kind = unionType then
ip := nil
else
ip := ip^.next;
if token.kind = commach then begin
if ip <> nil then
NextToken;
end {if}
else if token.kind <> rbracech then
ip := nil;
end; {while}
if bitCount > 0 then begin
InitializeBitField;
bitCount := (bitCount+7) div 8;
count := count-bitCount;
bitCount := 0;
end; {if}
if count > 0 then
if variable^.storage in [external,global,private] then
Fill(count, sCharPtr);
printMacroExpansions := lPrintMacroExpansions;
end {if}
else {struct/union assignment initializer}
GetInitializerValue(tp, bitsize, bitdisp);
end {else if}
{handle single-valued types}
else if kind in [scalarType,pointerType,enumType] then
GetInitializerValue(tp, bitsize, bitdisp)
else begin
Error(47);
errorFound := true;
end; {else}
if braces then begin {if there was an opening brace then }
if token.kind = commach then { insist on a closing brace }
NextToken;
if token.kind = rbracech then
NextToken
else begin
Error(23);
while not (token.kind in [rbracech,eofsy]) do
NextToken;
NextToken;
errorFound := true;
end; {else}
end; {if}
end; {InitializeTerm}
begin {Initializer}
bitcount := 0; {set up for bit fields}
bitvalue := 0;
errorFound := false; {no errors found so far}
luseGlobalPool := useGlobalPool; {use global memory for global vars}
useGlobalPool := (variable^.storage in [external,global,private])
or useGlobalPool;
{make sure a required '{' is there}
if not (token.kind in [lbracech,stringConst]) then
if variable^.itype^.kind = arrayType then begin
Error(27);
errorFound := true;
end; {if}
InitializeTerm(variable^.itype, 0, 0, true); {do the initialization}
variable^.state := initialized; {mark the variable as initialized}
iPtr := variable^.iPtr; {reverse the initializer list}
jPtr := nil;
while iPtr <> nil do begin
kPtr := iPtr;
iPtr := iPtr^.next;
kPtr^.next := jPtr;
jPtr := kPtr;
end; {while}
variable^.iPtr := jPtr;
if errorFound then {eliminate bad initializers}
variable^.state := defined;
useGlobalPool := luseGlobalPool; {restore useGlobalPool}
end; {Initializer}
procedure DoStaticAssert;
{ process a static assertion }
begin {DoStaticAssert}
NextToken;
Match(lparench, 13);
Expression(arrayExpression, [commach]);
if (expressionType = nil) or (expressionType^.kind <> scalarType) then
Error(18)
else if expressionValue = 0 then
Error(132);
Match(commach, 86);
Match(stringconst, 83);
Match(rparench, 12);
Match(semicolonch, 22);
end; {DoStaticAssert}
procedure DeclarationSpecifiers (allowedTokens: tokenSet;
expectedNext: tokenEnum);
{ handle declaration specifiers or a specifier-qualifier list }
{ }
{ parameters: }
{ allowedTokens - specifiers/qualifiers that can be used }
{ expectedNext - token usually expected after declaration }
{ specifiers (used for error messages only) }
{ }
{ outputs: }
{ isForwardDeclared - is the field list component }
{ referencing a forward struct/union? }
{ skipDeclarator - for enum,struct,union with no }
{ declarator }
{ typespec - type specifier }
{ declarationModifiers - all storage class specifiers, }
{ type qualifiers, function specifiers, and }
{ alignment specifiers in this declaration }
label 1,2,3;
var
done: boolean; {for loop termination}
enumVal: integer; {default value for the next enum constant}
tPtr: typePtr; {for building types}
variable: identPtr; {enumeration variable}
structPtr: identPtr; {structure identifier}
structTypePtr: typePtr; {structure type}
tKind: typeKind; {defining structure or union?}
ttoken: tokenType; {temp variable for struct name}
lUseGlobalPool: boolean; {local copy of useGlobalPool}
globalStruct: boolean; {did we force global pool use?}
typeSpecifiers: tokenSet; {set of tokens specifying the type}
typeDone: boolean; {no more type specifiers can be accepted}
typeQualifiers: typeQualifierSet; {set of type qualifiers found}
myIsForwardDeclared: boolean; {value of isForwardDeclared to generate}
mySkipDeclarator: boolean; {value of skipDeclarator to generate}
myTypeSpec: typePtr; {value of typeSpec to generate}
myDeclarationModifiers: tokenSet; {all modifiers in this declaration}
isLongLong: boolean; {is this a "long long" type?}
procedure FieldList (tp: typePtr; kind: typeKind);
{ handle a field list }
{ }
{ parameters }
{ tp - place to store the type pointer }
label 1;
var
bitDisp: integer; {current bit disp}
disp: longint; {current byte disp}
done: boolean; {for loop termination}
fl,tfl,ufl: identPtr; {field list}
ldoingParameters: boolean; {local copy of doingParameters}
lisForwardDeclared: boolean; {local copy of isForwardDeclared}
lstorageClass: tokenEnum; {storage class of the declaration}
maxDisp: longint; {for determining union sizes}
variable: identPtr; {variable being defined}
didFlexibleArray: boolean; {have we seen a flexible array member?}
alignmentSpecified: boolean; {was alignment explicitly specified?}
begin {FieldList}
ldoingParameters := doingParameters; {allow fields in K&R dec. area}
doingParameters := false;
lisForwardDeclared := isForwardDeclared; {stack this value}
lStorageClass := storageClass; {don't allow auto in a struct}
storageClass := ident;
bitDisp := 0; {start allocation from byte 0}
disp := 0;
maxDisp := 0;
didFlexibleArray := false;
fl := nil; {nothing in the field list, yet}
{while there are entries in the field list...}
1: while token.kind in structDeclarationStart do begin
if token.kind = _Static_assertsy then begin
DoStaticAssert;
goto 1;
end; {if}
DeclarationSpecifiers(specifierQualifierListElement, ident);
alignmentSpecified := _Alignassy in declarationModifiers;
if not skipDeclarator then
repeat {declare the variables...}
if didFlexibleArray then
Error(118);
variable := nil;
if token.kind <> colonch then begin
Declarator(typeSpec, variable, fieldListSpace, false);
if variable <> nil then {enter the var in the field list}
begin
tfl := fl; {(check for dups)}
while tfl <> nil do begin
if tfl^.name^ = variable^.name^ then
Error(42);
tfl := tfl^.next;
end; {while}
variable^.next := fl;
fl := variable;
end; {if}
end; {if}
if kind = unionType then begin
disp := 0;
bitdisp := 0;
end; {if}
if token.kind = colonch then {handle a bit field}
begin
NextToken;
Expression(arrayExpression,[commach,semicolonch]);
if (expressionValue >= maxBitField) or (expressionValue < 0) then
begin
Error(54);
expressionValue := maxBitField-1;
end; {if}
if (bitdisp+long(expressionValue).lsw > maxBitField)
or (long(expressionValue).lsw = 0) then begin
disp := disp+((bitDisp+7) div 8);
bitdisp := 0;
if long(expressionValue).lsw = 0 then
if variable <> nil then
Error(55);
end; {if}
if variable <> nil then begin
variable^.disp := disp;
variable^.bitdisp := bitdisp;
variable^.bitsize := long(expressionValue).lsw;
tPtr := variable^.itype;
end {if}
else
tPtr := typeSpec;
bitdisp := bitdisp+long(expressionValue).lsw;
if kind = unionType then
if ((bitDisp+7) div 8) > maxDisp then
maxDisp := ((bitDisp+7) div 8);
if (tPtr^.kind <> scalarType)
or not (tPtr^.baseType in
[cgByte,cgUByte,cgWord,cgUWord,cgLong,cgULong])
or (expressionValue > tPtr^.size*8)
or ((expressionValue > 1) and (tPtr^.cType = ctBool)) then
Error(115);
if alignmentSpecified then
Error(142);
end {if}
else if variable <> nil then begin
if bitdisp <> 0 then begin
disp := disp+((bitDisp+7) div 8);
bitdisp := 0;
end; {if}
variable^.disp := disp;
variable^.bitdisp := bitdisp;
variable^.bitsize := 0;
disp := disp + variable^.itype^.size;
if disp > maxDisp then
maxDisp := disp;
if variable^.itype^.size = 0 then
if (variable^.itype^.kind = arrayType)
and (disp > 0) then begin {handle flexible array member}
didFlexibleArray := true;
tp^.flexibleArrayMember := true;
end {if}
else
Error(117);
end {if}
else
Error(116);
if variable <> nil then {check for a const member}
tPtr := variable^.itype
else
tPtr := typeSpec;
while tPtr^.kind in [definedType,arrayType] do begin
if tqConst in tPtr^.qualifiers then
tp^.constMember := true;
if tPtr^.kind = definedType then
tPtr := tPtr^.dType
else {if tPtr^.kind = arrayType then}
tPtr := tPtr^.aType;
end; {while}
if tqConst in tPtr^.qualifiers then
tp^.constMember := true;
if tPtr^.kind in [structType,unionType] then begin
if tPtr^.constMember then
tp^.constMember := true;
if tPtr^.flexibleArrayMember then
if kind = structType then
Error(169)
else {if kind = unionType then}
tp^.flexibleArrayMember := true;
end; {if}
if token.kind = commach then {allow repeated declarations}
begin
NextToken;
done := false;
end {if}
else
done := true;
until done or (token.kind = eofsy)
else
Error(116);
Match(semicolonch,22); {insist on a closing ';'}
end; {while}
if fl <> nil then begin
ufl := nil; {reverse the field list}
while fl <> nil do begin
tfl := fl;
fl := fl^.next;
tfl^.next := ufl;
ufl := tfl;
end; {while}
if kind = structType then begin {return the field list}
if bitdisp <> 0 then
disp := disp+((bitDisp+7) div 8);
tp^.size := disp;
end {if}
else
tp^.size := maxDisp;
tp^.fieldList := ufl;
end {if}
else
Error(26); {error if no named declarations}
storageClass := lStorageClass; {restore default storage class}
isForwardDeclared := lisForwardDeclared; {restore the forward flag}
doingParameters := ldoingParameters; {restore the parameters flag}
end; {FieldList}
procedure ResolveType;
{ Resolve a set of type specifier keywords to a type }
begin {ResolveType}
{See C17 6.7.2}
if typeSpecifiers = [voidsy] then
myTypeSpec := voidPtr
else if typeSpecifiers = [charsy] then
myTypeSpec := charPtr
else if typeSpecifiers = [signedsy,charsy] then
myTypeSpec := sCharPtr
else if typeSpecifiers = [unsignedsy,charsy] then
myTypeSpec := uCharPtr
else if (typeSpecifiers = [shortsy])
or (typeSpecifiers = [signedsy,shortsy])
or (typeSpecifiers = [shortsy,intsy])
or (typeSpecifiers = [signedsy,shortsy,intsy]) then
myTypeSpec := shortPtr
else if (typeSpecifiers = [unsignedsy,shortsy])
or (typeSpecifiers = [unsignedsy,shortsy,intsy]) then
myTypeSpec := uShortPtr
else if (typeSpecifiers = [intsy])
or (typeSpecifiers = [signedsy])
or (typeSpecifiers = [signedsy,intsy]) then begin
if unix_1 then
myTypeSpec := int32Ptr
else
myTypeSpec := intPtr;
end {else if}
else if (typeSpecifiers = [unsignedsy])
or (typeSpecifiers = [unsignedsy,intsy]) then begin
if unix_1 then
myTypeSpec := uInt32Ptr
else
myTypeSpec := uIntPtr;
end {else if}
else if (typeSpecifiers = [longsy])
or (typeSpecifiers = [signedsy,longsy])
or (typeSpecifiers = [longsy,intsy])
or (typeSpecifiers = [signedsy,longsy,intsy]) then begin
if isLongLong then
myTypeSpec := longLongPtr
else
myTypeSpec := longPtr;
end {else if}
else if (typeSpecifiers = [unsignedsy,longsy])
or (typeSpecifiers = [unsignedsy,longsy,intsy]) then begin
if isLongLong then
myTypeSpec := uLongLongPtr
else
myTypeSpec := uLongPtr;
end {else if}
else if typeSpecifiers = [floatsy] then
myTypeSpec := floatPtr
else if typeSpecifiers = [doublesy] then
myTypeSpec := doublePtr
else if (typeSpecifiers = [longsy,doublesy])
or (typeSpecifiers = [extendedsy]) then
myTypeSpec := extendedPtr
else if typeSpecifiers = [compsy] then
myTypeSpec := compPtr
else if typeSpecifiers = [_Boolsy] then begin
myTypeSpec := boolPtr;
end {else if}
else
UnexpectedTokenError(expectedNext);
end; {ResolveType}
begin {DeclarationSpecifiers}
myTypeSpec := nil;
myIsForwardDeclared := false; {not doing a forward reference (yet)}
mySkipDeclarator := false; {declarations are required (so far)}
myDeclarationModifiers := [];
typeQualifiers := [];
typeSpecifiers := [];
typeDone := false;
isLongLong := false;
while token.kind in allowedTokens do begin
case token.kind of
{storage class specifiers}
autosy,externsy,registersy,staticsy,typedefsy: begin
myDeclarationModifiers := myDeclarationModifiers + [token.kind];
if storageClass <> ident then begin
if typeDone or (typeSpecifiers <> []) then
UnexpectedTokenError(expectedNext)
else
Error(26);
end; {if}
storageClass := token.kind;
if not doingFunction then
if token.kind = autosy then
Error(62);
if doingParameters then begin
if token.kind <> registersy then
Error(87);
end {if}
else if storageClass in [staticsy,typedefsy] then begin
{Error if we may have allocated type info in local pool.}
{This should not come up with current use of MM pools. }
if not useGlobalPool then
if typeDone then
Error(57);
useGlobalPool := true;
end; {else if}
if doingForLoopClause1 then
if not (storageClass in [autosy,registersy]) then
Error(127);
NextToken;
end;
_Thread_localsy: begin
myDeclarationModifiers := myDeclarationModifiers + [token.kind];
Error(139);
NextToken;
end;
{function specifiers}
inlinesy,_Noreturnsy,asmsy,pascalsy: begin
myDeclarationModifiers := myDeclarationModifiers + [token.kind];
NextToken;
end;
{type qualifiers}
constsy: begin
myDeclarationModifiers := myDeclarationModifiers + [token.kind];
typeQualifiers := typeQualifiers + [tqConst];
NextToken;
end;
volatilesy: begin
myDeclarationModifiers := myDeclarationModifiers + [token.kind];
typeQualifiers := typeQualifiers + [tqVolatile];
volatile := true;
NextToken;
end;
restrictsy: begin
myDeclarationModifiers := myDeclarationModifiers + [token.kind];
typeQualifiers := typeQualifiers + [tqRestrict];
if typeDone or (typeSpecifiers <> []) then
if (myTypeSpec^.kind <> pointerType)
or (myTypeSpec^.pType^.kind = functionType) then
Error(143);
NextToken;
end;
_Atomicsy: begin
myDeclarationModifiers := myDeclarationModifiers + [token.kind];
Error(137);
NextToken;
if token.kind = lparench then begin
{_Atomic(typename) as type specifier}
if typeDone or (typeSpecifiers <> []) then
UnexpectedTokenError(expectedNext);
NextToken;
TypeName;
myTypeSpec := typeSpec;
Match(rparench, 12);
end; {if}
typeDone := true;
end;
{type specifiers}
unsignedsy,signedsy,intsy,longsy,charsy,shortsy,floatsy,doublesy,voidsy,
compsy,extendedsy,_Boolsy: begin
if typeDone then
UnexpectedTokenError(expectedNext)
else if token.kind in typeSpecifiers then begin
if (token.kind = longsy) and
((myTypeSpec = longPtr) or (myTypeSpec = uLongPtr)) then begin
isLongLong := true;
ResolveType;
end
else
UnexpectedTokenError(expectedNext);
end {if}
else begin
if restrictsy in myDeclarationModifiers then begin
myDeclarationModifiers := myDeclarationModifiers - [restrictsy];
Error(143);
end; {if}
typeSpecifiers := typeSpecifiers + [token.kind];
ResolveType;
end; {else}
NextToken;
end;
_Complexsy,_Imaginarysy: begin
Error(136);
NextToken;
end;
enumsy: begin {enum}
if typeDone or (typeSpecifiers <> []) then
UnexpectedTokenError(expectedNext)
else if restrictsy in myDeclarationModifiers then
Error(143);
NextToken; {skip the 'enum' token}
if token.kind = ident then begin {handle a type definition}
variable := FindSymbol(token, tagSpace, true, true);
ttoken := token;
NextToken;
if variable <> nil then
if variable^.itype^.kind = enumType then
if token.kind <> lbracech then
goto 1;
tPtr := pointer(Malloc(sizeof(typeRecord)));
tPtr^.size := cgWordSize;
tPtr^.saveDisp := 0;
tPtr^.qualifiers := [];
tPtr^.kind := enumType;
variable :=
NewSymbol(ttoken.name, tPtr, storageClass, tagSpace, defined);
end {if}
else if token.kind <> lbracech then
Error(9);
enumVal := 0; {set the default value}
if token.kind = lbracech then begin
NextToken; {skip the '{'}
repeat {declare the enum constants}
tPtr := pointer(Malloc(sizeof(typeRecord)));
tPtr^.size := cgWordSize;
tPtr^.saveDisp := 0;
tPtr^.qualifiers := [];
tPtr^.kind := enumConst;
if token.kind = ident then begin
variable :=
NewSymbol(token.name, tPtr, ident, variableSpace, defined);
NextToken;
end {if}
else
Error(9);
if token.kind = eqch then begin {handle explicit enumeration values}
NextToken;
Expression(arrayExpression,[commach,rbracech]);
enumVal := long(expressionValue).lsw;
if enumVal <> expressionValue then
Error(6)
else if enumVal < 0 then
if expressionType^.kind = scalarType then
if expressionType^.baseType in [cgULong,cgUQuad] then
Error(6);
end; {if}
tPtr^.eval := enumVal; {set the enumeration constant value}
enumVal := enumVal+1; {inc the default enumeration value}
if token.kind = commach then {next enumeration...}
begin
done := false;
NextToken;
{kws -- allow trailing , in enum }
{ C99 6.7.2.2 Enumeration specifiers }
if token.kind = rbracech then done := true;
end {if}
else
done := true;
until done or (token.kind = eofsy);
if token.kind = rbracech then
NextToken
else begin
Error(23);
SkipStatement;
end; {else}
end; {if}
1: mySkipDeclarator := token.kind = semicolonch;
myTypeSpec := intPtr;
typeDone := true;
end;
structsy, {struct}
unionsy: begin {union}
if typeDone or (typeSpecifiers <> []) then
UnexpectedTokenError(expectedNext)
else if restrictsy in myDeclarationModifiers then
Error(143);
globalStruct := false; {we didn't make it global}
if token.kind = structsy then {set the type kind to use}
tKind := structType
else
tKind := unionType;
structPtr := nil; {no record, yet}
structTypePtr := defaultStruct; {use int as a default type}
NextToken; {skip 'struct' or 'union'}
if token.kind in [ident,typedef] {if there is a struct name then...}
then begin
{look up the name}
structPtr := FindSymbol(token, tagSpace, true, true);
ttoken := token; {record the structure name}
NextToken; {skip the structure name}
if structPtr = nil then begin {if the name hasn't been defined then...}
if token.kind <> lbracech then
structPtr := FindSymbol(ttoken, tagSpace, false, true);
if structPtr <> nil then
structTypePtr := structPtr^.itype
else begin
myIsForwardDeclared := true;
globalStruct := doingParameters and (token.kind <> lbracech);
if globalStruct then begin
lUseGlobalPool := useGlobalPool;
useGlobalPool := true;
end; {if}
structTypePtr := pointer(Calloc(sizeof(typeRecord)));
{structTypePtr^.size := 0;}
{structTypePtr^.saveDisp := 0;}
{structTypePtr^.qualifiers := [];}
structTypePtr^.kind := tkind;
{structTypePtr^.fieldList := nil;}
{structTypePtr^.sName := nil;}
{structTypePtr^.constMember := false;}
{structTypePtr^.flexibleArrayMember := false;}
structPtr := NewSymbol(ttoken.name, structTypePtr, ident,
tagSpace, defined);
structTypePtr^.sName := structPtr^.name;
end;
end {if}
{the name has been defined, so...}
else if structPtr^.itype^.kind <> tKind then begin
Error(42); {it's an error if it's not a struct}
structPtr := nil;
end {else}
else begin {record the existing structure type}
structTypePtr := structPtr^.itype;
end; {else}
end {if}
else if token.kind <> lbracech then
Error(9); {its an error if there's no name or struct}
2: if token.kind = lbracech then {handle a structure definition...}
begin {error if we already have one!}
if (structTypePtr <> defaultStruct)
and (structTypePtr^.fieldList <> nil) then begin
Error(53);
structPtr := nil;
end; {if}
NextToken; {skip the '{'}
if structTypePtr = defaultStruct then begin
structTypePtr := pointer(Calloc(sizeof(typeRecord)));
{structTypePtr^.size := 0;}
{structTypePtr^.saveDisp := 0;}
{structTypePtr^.qualifiers := [];}
structTypePtr^.kind := tkind;
{structTypePtr^.fieldList := nil;}
{structTypePtr^.sName := nil;}
{structTypePtr^.constMember := false;}
{structTypePtr^.flexibleArrayMember := false;}
end; {if}
if structPtr <> nil then
structPtr^.itype := structTypePtr;
FieldList(structTypePtr,tKind); {define the fields}
if token.kind = rbracech then {insist on a closing rbrace}
NextToken
else begin
Error(23);
SkipStatement;
end; {else}
end; {if}
if globalStruct then
useGlobalPool := lUseGlobalPool;
myTypeSpec := structTypePtr;
mySkipDeclarator := token.kind = semicolonch;
typeDone := true;
end;
typedef: begin {named type definition}
if (typeSpecifiers = []) and not typeDone then begin
myTypeSpec := token.symbolPtr^.itype;
if restrictsy in myDeclarationModifiers then
if (myTypeSpec^.kind <> pointerType)
or (myTypeSpec^.pType^.kind = functionType) then
Error(143);
NextToken;
typeDone := true;
end {if}
else {interpret as declarator, not type specifier}
goto 3;
end;
{alignment specifier}
_Alignassy: begin
myDeclarationModifiers := myDeclarationModifiers + [token.kind];
NextToken;
Match(lparench, 13);
if token.kind in specifierQualifierListElement then begin
TypeName;
with typeSpec^ do
if (size = 0) or ((kind = arrayType) and (elements = 0)) then
Error(133);
end {if}
else begin
Expression(arrayExpression, [rparench]);
if (expressionValue <> 0) and (expressionValue <> 1) then
Error(138);
end;
Match(rparench, 12);
end;
otherwise: begin
Error(57);
NextToken;
end;
end; {case}
end; {while}
3:
isForwardDeclared := myIsForwardDeclared;
skipDeclarator := mySkipDeclarator;
declarationModifiers := myDeclarationModifiers;
if myTypeSpec = nil then begin
myTypeSpec := intPtr; {under C89, default type is int}
if (lint & lintC99Syntax) <> 0 then
Error(151);
end; {if}
typeSpec := MakeQualifiedType(myTypeSpec, typeQualifiers); {apply type qualifiers}
end; {DeclarationSpecifiers}
{-- Externally available subroutines ---------------------------}
procedure DoDeclaration {doingPrototypes: boolean};
{ process a variable or function declaration }
{ }
{ parameters: }
{ doingPrototypes - are we processing a parameter list? }
label 1,2,3,4;
var
done: boolean; {for loop termination}
fName: stringPtr; {for forming uppercase names}
i: integer; {loop variable}
isAsm: boolean; {has the asm modifier been used?}
isInline: boolean; {has the inline specifier been used?}
isNoreturn: boolean; {has the _Noreturn specifier been used?}
alignmentSpecified: boolean; {was an alignment explicitly specified?}
lDoingParameters: boolean; {local copy of doingParameters}
lisPascal: boolean; {local copy of isPascal}
lp,tlp,tlp2: identPtr; {for tracing parameter list}
ltypeSpec: typePtr; {copy of type specifier}
lUseGlobalPool: boolean; {local copy of useGlobalPool}
nextPdisp: integer; {for calculating parameter disps}
noFDefinitions: boolean; {are function definitions inhibited?}
p1,p2,p3: parameterPtr; {for reversing prototyped parameters}
variable: identPtr; {pointer to the variable being declared}
fnType: typePtr; {function type}
segType: integer; {segment type}
tp: typePtr; {for tracing type lists}
tk: tokenType; {work token}
typeFound: boolean; {has some type specifier been found?}
startLine: integer; {line where this declaration starts}
procedure CheckArray (v: identPtr; firstVariable: boolean);
{ make sure all required array sizes are specified }
{ }
{ parameters: }
{ v - pointer to the identifier to check }
{ firstVariable - can the first array subscript be of a }
{ non-fixed size? }
label 1;
var
tp: typePtr; {work pointer}
begin {CheckArray}
if v <> nil then begin {skip check if there's no variable}
tp := v^.itype; {initialize the type pointer}
while tp <> nil do begin {check all types}
if tp^.kind = arrayType then {if it's an array with an unspecified }
begin
if tp^.elements = 0 then { size and an unspecified size is not }
if not firstVariable then { allowed here, flag an error. }
begin
Error(49);
goto 1;
end; {if}
if tp^.aType^.size = 0 then begin
Error(123);
goto 1;
end; {if}
if tp^.aType^.kind in [structType,unionType] then
if tp^.aType^.flexibleArrayMember then
Error(169);
end; {if}
firstVariable := false; {unspecified sizes are only allowed in }
{ the first subscript }
case tp^.kind of {next type...}
arrayType:
tp := tp^.aType;
pointerType: begin
tp := tp^.pType;
firstVariable := true; {(also allowed for pointers to arrays)}
end;
functionType:
tp := tp^.fType;
otherwise:
tp := nil;
end; {case}
end; {while}
end; {if}
1:
end; {CheckArray}
procedure SegmentStatement;
{ compile a segment statement }
{ }
{ statement syntax: }
{ }
{ 'segment' string-constant [',' 'dynamic'] }
var
i: integer; {loop variable}
len: integer; {segment name length}
begin {SegmentStatement}
NextToken;
if token.kind = stringConst then begin
for i := 1 to 10 do begin
defaultSegment[i] := chr(0);
currentSegment[i] := chr(0);
end; {for}
len := token.sval^.length;
if len > 10 then
len := 10;
for i := 1 to len do
defaultSegment[i] := token.sval^.str[i];
for i := 1 to len do
currentSegment[i] := token.sval^.str[i];
FlagPragmas(p_segment);
NextToken;
if token.kind = commach then begin
NextToken;
if token.kind = ident then begin
if token.name^ = 'dynamic' then
segmentKind := $8000
else Error(84);
NextToken;
end {if}
else Error(84);
end {if}
else
segmentKind := 0;
Match(semicolonch,22);
end {if}
else begin
Error(83);
SkipStatement;
end; {else}
end; {SegmentStatement}
function InPartialList (fName: stringPtr): boolean;
{ See if the function is in the partial compile list. }
{ }
{ If the function is in the list, the function name is }
{ removed from the list, and true is returned. If not, }
{ false is returned. }
{ }
{ parameters: }
{ fName - name of the function to check for }
label 1,2;
var
ch: char; {work character}
i,j: integer; {loop variable}
len: integer; {length of fName}
begin {InPartialList}
i := partialFileGS.theString.size; {strip trailing blanks}
while (i > 0) and (partialFileGS.theString.theString[i] = ' ') do begin
partialFileGS.theString.theString[i] := chr(0);
i := i-1;
end; {while}
while partialFileGS.theString.theString[1] = ' ' do {skip leading blanks}
for i := 1 to partialFileGS.theString.size do
partialFileGS.theString.theString[i] :=
partialFileGS.theString.theString[i+1];
InPartialList := true; {assume success}
i := 1; {scan the name list}
len := length(fName^);
while partialFileGS.theString.theString[i] <> chr(0) do begin
for j := 1 to len do begin
if partialFileGS.theString.theString[i+j-1] <> fName^[j] then
goto 1;
end; {for}
if partialFileGS.theString.theString[i+len] in [' ', chr(0)] then begin
{found a match - remove from list & return}
j := i+len;
while partialFileGS.theString.theString[j] = ' ' do
j := j+1;
repeat
ch := partialFileGS.theString.theString[j];
partialFileGS.theString.theString[i] := ch;
i := i+1;
j := j+1;
until ch = chr(0);
goto 2;
end; {if}
1: {no match - skip to next name}
while not (partialFileGS.theString.theString[i] in [chr(0), ' ']) do
i := i+1;
while partialFileGS.theString.theString[i] = ' ' do
i := i+1;
end; {while}
InPartialList := false; {no match found}
2:
end; {InPartialList}
procedure SkipFunction (isAsm: boolean);
{ Skip a function body for a partial compile }
{ }
{ Parameters: }
{ isAsm - are we compiling an asm function? }
var
braceCount: integer; {# of unmatched { chars}
doingAsm: boolean; {compiling an asm statement?}
begin {SkipFunction}
Match(lbracech,27); {skip to the closing rbrackch}
braceCount := 1;
doingAsm := false;
if isAsm then
charKinds[ord('#')] := ch_pound;
while (not (token.kind = eofsy)) and (braceCount <> 0) do begin
if token.kind = asmsy then begin
doingAsm := true;
charKinds[ord('#')] := ch_pound;
end {if}
else if token.kind = lbracech then
braceCount := braceCount+1
else if token.kind = rbracech then begin
braceCount := braceCount-1;
if doingAsm then begin
doingAsm := false;
charKinds[ord('#')] := illegal;
end; {if}
end; {else if}
NextToken;
end; {while}
nameFound := false; {no pc_nam for the next function (yet)}
doingFunction := false; {no longer doing a function}
charKinds[ord('#')] := illegal; {# is a preprocessor command}
end; {SkipFunction}
begin {DoDeclaration}
if token.kind = _Static_assertsy then begin
DoStaticAssert;
goto 4;
end; {if}
lDoingParameters := doingParameters; {record the status}
noFDefinitions := false; {are function definitions inhibited?}
if doingPrototypes then {prototypes implies a parm list}
doingParameters := true
else
lastParameter := nil; {init parm list if we're not doing prototypes}
isFunction := false; {assume it's not a function}
startLine := lineNumber;
if not doingFunction then {handle any segment statements}
while token.kind = segmentsy do
SegmentStatement;
inhibitHeader := true; {block imbedded includes in headers}
lUseGlobalPool := useGlobalPool;
storageClass := ident;
{handle a TypeSpecifier/declarator}
typeFound := token.kind in declarationSpecifiersElement;
DeclarationSpecifiers(declarationSpecifiersElement, ident);
isPascal := pascalsy in declarationModifiers;
isAsm := asmsy in declarationModifiers;
isInline := inlinesy in declarationModifiers;
isNoreturn := _Noreturnsy in declarationModifiers;
alignmentSpecified := _Alignassy in declarationModifiers;
lisPascal := isPascal;
if not skipDeclarator then begin
variable := nil;
Declarator(typeSpec, variable, variableSpace, doingPrototypes);
if variable = nil then begin
inhibitHeader := false;
if token.kind = semicolonch then
NextToken
else begin
Error(22);
SkipStatement;
end; {else}
goto 1;
end; {if}
end; {if}
isPascal := lisPascal;
{make sure variables have some type info}
if isFunction then begin
if not typeFound then
if (lint & lintNoFnType) <> 0 then
if (lint & lintC99Syntax) = 0 then
Error(104);
end {if}
else
if not typeFound then
Error(26);
3:
{handle a function declaration}
if isFunction then begin
if doingParameters then {a function cannot be a parameter}
Error(28);
fnType := variable^.itype; {get the type of the function}
while (fnType <> nil) and (fnType^.kind <> functionType) do
case fnType^.kind of
arrayType : fnType := fnType^.aType;
pointerType: fnType := fnType^.pType;
definedType: fnType := fnType^.dType;
otherwise : fnType := nil;
end; {case}
if fnType = nil then begin
SkipStatement;
goto 1;
end; {if}
if isInline then
if storageClass <> staticsy then
Error(120);
if alignmentSpecified then
Error(142);
if isPascal then begin {reverse prototyped parameters}
p1 := fnType^.parameterList;
if p1 <> nil then begin
p2 := nil;
while p1 <> nil do begin
p3 := p1;
p1 := p1^.next;
p3^.next := p2;
p2 := p3;
end; {while}
fnType^.parameterList := p2;
end; {if}
end; {if}
{handle functions in the parameter list}
if doingPrototypes then
PopTable
{external or forward declaration}
else if token.kind in [commach,semicolonch,inlinesy] then begin
fnType^.isPascal := isPascal; {note if we have pascal parms}
if token.kind = inlinesy then {handle tool declarations}
with fnType^ do begin
NextToken;
Match(lparench,13);
if token.kind in
[intconst,uintconst,ushortconst,charconst,scharconst,ucharconst]
then begin
toolNum := token.ival;
NextToken;
end {if}
else
Error(18);
Match(commach,86);
if token.kind in [longconst,ulongconst] then begin
dispatcher := token.lval;
NextToken;
end {if}
else if token.kind in
[intconst,uintconst,ushortconst,charconst,scharconst,ucharconst]
then begin
dispatcher := token.ival;
NextToken;
end {if}
else
Error(18);
Match(rparench,12);
end; {with}
doingParameters := doingPrototypes; {not doing parms any more}
if token.kind = semicolonch then begin
inhibitHeader := false;
NextToken; {skip the trailing semicolon}
end {if}
else if (token.kind = commach) and (not doingPrototypes) then begin
PopTable; {pop the symbol table}
NextToken; {allow further declarations}
variable := nil;
isFunction := false;
Declarator (typeSpec, variable, variableSpace, doingPrototypes);
if variable = nil then begin
inhibitHeader := false;
if token.kind = semicolonch then
NextToken
else begin
Error(22);
SkipStatement;
end; {else}
goto 1;
end; {if}
goto 3;
end {else if}
else begin
Error(22);
SkipStatement;
end; {else}
PopTable; {pop the symbol table}
end {if}
{cannot imbed functions...}
else if doingFunction then begin
isPascal := false;
Error(28);
while token.kind <> eofsy do
NextToken;
end {if}
{local declaration}
else begin
if noFDefinitions then
Error(22);
ftype := fnType^.ftype; {record the type of the function}
while fType^.kind = definedType do
fType := fType^.dType;
fIsNoreturn := isNoreturn; {record if function is _Noreturn}
variable^.state := defined; {note that the function is defined}
pfunc := variable; {set the identifier for parm checks}
fnType^.isPascal := isPascal; {note if we have pascal parms}
doingFunction := true; {read the parameter list}
doingParameters := true;
{declare the parameters}
lp := lastParameter; {(save now; it's volatile)}
while not (token.kind in [lbracech,eofsy]) do
if token.kind in declarationSpecifiersElement then
DoDeclaration(false)
else begin
Error(27);
NextToken;
end; {else}
if numberOfParameters <> 0 then {default K&R parm type is int}
begin
tlp := lp;
while tlp <> nil do begin
if tlp^.itype = nil then begin
tlp^.itype := intPtr;
if (lint & lintC99Syntax) <> 0 then
if (lint & lintNotPrototyped) = 0 then
Error(147); {C99+ require K&R params to be declared}
end; {if}
tlp := tlp^.pnext;
end; {while}
end; {if}
tlp := lp; {make sure all parameters have an}
while tlp <> nil do begin { identifier and a complete type }
if tlp^.name^ = '?' then begin
Error(113);
tlp := nil;
end {if}
else begin
if tlp^.itype^.size = 0 then
if not (tlp^.itype^.kind in [arrayType,functionType]) then
Error(148);
tlp := tlp^.pnext;
end; {else}
end; {while}
doingParameters := false;
fName := variable^.name; {skip if this is not needed for a }
if doingPartial then { partial compile }
if not InPartialList(fName) then begin
SkipFunction(isAsm);
goto 2;
end; {if}
TermHeader; {make sure the header file is closed}
if progress then {write progress information}
writeln('Compiling ', fName^);
useGlobalPool := false; {start a local label pool}
if not codegenStarted and (liDCBGS.kFlag <> 0) then begin {init the code generator (if it needs it)}
CodeGenInit (outFileGS, liDCBGS.kFlag, doingPartial);
liDCBGS.kFlag := 3;
codegenStarted := true;
end; {if}
foundFunction := true; {got one...}
segType := ord(variable^.class = staticsy) * $4000;
if fnType^.isPascal then begin
fName := pointer(Malloc(length(variable^.name^)+1));
CopyString(pointer(fName), pointer(variable^.name));
for i := 1 to length(fName^) do
if fName^[i] in ['a'..'z'] then
fName^[i] := chr(ord(fName^[i]) & $5F);
Gen2Name (dc_str, segType, 0, fName);
end {if}
else
Gen2Name (dc_str, segType, 0, variable^.name);
doingMain := variable^.name^ = 'main';
hasVarargsCall := false;
firstCompoundStatement := true;
Gen0 (dc_pin);
if not isAsm then
Gen1Name(pc_ent, 0, variable^.name);
functionName := variable^.name;
nextLocalLabel := 1; {initialize GetLocalLabel}
returnLabel := GenLabel; {set up an exit point}
tempList := nil; {initialize the work label list}
if not isAsm then {generate traceback, profile code}
if traceBack or profileFlag then begin
if traceBack then
nameFound := true;
GenPS(pc_nam, variable^.name);
end; {if}
nextPdisp := 0; {assign displacements to the parameters}
if not fnType^.isPascal then begin
tlp := lp;
lp := nil;
while tlp <> nil do begin
tlp2 := tlp;
tlp := tlp^.pnext;
tlp2^.pnext := lp;
lp := tlp2;
end; {while}
end; {if}
while lp <> nil do begin
lp^.pdisp := nextPdisp;
if lp^.itype^.kind = arrayType then
nextPdisp := nextPdisp + cgPointerSize
else begin
if lp^.itype^.kind = scalarType then
if lp^.itype^.baseType in [cgReal,cgDouble,cgComp] then
{all floating-points are passed as extended}
lp^.itype := extendedPtr;
nextPdisp := nextPdisp + long(lp^.itype^.size).lsw;
if (long(lp^.itype^.size).lsw = 1)
and (lp^.itype^.kind = scalarType) then
nextPdisp := nextPdisp+1;
end; {else}
lp := lp^.pnext;
end; {while}
gotoList := nil; {initialize the label list}
fenvAccessInFunction := fenvAccess;
if isAsm then begin
AsmFunction(variable); {handle assembly language functions}
PopTable;
end {if}
else begin
{set up struct/union area}
if variable^.itype^.ftype^.kind in [structType,unionType] then begin
lp := NewSymbol(@'@struct', variable^.itype^.ftype, staticsy,
variablespace, declared);
tk.kind := ident;
tk.class := identifier;
tk.name := @'@struct';
tk.symbolPtr := nil;
lp := FindSymbol(tk, variableSpace, false, true);
Gen1Name(pc_lao, 0, lp^.name);
Gen2t(pc_str, 0, 0, cgULong);
end; {if}
{generate parameter labels}
if fnType^.overrideKR then
GenParameters(nil)
else
GenParameters(fnType^.parameterList);
savedVolatile := volatile;
functionTable := table;
if fnType^.varargs then begin {make internal va info for varargs funcs}
lp := NewSymbol(@'__orcac_va_info', vaInfoPtr, autosy,
variableSpace, declared);
lp^.lln := GetLocalLabel;
Gen2(dc_loc, lp^.lln, ord(vaInfoPtr^.size));
Gen2(pc_lda, lastParameterLLN, lastParameterSize);
Gen2t(pc_cop, lp^.lln, 0, cgULong);
Gen2t(pc_str, lp^.lln, cgPointerSize, cgULong);
vaInfoLLN := lp^.lln;
end {if}
else
vaInfoLLN := 0;
CompoundStatement(false); {process the statements}
end; {else}
end; {else}
2: ;
end {if}
{handle a variable declaration}
else {if not isFunction then} begin
noFDefinitions := true;
if alignmentSpecified then
if storageClass in [typedefsy,registersy] then
Error(142);
if not SkipDeclarator then
repeat
if isPascal then begin
tp := variable^.itype;
while tp <> nil do
case tp^.kind of
scalarType,
enumType,
enumConst,
definedType,
structType,
unionType: begin tp := nil; Error(94); end;
arrayType: tp := tp^.atype;
pointerType: tp := tp^.pType;
functionType: begin tp^.isPascal := true; tp := nil; end;
end; {case}
end; {if}
if isInline then
Error(119);
if isNoreturn then
Error(141);
if token.kind = eqch then begin
if storageClass = typedefsy then
Error(52);
if doingPrototypes then
Error(88);
{allocate copy of incomplete array type,}
tp := variable^.itype; {so it can be completed by Initializer}
if (tp^.kind = arrayType) and (tp^.elements = 0) then begin
variable^.itype := pointer(Malloc(sizeof(typeRecord)));
variable^.itype^ := tp^;
variable^.itype^.saveDisp := 0;
end;
NextToken; {handle an initializer}
ltypeSpec := typeSpec;
Initializer(variable);
typeSpec := ltypeSpec;
end; {if}
{check to insure array sizes are specified}
if storageClass <> typedefsy then
CheckArray(variable,
(storageClass = externsy) or doingParameters or not doingFunction);
{allocate space}
if variable^.storage = stackFrame then begin
variable^.lln := GetLocalLabel;
Gen2(dc_loc, variable^.lln, long(variable^.itype^.size).lsw);
if variable^.state = initialized then
AutoInit(variable, startLine); {initialize auto variable}
end; {if}
if (token.kind = commach) and (not doingPrototypes) then begin
done := false; {allow multiple variables on one line}
NextToken;
variable := nil;
Declarator(typeSpec, variable, variableSpace, doingPrototypes);
if variable = nil then begin
if token.kind = semicolonch then
NextToken
else begin
Error(22);
SkipStatement;
end; {else}
goto 1;
end; {if}
goto 3;
end {if}
else
done := true;
until done or (token.kind = eofsy);
if doingPrototypes then begin
protoVariable := variable; {make the var available to Declarator}
if protoVariable = nil then
protoType := typeSpec
else
protoType := protoVariable^.iType;
end {if}
else begin
inhibitHeader := false;
if token.kind = semicolonch then {must end with a semicolon}
NextToken
else begin
Error(22);
SkipStatement;
end; {else}
end; {else}
end; {else}
1:
doingParameters := lDoingParameters; {restore the status}
useGlobalPool := lUseGlobalPool;
inhibitHeader := false;
4:
end; {DoDeclaration}
procedure TypeName;
{ process a type name (used for casts and sizeof/_Alignof) }
{ }
{ outputs: }
{ typeSpec - pointer to the type }
var
tl,tp: typePtr; {for creating/reversing the type list}
procedure AbstractDeclarator;
{ process an abstract declarator }
{ }
{ abstract-declarator: }
{ empty-abstract-declarator }
{ nonempty-abstract-declarator }
procedure NonEmptyAbstractDeclarator;
{ process a nonempty abstract declarator }
{ }
{ nonempty-abstract-declarator: }
{ ( nonempty-abstract-declarator ) }
{ abstract-declarator ( ) }
{ abstract-declarator [ expression OPT ] }
{ * abstract-declarator }
var
pcount: integer; {paren counter}
tp: typePtr; {work pointer}
begin {NonEmptyAbstractDeclarator}
if token.kind = lparench then begin
NextToken;
if token.kind = rparench then begin
{create a function type}
tp := pointer(Calloc(sizeof(typeRecord)));
{tp^.size := 0;}
{tp^.saveDisp := 0;}
{tp^.qualifiers := [];}
tp^.kind := functionType;
{tp^.varargs := false;}
{tp^.prototyped := false;}
{tp^.overrideKR := false;}
{tp^.parameterList := nil;}
{tp^.isPascal := false;}
{tp^.toolNum := 0;}
{tp^.dispatcher := 0;}
tp^.fType := Unqualify(tl);
tl := tp;
NextToken;
end {if}
else begin
{handle a parenthesized type}
if not (token.kind in [lparench,asteriskch,lbrackch]) then
begin
Error(82);
while not (token.kind in
[eofsy,lparench,asteriskch,lbrackch,rparench]) do
NextToken;
end; {if}
if token.kind in [lparench,asteriskch,lbrackch] then
NonEmptyAbstractDeclarator;
Match(rparench,12);
end; {else}
end {if token.kind = lparench}
else if token.kind = asteriskch then begin
{create a pointer type}
NextToken;
tp := pointer(Malloc(sizeof(typeRecord)));
tp^.size := cgLongSize;
tp^.saveDisp := 0;
tp^.qualifiers := [];
tp^.kind := pointerType;
while token.kind in [constsy,volatilesy,restrictsy] do begin
if token.kind = constsy then
tp^.qualifiers := tp^.qualifiers + [tqConst]
else if token.kind = volatilesy then begin
tp^.qualifiers := tp^.qualifiers + [tqVolatile];
volatile := true;
end {else}
else {if token.kind = restrictsy then}
tp^.qualifiers := tp^.qualifiers + [tqRestrict];
NextToken;
end; {while}
AbstractDeclarator;
tp^.fType := tl;
tl := tp;
end {else if token.kind = asteriskch}
else {if token.kind = lbrackch then} begin
{create an array type}
NextToken;
if token.kind = rbrackch then
expressionValue := 0
else begin
Expression(arrayExpression, [rbrackch]);
if expressionValue <= 0 then begin
Error(45);
expressionValue := 1;
end; {if}
end; {else}
tp := pointer(Malloc(sizeof(typeRecord)));
tp^.saveDisp := 0;
tp^.kind := arrayType;
tp^.elements := expressionValue;
tp^.fType := tl;
tl := tp;
Match(rbrackch,24);
end; {else}
if token.kind = lparench then begin
{create a function type}
NextToken;
pcount := 1;
while (token.kind <> eofsy) and (pcount <> 0) do begin
if token.kind = rparench then
pcount := pcount-1
else if token.kind = lparench then
pcount := pcount+1;
NextToken;
end; {while}
tp := pointer(Calloc(sizeof(typeRecord)));
{tp^.size := 0;}
{tp.saveDisp := 0;}
{tp^.qualifiers := [];}
tp^.kind := functionType;
{tp^.varargs := false;}
{tp^.prototyped := false;}
{tp^.overrideKR := false;}
{tp^.parameterList := nil;}
{tp^.isPascal := false;}
{tp^.toolNum := 0;}
{tp^.dispatcher := 0;}
tp^.fType := Unqualify(tl);
tl := tp;
end; {if}
end; {NonEmptyAbstractDeclarator}
begin {AbstractDeclarator}
while token.kind in [lparench,asteriskch,lbrackch] do
NonEmptyAbstractDeclarator;
end; {AbstractDeclarator}
begin {TypeName}
{read and process the type specifier}
DeclarationSpecifiers(specifierQualifierListElement, rparench);
{_Alignas is not allowed in most uses of type names. }
{TODO: _Alignas should be allowed in compound literals. }
if _Alignassy in declarationModifiers then
Error(142);
{handle the abstract-declarator part}
tl := nil; {no types so far}
AbstractDeclarator; {create the type list}
while tl <> nil do begin {reverse the list & compute array sizes}
tp := tl^.aType; {NOTE: assumes aType, pType and fType overlap in typeRecord}
tl^.aType := typeSpec;
if tl^.kind = arrayType then
tl^.size := tl^.elements * typeSpec^.size;
typeSpec := tl;
tl := tp;
end; {while}
end; {TypeName}
procedure DoStatement;
{ process a statement from a function }
var
lToken: tokenType; {temporary copy of old token}
nToken: tokenType; {new token}
hasStatementNext: boolean; {is a stmt next within a compound stmt?}
lPrintMacroExpansions: boolean; {local copy of printMacroExpansions}
begin {DoStatement}
case statementList^.kind of
compoundSt: begin
hasStatementNext := true;
if token.kind = rbracech then begin
hasStatementNext := false;
EndCompoundStatement;
end {if}
else if (statementList^.doingDeclaration or allowMixedDeclarations)
and (token.kind in localDeclarationStart)
then begin
hasStatementNext := false;
if token.kind <> typedef then
DoDeclaration(false)
else begin
lToken := token;
lPrintMacroExpansions := printMacroExpansions; {inhibit token echo}
printMacroExpansions := false;
NextToken;
printMacroExpansions := lPrintMacroExpansions;
nToken := token;
PutBackToken(nToken, false);
token := lToken;
if nToken.kind <> colonch then
DoDeclaration(false)
else
hasStatementNext := true;
end {else}
end; {else if}
if hasStatementNext then begin
if statementList^.doingDeclaration then begin
statementList^.doingDeclaration := false;
if firstCompoundStatement then begin
Gen1Name(dc_sym, ord(doingMain), pointer(table));
firstCompoundStatement := false;
end; {if}
end; {if}
Statement;
end; {else}
end;
ifSt:
EndIfStatement;
elseSt:
EndElseStatement;
doSt:
EndDoStatement;
whileSt:
EndWhileStatement;
forSt:
EndForStatement;
switchSt:
EndSwitchStatement;
otherwise: Error(57);
end; {case}
end; {DoStatement}
procedure AutoInit {variable: identPtr, line: integer};
{ generate code to initialize an auto variable }
{ }
{ parameters: }
{ variable - the variable to initialize }
{ line - line number (used for debugging) }
var
count: integer; {initializer counter}
iPtr: initializerPtr; {pointer to the next initializer}
procedure Initialize (id: identPtr; disp: longint; itype: typePtr);
{ initialize a variable }
{ }
{ parameters: }
{ id - pointer to the identifier }
{ disp - disp past the identifier to initialize }
{ itype - type of the variable to initialize }
{ }
{ variables: }
{ count - number of times to re-use the initializer }
{ ip - pointer to the initializer record to use }
label 1,2;
var
elements: longint; {# array elements}
fp: identPtr; {for tracing field lists}
size: integer; {fill size}
union: boolean; {are we doing a union?}
startDisp,endDisp: longint; {disp at start/end of struct/union}
{bit field manipulation}
{----------------------}
bitcount: integer; {# if bits so far}
bitsize,bitdisp: integer; {defines size, location of a bit field}
{assignment conversion}
{---------------------}
tree: tokenPtr; {expression tree}
val: longint; {constant expression value}
isConstant: boolean; {is the expression a constant?}
procedure LoadAddress;
{ Load the address of the operand }
begin {LoadAddress}
if id^.storage = stackFrame then
Gen2(pc_lda, id^.lln, ord(disp))
else
Error(57);
end; {LoadAddress}
function ZeroFill (elements: longint; itype: typePtr;
count: integer; iPtr: initializerPtr): boolean;
{ See if an array can be zero filled }
{ }
{ parameters: }
{ elements - elements in the array }
{ itype - type of each array element }
{ count - remaining initializer repetitions }
{ iPtr - initializer record }
begin {ZeroFill}
ZeroFill := false;
if not iPtr^.isConstant then
if itype^.kind in [scalarType,enumType] then
if count >= elements then
with iPtr^.itree^ do
if token.kind = intconst then
if token.ival = 0 then
{don't call ~ZERO for very small arrays}
if elements * itype^.size > 10 then
ZeroFill := true;
end; {ZeroFill}
begin {Initialize}
while itype^.kind = definedType do
itype := itype^.dType;
case itype^.kind of
scalarType,pointerType,enumType,functionType: begin
tree := iptr^.itree;
if tree = nil then goto 2; {don't generate code in error case}
LoadAddress; {load the destination address}
doDispose := count = 1; {generate the expression value}
{see if this is a constant}
{do assignment conversions}
while tree^.token.kind = castoper do
tree := tree^.left;
isConstant :=
tree^.token.class in [intConstant,longConstant,longlongConstant];
if isConstant then
if tree^.token.class = intConstant then
val := tree^.token.ival
else if tree^.token.class = longConstant then
val := tree^.token.lval
else {if tree^.token.class = longlongConstant then} begin
if (tree^.token.qval.hi = 0) and (tree^.token.qval.lo >= 0) then
val := tree^.token.qval.lo
else
isConstant := false;
end; {else}
{ if isConstant then
if tree^.token.class = intConstant then
Writeln('loc 2: bitsize = ', iPtr^.bitsize:1, '; ival = ', tree^.token.ival:1) {debug}
{ else
Writeln('loc 2: bitsize = ', iPtr^.bitsize:1, '; lval = ', tree^.token.lval:1) {debug}
{ else
Writeln('loc 2: bitsize = ', iPtr^.bitsize:1); {debug}
GenerateCode(iptr^.iTree);
AssignmentConversion(itype, expressionType, isConstant, val, true,
false);
case itype^.kind of {save the value}
scalarType:
if iptr^.bitsize <> 0 then
Gen2t(pc_sbf, iptr^.bitdisp, iptr^.bitsize, itype^.basetype)
else
Gen0t(pc_sto, itype^.baseType);
enumType:
Gen0t(pc_sto, cgWord);
pointerType,functionType:
Gen0t(pc_sto, cgULong);
end; {case}
2: end;
arrayType: begin
elements := itype^.elements;
if elements = 0 then goto 1; {don't init flexible array member}
if itype^.aType^.kind = scalarType then
if iPtr^.iTree^.token.kind = stringConst then begin
elements := elements * itype^.aType^.size;
size := iPtr^.iTree^.token.sval^.length;
if size >= elements then
size := ord(elements)
else
size := size-1;
if size <> 0 then begin
GenLdcLong(size);
Gen0t(pc_stk, cgULong);
GenS(pc_lca, iPtr^.iTree^.token.sval);
Gen0t(pc_stk, cgULong);
Gen0t(pc_bno, cgULong);
LoadAddress;
Gen0t(pc_stk, cgULong);
Gen0t(pc_bno, cgULong);
Gen1tName(pc_cup, 0, cgVoid, @'memcpy');
end; {if}
if size < elements then begin
elements := elements - size;
disp := disp + size;
LoadAddress;
Gen0t(pc_stk, cgULong);
Gen1t(pc_ldc, ord(elements), cgWord);
Gen0t(pc_stk, cgWord);
Gen0t(pc_bno, cgULong);
Gen1tName(pc_cup, -1, cgVoid, @'~ZERO');
end; {if}
iPtr := iPtr^.next;
goto 1;
end; {if}
itype := itype^.atype;
if ZeroFill(elements, itype, count, iPtr) then begin
if itype^.kind = enumType then
size := cgWordSize
else
size := TypeSize(itype^.baseType);
size := size * long(elements).lsw;
LoadAddress;
Gen0t(pc_stk, cgULong);
Gen1t(pc_ldc, size, cgWord);
Gen0t(pc_stk, cgWord);
Gen0t(pc_bno, cgULong);
Gen1tName(pc_cup, -1, cgVoid, @'~ZERO');
disp := disp + size;
count := count - long(elements).lsw;
if count = 0 then begin
iPtr := iPtr^.next;
if iPtr <> nil then
count := iPtr^.count;
end; {if}
end {if}
else begin
while elements <> 0 do begin
Initialize(id, disp, itype);
if itype^.kind in [scalarType,pointerType,enumType] then begin
count := count-1;
if count = 0 then begin
iPtr := iPtr^.next;
if iPtr <> nil then
count := iPtr^.count;
end; {if}
end; {if}
disp := disp+itype^.size;
elements := elements-1;
end; {while}
end; {else}
1: end;
structType,unionType: begin
startDisp := disp;
endDisp := disp + itype^.size;
if iPtr^.isStructOrUnion then begin
LoadAddress; {load the destination address}
GenerateCode(iptr^.iTree); {load the struct address}
{do the assignment}
AssignmentConversion(itype, expressionType, isConstant, val,
true, false);
with expressionType^ do
Gen2(pc_mov, long(size).msw, long(size).lsw);
Gen0t(pc_pop, UsualUnaryConversions);
end {if}
else begin
union := itype^.kind = unionType;
fp := itype^.fieldList;
while fp <> nil do begin
itype := fp^.itype;
disp := startDisp + fp^.disp;
bitdisp := fp^.bitdisp;
bitsize := fp^.bitsize;
{ writeln('Initialize: disp = ', disp:3, '; fp^. Disp = ', fp^.disp:3, 'itype^.size = ', itype^.size:1); {debug}
{ writeln(' bitDisp = ', bitDisp:3, '; fp^.bitDisp = ', fp^.bitDisp:3); {debug}
{ writeln(' bitSize = ', bitSize:3, '; fp^.bitSize = ', fp^.bitSize:3); {debug}
Initialize(id, disp, itype);
if bitsize = 0 then begin
if bitcount <> 0 then begin
bitcount := 0;
end {if}
else if fp^.bitSize <> 0 then begin
bitcount := 8;
while (fp <> nil) and (bitcount > 0) do begin
bitcount := bitcount - fp^.bitSize;
if bitcount > 0 then
if fp^.next <> nil then
if fp^.next^.bitSize <> 0 then
fp := fp^.next
else
bitcount := 0;
end; {while}
bitcount := 0;
end; {else if}
end {if}
else if fp^.bitSize = 0 then begin
bitsize := 0;
end {else if}
else begin
bitcount := bitsize + bitdisp;
end; {else}
if itype^.kind in [scalarType,pointerType,enumType] then begin
count := count-1;
if count = 0 then begin
iPtr := iPtr^.next;
if iPtr <> nil then begin
count := iPtr^.count;
bitsize := iPtr^.bitsize;
bitdisp := iPtr^.bitdisp;
end; {if}
end; {if}
end; {if}
if union then
fp := nil
else
fp := fp^.next;
end; {while}
end; {else}
disp := endDisp;
end;
otherwise: Error(57);
end; {case}
end; {Initialize}
begin {AutoInit}
iPtr := variable^.iPtr;
count := iPtr^.count;
if variable^.class <> staticsy then begin
if traceBack or debugFlag then
if nameFound or debugFlag then
if (statementList <> nil) and not statementList^.doingDeclaration then
if lastLine <> line then begin
lastLine := line;
Gen2(pc_lnm, line, ord(debugType));
end; {if}
Initialize(variable, 0, variable^.itype);
end; {if}
end; {AutoInit}
function MakeFuncIdentifier{: identPtr};
{ 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. }
var
lTable: symbolTablePtr; {saved copy of current symbol table}
tp: typePtr; {the type of __func__}
id: identPtr; {the identifier for __func__}
sval: longstringPtr; {the initializer string}
iPtr: initializerPtr; {the initializer}
i: integer; {loop variable}
len: integer; {string length}
begin {MakeFuncIdentifier}
lTable := table;
table := functionTable;
len := ord(functionName^[0]) + 1;
tp := pointer(GCalloc(sizeof(typeRecord)));
tp^.size := len;
tp^.saveDisp := 0;
tp^.qualifiers := [];
tp^.kind := arrayType;
tp^.aType := constCharPtr;
tp^.elements := len;
id := NewSymbol(@'__func__', tp, staticsy, variableSpace, initialized);
sval := pointer(GCalloc(len + sizeof(integer)));
sval^.length := len;
for i := 1 to len-1 do
sval^.str[i] := functionName^[i];
sval^.str[len] := chr(0);
iPtr := pointer(GCalloc(sizeof(initializerRecord)));
iPtr^.next := nil;
iPtr^.count := 1;
iPtr^.bitdisp := 0;
iPtr^.bitsize := 0;
iPtr^.isStructOrUnion := false;
iPtr^.isConstant := true;
iPtr^.itype := cgString;
iPtr^.sval := sval;
id^.iPtr := iPtr;
table := lTable;
MakeFuncIdentifier := id;
end; {MakeFuncIdentifier}
function MakeCompoundLiteral{tp: typePtr): identPtr};
{ Make the identifier for a compound literal. }
{ }
{ parameters: }
{ tp - the type of the compound literal }
type
nameString = packed array [0..24] of char;
var
id: identPtr; {the identifier for the literal}
name: ^nameString; {the name for the identifier}
class: tokenEnum; {storage class}
begin {MakeCompoundLiteral}
if functionTable <> nil then begin
Error(164);
class := autosy
end {if}
else
class := staticsy;
name := pointer(Malloc(25));
name^ := concat('~CompoundLiteral', cnvis(compoundLiteralNumber));
id := NewSymbol(name, tp, class, variableSpace, defined);
Initializer(id);
MakeCompoundLiteral := id;
compoundLiteralNumber := compoundLiteralNumber + 1;
if compoundLiteralNumber = 0 then
Error(57);
if class = autosy then begin
id^.lln := GetLocalLabel;
id^.clnext := compoundLiteralToAllocate;
compoundLiteralToAllocate := id;
end;
end; {MakeFuncIdentifier}
procedure InitParser;
{ Initialize the parser }
var
typeSpecifierStart: tokenSet;
storageClassSpecifiers: tokenSet;
typeQualifiers: tokenSet;
functionSpecifiers: tokenSet;
alignmentSpecifiers: tokenSet;
begin {InitParser}
doingFunction := false; {not doing a function (yet)}
doingParameters := false; {not processing parameters}
lastLine := 0; {no pc_lnm generated yet}
nameFound := false; {no pc_nam generated yet}
statementList := nil; {no open statements}
codegenStarted := false; {code generator is not started}
doingForLoopClause1 := false; {not doing a for loop}
fIsNoreturn := false; {not doing a noreturn function}
compoundLiteralNumber := 1; {no compound literals yet}
compoundLiteralToAllocate := nil; {no compound literals needing space yet}
{init syntactic classes of tokens}
{See C17 section 6.7 ff.}
typeSpecifierStart :=
[voidsy,charsy,shortsy,intsy,longsy,floatsy,doublesy,signedsy,unsignedsy,
extendedsy,compsy,_Boolsy,_Complexsy,_Imaginarysy,_Atomicsy,
structsy,unionsy,enumsy,typedef];
storageClassSpecifiers :=
[typedefsy,externsy,staticsy,_Thread_localsy,autosy,registersy];
typeQualifiers :=
[constsy,volatilesy,restrictsy,_Atomicsy];
functionSpecifiers := [inlinesy,_Noreturnsy,pascalsy,asmsy];
alignmentSpecifiers := [_Alignassy];
declarationSpecifiersElement := typeSpecifierStart + storageClassSpecifiers
+ typeQualifiers + functionSpecifiers + alignmentSpecifiers;
specifierQualifierListElement :=
typeSpecifierStart + typeQualifiers + alignmentSpecifiers;
structDeclarationStart := specifierQualifierListElement + [_Static_assertsy];
topLevelDeclarationStart :=
declarationSpecifiersElement + [ident,segmentsy,_Static_assertsy];
localDeclarationStart :=
declarationSpecifiersElement + [_Static_assertsy] - [asmsy];
end; {InitParser}
procedure TermParser;
{ shut down the parser }
begin {TermParser}
if statementList <> nil then
case statementList^.kind of
compoundSt : Error(34);
doSt : Error(33);
elseSt : Error(67);
forSt : Error(69);
ifSt : Error(32);
switchSt : Error(70);
whileSt : Error(68);
otherwise: Error(57);
end; {case}
end; {TermParser}
end.