Apple-2gs-SW/ORCA-C
1
0
Fork 0
mirror of https://github.com/byteworksinc/ORCA-C.git synced 2024-12-22 07:30:54 +00:00
Code Issues Projects Releases Wiki Activity
1502e48188
ORCA-C/Parser.pas
Stephen Heumann f79887c565 Don't erroneously pop the symbol table at declarations of a pointer to a typedef'd function type. 
This problem could cause "duplicate symbol" and "undeclared identifier" errors, for example in the following program:

typedef int f1( void );
void bar( void ) {
    int i;
    f1 *foo;
    int baz;
    i = 10;
}
int foo;
long baz;
2017-10-21 20:36:21 -05:00

4003 lines
144 KiB
ObjectPascal
Raw Blame History

{$optimize 1}
{---------------------------------------------------------------}
{ }
{ Parser }
{ }
{ External Subroutines: }
{ }
{ DoDeclaration - process a variable or function declaration }
{ DoStatement - process a statement from a function }
{ InitParser - initialize the parser }
{ Match - insure that the next token is of the specified type }
{ TermParser - shut down the parser }
{ TypeSpecifier - 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 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 }
procedure TypeSpecifier (doingFieldList,isConstant: boolean);
{ handle a type specifier }
{ }
{ parameters: }
{ doingFieldList - are we processing a field list? }
{ isConstant - did we already find a constsy? }
{---------------------------------------------------------------}
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: longint; {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)}
);
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}
isLong: boolean; {do long switch?}
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
doingMain: boolean; {are we processing the main function?}
firstCompoundStatement: boolean; {are we doing a function level compound statement?}
fType: typePtr; {return type of the current function}
initializerList: identList; {list of initialized identifiers}
isForwardDeclared: boolean; {is the field list component }
{ referenceing 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}
{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}
{-- 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. }
{ }
{ paremeters: }
{ 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 imbeded statements) }
var
stPtr: statementPtr; {for creating a compound statement record}
begin {CompoundStatement}
Match(lbracech,27); {make sure there is an opening '{'}
new(stPtr); {create a statement record}
stPtr^.next := statementList;
statementList := stPtr;
stPtr^.kind := compoundSt;
if makeSymbols then {create a symbol table}
PushTable;
stPtr^.doingDeclaration := true; {allow declarations}
initializerList := nil; {no initializers, yet}
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}
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);
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)}
end; {if}
PopTable; {remove this symbol table}
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 asignment 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: integer; {case label value}
begin {CaseStatement}
while token.kind = casesy do begin
NextToken; {skip the 'case' token}
stPtr := GetSwitchRecord; {get the proper switch record}
Expression(arrayExpression, [colonch]); {evaluate the branch condition}
val := long(expressionValue).lsw;
if val <> expressionValue then
if not stPtr^.isLong then
expressionValue := val; {convert out-of-range value to (U)Word}
if stPtr = nil then
Error(72)
else begin
new(swPtr2); {create the new label table entry}
swPtr2^.lab := GenLabel;
Gen1(dc_lab, swPtr2^.lab);
swPtr2^.val := expressionValue;
swPtr := stPtr^.switchList;
if swPtr = nil then begin {enter it in the table}
swPtr2^.last := nil;
swPtr2^.next := nil;
stPtr^.switchList := swPtr2;
stPtr^.maxVal := expressionValue;
stPtr^.labelCount := 1;
end {if}
else begin
while (swPtr^.next <> nil) and (swPtr^.val < expressionValue) do
swPtr := swPtr^.next;
if swPtr^.val = expressionValue then
Error(73)
else if swPtr^.val > expressionValue 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;
stPtr^.maxVal := expressionValue;
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;
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;
Match(lparench,13); {evaluate the start condition}
if token.kind <> semicolonch then begin
Expression(normalExpression, [semicolonch]);
Gen0t(pc_pop, UsualUnaryConversions);
end; {if}
Match(semicolonch,22);
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}
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}
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;
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}
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}
Expression(normalExpression, [semicolonch]);
AssignmentConversion(fType, expressionType, lastWasConst, lastConst,
true, false);
case fType^.kind of
scalarType: 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}
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^.isLong := false;
stPtr^.labelCount := 0;
stPtr^.switchLab := GenLabel;
stPtr^.switchExit := GenLabel;
stPtr^.breakLab := stPtr^.switchExit;
stPtr^.switchList := nil;
stPtr^.switchDefault := 0;
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 [cgLong,cgULong] then begin
stPtr^.isLong := true;
stPtr^.size := cgLongSize;
stPtr^.ln := GetTemp(cgLongSize);
Gen2t(pc_str, stPtr^.ln, 0, cgLong);
end {if}
else if tp^.baseType in [cgByte,cgUByte,cgWord,cgUWord] then begin
stPtr^.isLong := false;
stPtr^.size := cgWordSize;
stPtr^.ln := GetTemp(cgWordSize);
Gen2t(pc_str, stPtr^.ln, 0, cgWord);
end {else if}
else
Error(71);
enumType: begin
stPtr^.isLong := false;
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}
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}
Match(lparench, 13); {evaluate the condition}
Expression(normalExpression, [rparench]);
Match(rparench, 12);
CompareToZero(pc_neq); {evaluate the condition}
Gen1(pc_fjp, endl);
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}
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);
end; {EndDoStatement}
procedure EndIfStatement;
{ finish off an if statement }
var
lab1,lab2: integer; {branch labels}
stPtr: statementPtr; {work pointer}
begin {EndIfStatement}
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;
Statement; {evaluate the else clause}
end {if}
else
Gen1(dc_lab, lab1); {create label for if to branch to}
end; {EndIfStatement}
procedure EndElseStatement;
{ finish off an else clause }
var
stPtr: statementPtr; {work pointer}
begin {EndElseStatement}
stPtr := statementList; {create the label to branch to}
Gen1(dc_lab, stPtr^.elseLab);
statementList := stPtr^.next; {pop the statement record}
dispose(stPtr);
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}
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 seminolon}
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);
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?}
swPtr,swPtr2: switchPtr; {switch label table list}
begin {EndSwitchStatement}
stPtr := statementList; {get the statement record}
exitLab := stPtr^.switchExit; {get the exit label}
isLong := stPtr^.isLong; {get the 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 isLong then {decide on a base type}
ltp := cgLong
else
ltp := cgWord;
if stPtr^.isLong
or (((stPtr^.maxVal-swPtr^.val) div stPtr^.labelCount) > sparse) then
begin
{Long expressions and sparse switch statements are handled as a }
{series of if-goto tests. }
while swPtr <> nil do begin {generate the compares}
if isLong then
GenLdcLong(swPtr^.val)
else
Gen1t(pc_ldc, long(swPtr^.val).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).lsw; {record the min label value}
Gen2t(pc_lod, stPtr^.ln, 0, ltp); {get the value}
Gen1t(pc_dec, minVal, cgWord); {adjust the range}
Gen1(pc_xjp, ord(stPtr^.maxVal-minVal+1)); {do the indexed jump}
while swPtr <> nil do begin {generate the jump table}
while minVal < swPtr^.val do begin
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);
end; {EndSwitchStatement}
procedure EndWhileStatement;
{ finish off a while statement }
var
stPtr: statementPtr; {work pointer}
begin {EndWhileStatement}
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);
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;
isConstant: boolean;
end;
var
i: integer; {loop variable}
lastWasIdentifier: boolean; {for deciding if the declarator is a fuction}
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}
varParmList: boolean; {did we prototype a variable?}
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 (var varParmList: boolean);
{ stack the declaration operators }
{ }
{ Parameters: }
{ varParmList - did we create one? }
var
cp,cpList: pointerListPtr; {pointer list}
done,done2: boolean; {for loop termination}
isPtr: boolean; {is the parenthesized expr a ptr?}
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}
lvarParmList: boolean; {did we prototype a variable?}
{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}
varParmList := false; {no var parm list, yet}
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^.isConstant := false;}
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^.isConstant := false;
while token.kind in
[unsignedsy,signedsy,intsy,longsy,charsy,shortsy,floatsy,
doublesy,compsy,extendedsy,voidsy,enumsy,structsy,unionsy,
volatilesy,constsy] do begin
if token.kind = constsy then
cpList^.isConstant := true
else if token.kind = volatilesy then
volatile := true
else
Error(9);
NextToken;
end; {while}
end; {while}
StackDeclarations(lvarParmList);
end;
lparench: begin {handle '(' 'declarator' ')'}
NextToken;
isPtr := token.kind = asteriskch;
StackDeclarations(lvarParmList);
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;
varParmList := not isFunction;
tPtr2 := pointer(GCalloc(sizeof(typeRecord))); {create the function type}
{tPtr2^.size := 0;}
{tPtr2^.saveDisp := 0;}
tPtr2^.kind := functionType;
{tPtr2^.isConstant := false;}
{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}
if token.kind = voidsy 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}
if token.kind in {see if we are doing a prototyped list}
[autosy,externsy,registersy,staticsy,typedefsy,unsignedsy,intsy,
longsy,charsy,shortsy,floatsy,doublesy,compsy,extendedsy,voidsy,
enumsy,structsy,unionsy,typedef,signedsy,constsy] 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 [autosy,externsy,registersy,staticsy,
typedefsy,unsignedsy,signedsy,intsy,longsy,
charsy,shortsy,floatsy,doublesy,compsy,
extendedsy,enumsy,structsy,unionsy,
typedef,voidsy,volatilesy,constsy])
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^.isConstant := false;}
tPtr2^.kind := arrayType;
{tPtr2^.elements := 0;}
new(ttPtr);
ttPtr^.next := typeStack;
typeStack := ttPtr;
ttPtr^.typeDef := tPtr2;
NextToken;
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}
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^.isConstant := cpList^.isConstant;
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(varParmList); {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 := 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 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 pfunc^.itype^.prototyped then
if not doingPrototypes 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
t1 := variable^.itype;
if CompTypes(t1, tPtr) then begin
if t1^.prototyped and tPtr^.prototyped then begin
p2 := tptr^.parameterList;
if isPascal then begin
{reverse the parameter list}
p1 := nil;
while p2 <> nil do begin
p3 := p2;
p2 := p2^.next;
p3^.next := p1;
p1 := p3;
end; {while}
tPtr^.parameterList := p1;
end; {if}
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);
p2 := tptr^.parameterList;
if isPascal then begin
{reverse the parameter list}
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}
else
Error(42);
1:
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 > 16 then
iPtr^.itype := cgULong
else if bitcount > 8 then
iPtr^.itype := cgUWord
else
iPtr^.itype := cgUByte;
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] then
size := rtree^.token.ival
else if rtree^.token.kind in [longconst,ulongconst] then
size := rtree^.token.lval
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 := wordPtr;
end; {else}
end {if}
else if tree^.token.kind = dotch then begin
tp := Subscript(tree^.left);
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 := wordPtr;
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 := wordPtr;
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 := wordPtr;
end; {else}
end; {Subscript}
begin {GetInitializerValue}
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
iPtr^.iVal := expressionValue;
iPtr^.itype := tp^.baseType;
InitializeBitField;
end; {if}
case tp^.kind of
scalarType: begin
bKind := tp^.baseType;
if (bKind in [cgByte..cgULong])
and (etype^.baseType in [cgByte..cgULong]) then begin
if bKind in [cgLong,cgULong] then
if eType^.baseType = cgUByte then
iPtr^.iVal := iPtr^.iVal & $000000FF
else if eType^.baseType = cgUWord then
iPtr^.iVal := iPtr^.iVal & $0000FFFF;
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 then begin
iPtr^.isConstant := true;
iPtr^.iType := ccPointer;
iPtr^.pval := 0;
iPtr^.pPlus := operator = plusch;
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 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]))
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,longConst] then begin
if kind = intConst then
offSet2 := ival
else
offset2 := lval;
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}
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}
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 if}
else if tp^.kind = unionType then
{fill a union}
Fill(count, tp^.fieldList^.iType)
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 infered 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) and (kind = scalarType)
and (ktp^.baseType in [cgByte,cgUByte]) then begin
if tp^.elements = 0 then begin
tp^.elements := token.sval^.length + 1;
RecomputeSizes(variable^.itype);
end {if}
else if tp^.elements < token.sval^.length 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 - token.sval^.length;
if count <> 0 then
Fill(count, bytePtr);
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 of non-strings}
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;
while (ip <> nil) and (ip^.itype^.size > 0)
and (token.kind <> rbracech) do begin
if ip^.isForwardDeclared then
ResolveForwardReference(ip);
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
if bitCount > 0 then begin
bitCount := (bitCount+7) div 8;
count := count-bitCount;
bitCount := 0;
end; {if}
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
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
Fill(count, bytePtr);
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;
new(ip); {place the initializer in the list}
ip^.next := initializerList;
ip^.id := variable;
initializerList := ip;
useGlobalPool := luseGlobalPool; {restore useGlobalPool}
end; {Initializer}
procedure TypeSpecifier {doingFieldList,isConstant: boolean};
{ handle a type specifier }
{ }
{ parameters: }
{ doingFieldList - are we processing a field list? }
{ isConstant - did we already find a constsy? }
{ }
{ outputs: }
{ isForwardDeclared - is the field list component }
{ referenceing a forward struct/union? }
{ skipDeclarator - for enum,struct,union with no }
{ declarator }
{ typespec - type specifier }
label 1,2;
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?}
procedure FieldList (tp: typePtr; kind: typeKind);
{ handle a field list }
{ }
{ parameters }
{ tp - place to store the type pointer }
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?}
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}
{check for no declarations}
if not (token.kind in [unsignedsy,signedsy,intsy,longsy,charsy,shortsy,
floatsy,doublesy,compsy,extendedsy,enumsy,structsy,unionsy,typedefsy,
typedef,voidsy,constsy,volatilesy]) then
Error(26);
{while there are entries in the field list...}
while token.kind in [unsignedsy,signedsy,intsy,longsy,charsy,shortsy,floatsy,
doublesy,compsy,extendedsy,enumsy,structsy,unionsy,typedefsy,typedef,
voidsy,constsy,volatilesy] do begin
typeSpec := wordPtr; {default type specifier is an integer}
TypeSpecifier(true,false); {get the type specifier}
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 token.kind = colonch then {handle a bit field}
begin
if kind = unionType then
Error(56);
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;
bitdisp := bitdisp+long(expressionValue).lsw;
tPtr := variable^.itype;
end {if}
else
tPtr := typeSpec;
if (tPtr^.kind <> scalarType)
or not (tPtr^.baseType in
[cgByte,cgUByte,cgWord,cgUWord,cgLong,cgULong])
or (expressionValue > tPtr^.size*8) then
Error(115);
end {if}
else if variable <> nil then begin
if bitdisp <> 0 then begin
disp := disp+((bitDisp+7) div 8);
bitdisp := 0;
end {if}
else if kind = unionType then
disp := 0;
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 {handle flexible array member}
didFlexibleArray := true
else
Error(117);
end {if}
else
Error(116);
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}
storageClass := lStorageClass; {restore default storage class}
isForwardDeclared := lisForwardDeclared; {restore the forward flag}
doingParameters := ldoingParameters; {restore the parameters flag}
end; {FieldList}
procedure CheckConst;
{ Check the token to see if it is a const or volatile }
begin {CheckConst}
while token.kind in [constsy,volatilesy] do begin
if token.kind = constsy then
isConstant := true
else
volatile := true;
NextToken;
end; {while}
end; {CheckConst}
begin {TypeSpecifier}
isForwardDeclared := false; {not doing a forward reference (yet)}
skipDeclarator := false; {declarations are required (so far)}
CheckConst;
case token.kind of
unsignedsy: begin {unsigned}
NextToken;
CheckConst;
if token.kind = shortsy then begin
NextToken;
CheckConst;
if token.kind = intsy then begin
NextToken;
CheckConst;
end; {if}
typeSpec := uWordPtr;
end {if}
else if token.kind = longsy then begin
NextToken;
CheckConst;
if token.kind = intsy then begin
NextToken;
CheckConst;
end; {if}
typeSpec := uLongPtr;
end {else if}
else if token.kind = charsy then begin
NextToken;
CheckConst;
typeSpec := uBytePtr;
end {else if}
else if token.kind = intsy then begin
NextToken;
CheckConst;
if unix_1 then
typeSpec := uLongPtr
else
typeSpec := uWordPtr;
end {else if}
else begin
CheckConst;
if unix_1 then
typeSpec := uLongPtr
else
typeSpec := uWordPtr;
end; {else if}
end;
signedsy: begin {signed}
NextToken;
CheckConst;
if token.kind = shortsy then begin
NextToken;
CheckConst;
if token.kind = intsy then begin
NextToken;
CheckConst;
end; {if}
typeSpec := wordPtr;
end {if}
else if token.kind = longsy then begin
NextToken;
CheckConst;
if token.kind = intsy then begin
NextToken;
CheckConst;
end; {if}
typeSpec := longPtr;
end {else if}
else if token.kind = intsy then begin
NextToken;
CheckConst;
if unix_1 then
typeSpec := longPtr
else
typeSpec := wordPtr;
end {else if}
else if token.kind = charsy then begin
NextToken;
CheckConst;
typeSpec := bytePtr;
end; {else if}
end;
intsy: begin {int}
NextToken;
CheckConst;
if unix_1 then
typeSpec := longPtr
else
typeSpec := wordPtr;
end;
longsy: begin {long}
NextToken;
CheckConst;
typeSpec := longPtr;
if token.kind in [intsy,floatsy] then begin
if token.kind = floatsy then
typeSpec := doublePtr;
NextToken;
CheckConst;
end {if}
else if token.kind = doublesy then begin
typeSpec := extendedPtr;
NextToken;
CheckConst;
end; {else if}
end;
charsy: begin {char}
NextToken;
CheckConst;
typeSpec := uBytePtr;
end;
shortsy: begin {short}
NextToken;
CheckConst;
if token.kind = intsy then begin
NextToken;
CheckConst;
end; {if}
typeSpec := wordPtr;
end;
floatsy: begin {float}
NextToken;
CheckConst;
typeSpec := realPtr;
end;
doublesy: begin {double}
NextToken;
CheckConst;
typeSpec := doublePtr;
end;
compsy: begin {comp}
NextToken;
CheckConst;
typeSpec := compPtr;
end;
extendedsy: begin {extended}
NextToken;
CheckConst;
typeSpec := extendedPtr;
end;
voidsy: begin {void}
NextToken;
CheckConst;
typeSpec := voidPtr;
end;
enumsy: begin {enum}
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^.isConstant := false;
tPtr^.kind := enumType;
variable :=
NewSymbol(ttoken.name, tPtr, storageClass, tagSpace, defined);
CheckConst;
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^.isConstant := false;
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);
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: skipDeclarator := token.kind = semicolonch;
end;
structsy, {struct}
unionsy: begin {union}
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
isForwardDeclared := 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^.isConstant := false;}
structTypePtr^.kind := tkind;
{structTypePtr^.fieldList := nil;}
{structTypePtr^.sName := nil;}
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;
CheckConst;
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^.isConstant := false;}
structTypePtr^.kind := tkind;
{structTypePtr^.fieldList := nil;}
{structTypePtr^.sName := nil;}
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;
typeSpec := structTypePtr;
skipDeclarator := token.kind = semicolonch;
end;
typedef: begin {named type definition}
typeSpec := token.symbolPtr^.itype;
NextToken;
end;
otherwise: ;
end; {case}
if isconstant then begin {handle a constant type}
new(tPtr);
if typeSpec^.kind in [structType,unionType] then begin
with tPtr^ do begin
size := typeSpec^.size;
kind := definedType;
dType := typeSpec;
end; {with}
end {if}
else
tPtr^ := typeSpec^;
tPtr^.isConstant := true;
typeSpec := tPtr;
end; {if}
end; {TypeSpecifier}
{-- 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;
var
done: boolean; {for loop termination}
foundConstsy: boolean; {did we find a constsy?}
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?}
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?}
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 }
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}
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}
lDoingParameters := doingParameters; {record the status}
noFDefinitions := false; {are function definitions inhibited?}
typeFound := false; {no explicit type found, yet}
foundConstsy := false; {did not find a constsy}
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}
if not doingFunction then {handle any segment statements}
while token.kind = segmentsy do
SegmentStatement;
inhibitHeader := true; {block imbedded includes in headers}
if token.kind in [constsy,volatilesy] {handle leading constsy, volatile}
then begin
while token.kind in [constsy,volatilesy] do begin
if token.kind = constsy then
foundConstsy := true
else
volatile := true;
NextToken;
end; {while}
end; {if}
storageClass := ident; {handle a StorageClassSpecifier}
lUseGlobalPool := useGlobalPool;
if token.kind in [autosy,externsy,registersy,staticsy,typedefsy] then begin
typeFound := true;
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
useGlobalPool := true;
NextToken;
end; {if}
isAsm := false;
isPascal := false;
isInline := false;
while token.kind in [pascalsy,asmsy,inlinesy] do begin
if token.kind = pascalsy then
isPascal := true
else if token.kind = asmsy then
isAsm := true
else {if token.kind = inlinesy then}
isInline := true;
NextToken;
end; {while}
lisPascal := isPascal;
typeSpec := wordPtr; {default type specifier is an integer}
if token.kind in {handle a TypeSpecifier/declarator}
[unsignedsy,signedsy,intsy,longsy,charsy,shortsy,floatsy,doublesy,compsy,
extendedsy,voidsy,enumsy,structsy,unionsy,typedef,volatilesy,constsy] then
begin
typeFound := true;
TypeSpecifier(false,foundConstsy);
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}
end {if}
else 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;
isPascal := lisPascal;
{make sure variables have some type info}
if isFunction then begin
if not typeFound then
if (lint & lintNoFnType) <> 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 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] 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] 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;
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 [autosy,externsy,registersy,staticsy,typedefsy,
unsignedsy,signedsy,intsy,longsy,charsy,shortsy,
floatsy,doublesy,compsy,extendedsy,enumsy,
structsy,unionsy,typedef,voidsy,volatilesy,
constsy,ident]) 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
tlp^.itype := wordPtr;
tlp := tlp^.pnext;
end; {while}
end; {if}
tlp := lp; {make sure all parameters have an}
while tlp <> nil do { identifier }
if tlp^.name^ = '?' then begin
Error(113);
tlp := nil;
end {if}
else
tlp := tlp^.pnext;
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';
firstCompoundStatement := true;
Gen0 (dc_pin);
if not isAsm then
Gen0(pc_ent);
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}
{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}
if isAsm then begin
AsmFunction(variable); {handle assembly language functions}
PopTable;
end {if}
else begin
{generate parameter labels}
if fnType^.overrideKR then
GenParameters(nil)
else
GenParameters(fnType^.parameterList);
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 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 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);
{allocate space}
if variable^.storage = stackFrame then begin
variable^.lln := GetLocalLabel;
Gen2(dc_loc, variable^.lln, long(variable^.itype^.size).lsw);
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;
end; {DoDeclaration}
procedure DoStatement;
{ process a statement from a function }
procedure AutoInit;
{ initialize auto variables }
var
count: integer; {initializer counter}
ip: identPtr; {pointer to a symbol table entry}
lp1,lp2: identList; {used to reverse, track the list}
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;
var
elements: longint; {# array elements}
fp: identPtr; {for tracing field lists}
size: integer; {fill size}
union: boolean; {are we doing a 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}
with id^ do {load the base address}
case storage of
stackFrame: Gen2(pc_lda, lln, 0);
parameter: if itype^.kind = arrayType then
Gen2t(pc_lod, pln, 0, cgULong)
else
Gen2(pc_lda, pln, 0);
external,
global,
private: Gen1Name(pc_lao, 0, name);
otherwise: ;
end; {case}
if disp <> 0 then
Gen1t(pc_inc, long(disp).lsw, cgULong)
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 repititions }
{ 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}
case itype^.kind of
scalarType,pointerType,enumType,functionType: begin
LoadAddress; {load the destination address}
doDispose := count = 1; {generate the expression value}
tree := iptr^.itree; {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];
if isConstant then
if tree^.token.class = intConstant then
val := tree^.token.ival
else
val := tree^.token.lval;
{ 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}
end;
arrayType: begin
if itype^.aType^.kind = scalarType then
if itype^.aType^.baseType in [cgByte,cgUByte] then
if iPtr^.iTree^.token.kind = stringConst then begin
GenLdcLong(itype^.elements);
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, @'strncpy');
iPtr := iPtr^.next;
goto 1;
end; {if}
elements := itype^.elements;
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, 0, cgVoid, @'~ZERO');
disp := disp + size;
count := count - long(elements).lsw;
if count = 0 then begin
iPtr := iPtr^.next;
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;
count := iPtr^.count;
end; {if}
end; {if}
disp := disp+itype^.size;
elements := elements-1;
end; {while}
end; {else}
1: end;
structType,unionType: begin
if iPtr^.isStructOrUnion then begin
LoadAddress; {load the destination address}
GenerateCode(iptr^.iTree); {load the stuct 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;
bitsize := iPtr^.bitsize;
bitdisp := iPtr^.bitdisp;
bitcount := 0;
while fp <> nil do begin
itype := fp^.itype;
{ 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
disp := disp + (bitcount+7) div 8;
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;
disp := disp + 1;
end {else if}
else
disp := disp + itype^.size;
end {if}
else if fp^.bitSize = 0 then begin
bitsize := 0;
disp := disp + itype^.size;
end {else if}
else begin
if bitsize + bitdisp < bitcount then
disp := disp + (bitcount + 7) div 8;
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;
count := iPtr^.count;
bitsize := iPtr^.bitsize;
bitdisp := iPtr^.bitdisp;
end; {if}
end; {if}
if union then
fp := nil
else
fp := fp^.next;
end; {while}
end; {else}
end;
otherwise: Error(57);
end; {case}
end; {Initialize}
begin {AutoInit}
lp1 := nil; {reverse the list}
while initializerList <> nil do begin
lp2 := initializerList;
initializerList := lp2^.next;
lp2^.next := lp1;
lp1 := lp2;
end; {while}
while lp1 <> nil do begin {initialize the variables}
ip := lp1^.id;
iPtr := ip^.iPtr;
count := iPtr^.count;
if ip^.class <> staticsy then
Initialize(ip, 0, ip^.itype);
lp2 := lp1;
lp1 := lp1^.next;
dispose(lp2);
end; {while}
end; {AutoInit}
begin {DoStatement}
case statementList^.kind of
compoundSt: begin
if token.kind = rbracech then begin
if statementList^.doingDeclaration then
if initializerList <> nil then
AutoInit;
EndCompoundStatement;
end {if}
else if (statementList^.doingDeclaration = true)
and (token.kind in [autosy,externsy,registersy,staticsy,typedefsy,
unsignedsy,signedsy,intsy,longsy,charsy,shortsy,
floatsy,doublesy,compsy,extendedsy,enumsy,
structsy,unionsy,typedef,voidsy,volatilesy,
constsy])
then
DoDeclaration(false)
else begin
if statementList^.doingDeclaration then begin
statementList^.doingDeclaration := false;
if firstCompoundStatement then begin
Gen1Name(dc_sym, ord(doingMain), pointer(table));
firstCompoundStatement := false;
end; {if}
if initializerList <> nil then
AutoInit;
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 InitParser;
{ Initialize the parser }
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}
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.
Reference in New Issue View Git Blame Copy Permalink