Apple-2gs-SW/ORCA-C
1
0
Fork 0
mirror of https://github.com/byteworksinc/ORCA-C.git synced 2024-11-17 20:06:49 +00:00
Code Issues Projects Releases Wiki Activity
0b8d4ce3e4
ORCA-C/Parser.pas
Stephen Heumann 0b8d4ce3e4 Fix invalid static initialization of bitfields occupying three bytes. 
An extra, fourth byte was being generated for the bitfield(s). This would cause all subsequent members of the struct and any enclosing object not to be initialized at the proper locations, which would generally corrupt their values.

The following program illustrates the issue:

#include <stdio.h>

struct X {
    int a:9;
    int b:9;
    int c;
} x = {123,234,12345};

int main(void) {
    printf("x.a = %i, x.b = %i, x.b = %i\n", x.a, x.b, x.c);
}
2018-04-11 23:42:04 -05:00

4083 lines
147 KiB
ObjectPascal
Raw Blame History

{$optimize 1}
{---------------------------------------------------------------}
{ }
{ Parser }
{ }
{ External Subroutines: }
{ }
{ DoDeclaration - process a variable or function declaration }
{ DoStatement - process a statement from a function }
{ AutoInit - generate code to initialize an auto variable }
{ InitParser - initialize the parser }
{ Match - insure that the next token is of the specified type }
{ TermParser - shut down the parser }
{ 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, autoOrRegisterOnly: boolean);
{ process a variable or function declaration }
{ }
{ parameters: }
{ doingPrototypes - are we processing a parameter list? }
{ autoOrRegisterOnly - limit storage classes allowed? }
procedure DoStatement;
{ process a statement from a function }
procedure AutoInit (variable: identPtr);
{ generate code to initialize an auto variable }
{ }
{ parameters: }
{ variable - the variable to initialize }
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}
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}
savedVolatile: boolean; {saved copy of volatile}
{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}
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)}
volatile := savedVolatile; {local volatile vars are out of scope}
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;
if c99Scope then PushTable;
if c99Scope then PushTable;
Statement; {process the first loop body statement}
end; {DoStatement}
procedure ForStatement;
{ handle a for statement }
var
errorFound: boolean; {did we find an error?}
forLoop, continueLab, breakLab: integer; {branch points}
lType: typePtr; {type of "left" expression}
parencount: integer; {number of unmatched '(' chars}
stPtr: statementPtr; {work pointer}
tl,tk: tokenStackPtr; {for forming expression list}
begin {ForStatement}
NextToken; {skip the 'for' token}
new(stPtr); {create a statement record}
stPtr^.next := statementList;
statementList := stPtr;
stPtr^.kind := forSt;
forLoop := GenLabel; {create the branch labels}
continueLab := GenLabel;
breakLab := GenLabel;
stPtr^.forLoop := forLoop;
stPtr^.continueLab := continueLab;
stPtr^.breakLab := breakLab;
if c99Scope then PushTable;
Match(lparench,13); {evaluate the start condition}
if allowMixedDeclarations
and (token.kind in [autosy,registersy,unsignedsy,signedsy,intsy,longsy,
charsy,shortsy,floatsy,doublesy,compsy,extendedsy,enumsy,
structsy,unionsy,typedef,voidsy,volatilesy,constsy,
externsy,staticsy,typedefsy]) then begin
DoDeclaration(false, true)
end {if}
else if token.kind <> semicolonch then begin
Expression(normalExpression, [semicolonch]);
Gen0t(pc_pop, UsualUnaryConversions);
Match(semicolonch,22);
end {else if}
else
NextToken;
Gen1(dc_lab, forLoop); {this label points to the condition}
if token.kind <> semicolonch then {handle the loop test}
begin {evaluate the expression}
Expression(normalExpression, [semicolonch]);
CompareToZero(pc_neq); {Evaluate the condition}
Gen1(pc_fjp, breakLab);
end; {if}
Match(semicolonch,22);
tl := nil; {collect the tokens for the last expression}
parencount := 0;
errorFound := false;
while (token.kind <> eofsy)
and ((token.kind <> rparench) or (parencount <> 0))
and (token.kind <> semicolonch) do begin
new(tk); {place the token in the list}
tk^.next := tl;
tl := tk;
tk^.token := token;
if token.kind = lparench then {allow parens in the expression}
parencount := parencount+1
else if token.kind = rparench then
parencount := parencount-1;
NextToken; {next token}
end; {while}
if errorFound then {if an error was found, dump the list}
while tl <> nil do begin
tk := tl;
tl := tl^.next;
dispose(tk);
end; {while}
stPtr^.e3List := tl; {save the list}
Match(rparench,12); {get the closing for loop paren}
if c99Scope then PushTable;
Statement; {process the first loop body statement}
end; {ForStatement}
procedure IfStatement;
{ handle an if statement }
var
lab: integer; {branch label}
lType: typePtr; {type of "left" expression}
stPtr: statementPtr; {work pointer}
begin {IfStatement}
NextToken; {skip the 'if' token}
if c99Scope then PushTable;
Match(lparench, 13); {evaluate the condition}
Expression(normalExpression, [rparench]);
Match(rparench, 12);
lab := GenLabel; {create the branch label}
CompareToZero(pc_neq); {evaluate the condition}
Gen1(pc_fjp, lab);
new(stPtr); {create a statement record}
stPtr^.next := statementList;
statementList := stPtr;
stPtr^.kind := ifSt;
stPtr^.ifLab := lab;
if c99Scope then PushTable;
Statement; {process the 'true' statement}
end; {IfStatement}
procedure GotoStatement;
{ handle a goto statement }
begin {GotoStatement}
NextToken; {skip the 'goto' token}
if token.kind in [ident,typedef] then begin
GotoLabel(pc_ujp); {jump to the label}
NextToken; {skip the token}
end {if}
else
Error(9); {flag the error}
Match(semicolonch, 22); {insist on a closing ';'}
end; {GotoStatement}
procedure LabelStatement;
{ handle a labeled statement }
begin {LabelStatement}
GotoLabel(dc_lab); {define the label}
NextToken; {skip the label}
if token.kind = colonch then {if present, skip the colon}
NextToken
else begin {bad statement - flag error and skip it}
Error(31);
SkipStatement;
end; {else}
end; {LabelStatement}
procedure ReturnStatement;
{ handle a return statement }
var
id: identPtr; {structure id}
size: longint; {size of the struct/union}
tk: tokenType; {structure name token}
begin {ReturnStatement}
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;
if c99Scope then PushTable;
Match(lparench, 13); {evaluate the condition}
Expression(normalExpression,[rparench]);
Match(rparench, 12);
tp := expressionType; {make sure the expression is integral}
while tp^.kind = definedType do
tp := tp^.dType;
case tp^.kind of
scalarType:
if tp^.baseType in [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}
if c99Scope then PushTable;
Statement; {process the loop body statement}
end; {SwitchStatement}
procedure WhileStatement;
{ handle a while statement }
var
lType: typePtr; {type of "left" expression}
stPtr: statementPtr; {work pointer}
top, endl: integer; {branch points}
begin {WhileStatement}
NextToken; {skip the 'while' token}
new(stPtr); {create a statement record}
stPtr^.next := statementList;
statementList := stPtr;
stPtr^.kind := whileSt;
top := GenLabel; {create the branch labels}
endl := GenLabel;
stPtr^.whileTop := top;
stPtr^.whileEnd := endl;
stPtr^.breakLab := endl;
stPtr^.continueLab := top;
Gen1(dc_lab, top); {define the top label}
if c99Scope then PushTable;
Match(lparench, 13); {evaluate the condition}
Expression(normalExpression, [rparench]);
Match(rparench, 12);
CompareToZero(pc_neq); {evaluate the condition}
Gen1(pc_fjp, endl);
if c99Scope then PushTable;
Statement; {process the first loop body statement}
end; {WhileStatement}
begin {Statement}
1:
{if trace names are enabled and a line # is due, generate it}
if traceBack or debugFlag then
if nameFound or debugFlag then
if lastLine <> lineNumber then begin
lastLine := lineNumber;
Gen2(pc_lnm, lineNumber, ord(debugType));
end; {if}
{handle the statement}
case token.kind of
asmsy: begin
NextToken;
AsmStatement;
end;
breaksy: BreakStatement;
casesy: CaseStatement;
continuesy: ContinueStatement;
defaultsy: DefaultStatement;
dosy: DoStatement;
elsesy: begin Error(25); SkipStatement; end;
forsy: ForStatement;
gotosy: GotoStatement;
typedef,
ident: begin
lPrintMacroExpansions := printMacroExpansions;
printMacroExpansions := false;
lToken := token;
NextToken;
tToken := token;
PutBackToken(token, true);
token := lToken;
printMacroExpansions := lPrintMacroExpansions;
if tToken.kind = colonch then begin
LabelStatement;
goto 1;
end {if}
else
AssignmentStatement;
end;
ifsy: IfStatement;
lbracech: CompoundStatement(true);
returnsy: ReturnStatement;
semicolonch: NextToken;
switchsy: SwitchStatement;
whilesy: WhileStatement;
otherwise: AssignmentStatement;
end; {case}
end; {Statement}
procedure EndDoStatement;
{ finish off a do statement }
var
lType: typePtr; {type of "left" expression}
stPtr: statementPtr; {work pointer}
begin {EndDoStatement}
if c99Scope then PopTable;
stPtr := statementList; {get the statement record}
if token.kind = whilesy then begin {if a while clause exists, process it}
NextToken; {skip the 'while' token}
if stPtr^.continueLab <> 0 then {create the continue label}
Gen1(dc_lab, stPtr^.continueLab);
Match(lparench, 13); {evaluate the condition}
Expression(normalExpression, [rparench]);
Match(rparench, 12);
CompareToZero(pc_equ); {evaluate the condition}
Gen1(pc_fjp, stPtr^.doLab);
Match(semicolonch, 22); {process the closing ';'}
end {if}
else
Error(30); {'while' expected}
if stPtr^.breakLab <> 0 then {create the break label}
Gen1(dc_lab, stPtr^.breakLab);
statementList := stPtr^.next; {pop the statement record}
dispose(stPtr);
if c99Scope then PopTable;
end; {EndDoStatement}
procedure EndIfStatement;
{ finish off an if statement }
var
lab1,lab2: integer; {branch labels}
stPtr: statementPtr; {work pointer}
begin {EndIfStatement}
if c99Scope then PopTable;
stPtr := statementList; {get the label to branch to}
lab1 := stPtr^.ifLab;
statementList := stPtr^.next; {pop the statement record}
dispose(stPtr);
if token.kind = elsesy then begin {if an else clause exists, process it}
NextToken; {skip 'else'}
lab2 := GenLabel; {create the branch label}
Gen1(pc_ujp, lab2); {branch past the else clause}
Gen1(dc_lab, lab1); {create label for if to branch to}
new(stPtr); {create a statement record}
stPtr^.next := statementList;
statementList := stPtr;
stPtr^.kind := elseSt;
stPtr^.elseLab := lab2;
if c99Scope then PushTable;
Statement; {evaluate the else clause}
end {if}
else begin
Gen1(dc_lab, lab1); {create label for if to branch to}
if c99Scope then PopTable;
end; {else}
end; {EndIfStatement}
procedure EndElseStatement;
{ finish off an else clause }
var
stPtr: statementPtr; {work pointer}
begin {EndElseStatement}
if c99Scope then PopTable;
stPtr := statementList; {create the label to branch to}
Gen1(dc_lab, stPtr^.elseLab);
statementList := stPtr^.next; {pop the statement record}
dispose(stPtr);
if c99Scope then PopTable;
end; {EndElseStatement}
procedure EndForStatement;
{ finish off a for statement }
var
ltoken: tokenType; {for putting ; on stack}
stPtr: statementPtr; {work pointer}
tl,tk: tokenStackPtr; {for forming expression list}
lPrintMacroExpansions: boolean; {local copy of printMacroExpansions}
begin {EndForStatement}
if c99Scope then PopTable;
stPtr := statementList;
Gen1(dc_lab, stPtr^.continueLab); {define the continue label}
tl := stPtr^.e3List; {place the expression back in the list}
if tl <> nil then begin
PutBackToken(token, false);
ltoken.kind := semicolonch;
ltoken.class := reservedSymbol;
PutBackToken(ltoken, false);
while tl <> nil do begin
PutBackToken(tl^.token, false);
tk := tl;
tl := tl^.next;
dispose(tk);
end; {while}
lPrintMacroExpansions := printMacroExpansions; {inhibit token echo}
printMacroExpansions := false;
NextToken; {evaluate the expression}
Expression(normalExpression, [semicolonch]);
Gen0t(pc_pop, UsualUnaryConversions);
NextToken; {skip the 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);
if c99Scope then PopTable;
end; {EndForStatement}
procedure EndSwitchStatement;
{ finish off a switch statement }
const
sparse = 5; {label to tableSize ratio for sparse table}
var
default: integer; {default label}
ltp: baseTypeEnum; {base type}
minVal: integer; {min switch value}
stPtr: statementPtr; {work pointer}
{copies of vars (for efficiency)}
{-------------------------------}
exitLab: integer; {label at the end of the jump table}
isLong: boolean; {is the case expression long?}
swPtr,swPtr2: switchPtr; {switch label table list}
begin {EndSwitchStatement}
if c99Scope then PopTable;
stPtr := statementList; {get the statement record}
exitLab := stPtr^.switchExit; {get the exit label}
isLong := stPtr^.isLong; {get the long flag}
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);
if c99Scope then PopTable;
end; {EndSwitchStatement}
procedure EndWhileStatement;
{ finish off a while statement }
var
stPtr: statementPtr; {work pointer}
begin {EndWhileStatement}
if c99Scope then PopTable;
stPtr := statementList; {loop to the test}
Gen1(pc_ujp, stPtr^.whileTop);
Gen1(dc_lab, stPtr^.whileEnd); {create the exit label}
statementList := stPtr^.next; {pop the statement record}
dispose(stPtr);
if c99Scope then PopTable;
end; {EndWhileStatement}
{-- Type declarations ------------------------------------------}
procedure Declarator(tPtr: typePtr; var variable: identPtr; space: spaceType;
doingPrototypes: boolean);
{ handle a declarator }
{ }
{ parameters: }
{ tPtr - pointer to the type to use }
{ variable - pointer to variable being defined }
{ space - variable space to use }
{ doingPrototypes - are we compiling prototype parameter }
{ declarations? }
label 1;
type
typeDefPtr = ^typeDefRecord; {for stacking type records}
typeDefRecord = record
next: typeDefPtr;
typeDef: typePtr;
end;
pointerListPtr = ^pointerList; {for stacking pointer types}
pointerList = record
next: pointerListPtr;
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?}
isVoid: boolean; {is the type specifier void?}
wp: parameterPtr; {used to build prototype var list}
pvar: identPtr; {work pointer}
tPtr2: typePtr; {work pointer}
ttPtr: typeDefPtr; {work pointer}
parencount: integer; {for skipping in parm list}
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}
isVoid := token.kind = voidsy;
if token.kind = typedef then
if token.symbolPtr^.itype^.kind = scalarType then
if token.symbolPtr^.itype^.baseType = cgVoid then
isVoid := true;
if isVoid then begin {check for a void prototype}
lPrintMacroExpansions := printMacroExpansions;
printMacroExpansions := false;
NextToken;
printMacroExpansions := lPrintMacroExpansions;
if token.kind = rparench then begin
PutBackToken(token, false);
NextToken;
tPtr2^.prototyped := true;
end
else begin
PutBackToken(token, false);
token.kind := voidsy;
token.class := reservedSymbol;
end; {else}
end; {if}
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, false);
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 <= 8 then
iPtr^.itype := cgUByte
else if bitcount <= 16 then
iPtr^.itype := cgUWord
else if bitcount > 24 then
iPtr^.itype := cgULong
else begin {3-byte bitfield: split into two parts}
iPtr^.itype := cgUWord;
iPtr^.iVal := bitvalue & $0000FFFF;
bitcount := bitcount - 16;
bitvalue := bitvalue >> 16;
InitializeBitField;
end;
bitcount := 0; {reset the bit field values}
bitvalue := 0;
end; {if}
end; {InitializeBitField}
procedure GetInitializerValue (tp: typePtr; bitsize,bitdisp: integer);
{ get the value of an initializer from a single expression }
{ }
{ parameters: }
{ tp - type of the variable being initialized }
{ bitsize - size of bit field (0 for non-bit fields) }
{ bitdisp - disp of bit field; unused if bitsize = 0 }
label 1,2,3;
var
bitmask: longint; {used to add a value to a bit field}
bKind: baseTypeEnum; {type of constant}
etype: typePtr; {expression type}
i: integer; {loop variable}
ip: identPtr; {ident in pointer constant}
iPtr: initializerPtr; {for creating an initializer entry}
kind: tokenEnum; {kind of constant}
offset, offset2: longint; {integer offset from a pointer}
operator: tokenEnum; {operator for constant pointers}
tKind: typeKind; {type of constant}
tree: tokenPtr; {for evaluating pointer constants}
function Subscript (tree: tokenPtr): typePtr;
{ handle subscripts in a pointer constant }
{ }
{ parameters: }
{ tree - subscript operators }
{ }
{ returns: type of the variable }
{ }
{ variables: }
{ iPtr - initializer location to store the array name }
{ offset - bytes past the start of the array }
var
ip: identPtr; {ident pointer}
rtree: tokenPtr; {work pointer}
tp: typePtr; {for tracking types}
select: longint; {selector size}
size: longint; {subscript value}
begin {Subscript}
if tree^.token.kind = uasterisk then begin
tree := tree^.left;
if tree^.token.kind = plusch then begin
rtree := tree^.right;
if rtree^.token.kind in [intconst,uintconst] 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);
while tp^.kind = definedType do
tp := tp^.dType;
if tp^.kind in [structType,unionType] then begin
DoSelection(tp, tree^.right, select);
Subscript := expressionType;
offset := offset+select;
if isBitField then
Error(106);
end {if}
else begin
Error(47);
errorFound := true;
Subscript := 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 := false;
iPtr^.isName := false;
iPtr^.pStr := longstringPtr(expressionValue);
end {if}
else if etype^.kind = scalarType then
if etype^.baseType in [cgByte..cgULong] then
if expressionValue = 0 then
iPtr^.iType := cgULong
else begin
Error(47);
errorFound := true;
end {else}
else 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);
if ip^.bitSize = 0 then
if bitCount > 0 then begin
InitializeBitField;
bitCount := (bitCount+7) div 8;
count := count-bitCount;
bitCount := 0;
end; {if}
InitializeTerm(ip^.itype, ip^.bitsize, ip^.bitdisp, false);
if ip^.bitSize <> 0 then begin
bitCount := bitCount + ip^.bitSize;
if bitCount > maxBitField then begin
count := count - (maxBitField div 8);
bitCount := ip^.bitSize;
end; {if}
end {if}
else begin
count := count-ip^.itype^.size;
end; {else}
{ writeln('Initializer: ', ip^.bitsize:10, ip^.bitdisp:10, bitCount:10); {debug}
if kind = unionType then
ip := nil
else
ip := ip^.next;
if token.kind = commach then begin
if ip <> nil then
NextToken;
end {if}
else
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;
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, autoOrRegisterOnly: 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 }
begin
if tp^.elements = 0 then { size and an unspecified size is not }
if not firstVariable then { allowed here, flag an error. }
begin
Error(49);
goto 1;
end; {if}
if tp^.aType^.size = 0 then begin
Error(123);
goto 1;
end; {if}
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;
if autoOrRegisterOnly then
if not (storageClass in [autosy,registersy]) then
Error(127);
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, 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';
hasVarargsCall := false;
firstCompoundStatement := true;
Gen0 (dc_pin);
if not isAsm then
Gen1Name(pc_ent, 0, variable^.name);
nextLocalLabel := 1; {initialize GetLocalLabel}
returnLabel := GenLabel; {set up an exit point}
tempList := nil; {initialize the work label list}
if not isAsm then {generate traceback, profile code}
if traceBack or profileFlag then begin
if traceBack then
nameFound := true;
GenPS(pc_nam, variable^.name);
end; {if}
nextPdisp := 0; {assign displacements to the parameters}
if not fnType^.isPascal then begin
tlp := lp;
lp := nil;
while tlp <> nil do begin
tlp2 := tlp;
tlp := tlp^.pnext;
tlp2^.pnext := lp;
lp := tlp2;
end; {while}
end; {if}
while lp <> nil do begin
lp^.pdisp := nextPdisp;
if lp^.itype^.kind = arrayType then
nextPdisp := nextPdisp + cgPointerSize
else begin
if lp^.itype^.kind = scalarType then
if lp^.itype^.baseType in [cgReal,cgDouble,cgComp] then
{all floating-points are passed as extended}
lp^.itype := extendedPtr;
nextPdisp := nextPdisp + long(lp^.itype^.size).lsw;
if (long(lp^.itype^.size).lsw = 1)
and (lp^.itype^.kind = scalarType) then
nextPdisp := nextPdisp+1;
end; {else}
lp := lp^.pnext;
end; {while}
gotoList := nil; {initialize the label list}
{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);
savedVolatile := volatile;
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 or not doingFunction);
{allocate space}
if variable^.storage = stackFrame then begin
variable^.lln := GetLocalLabel;
Gen2(dc_loc, variable^.lln, long(variable^.itype^.size).lsw);
if variable^.state = initialized then
AutoInit(variable); {initialize auto variable}
end; {if}
if (token.kind = commach) and (not doingPrototypes) then begin
done := false; {allow multiple variables on one line}
NextToken;
variable := nil;
Declarator(typeSpec, variable, variableSpace, doingPrototypes);
if variable = nil then begin
if token.kind = semicolonch then
NextToken
else begin
Error(22);
SkipStatement;
end; {else}
goto 1;
end; {if}
goto 3;
end {if}
else
done := true;
until done or (token.kind = eofsy);
if doingPrototypes then begin
protoVariable := variable; {make the var available to Declarator}
if protoVariable = nil then
protoType := typeSpec
else
protoType := protoVariable^.iType;
end {if}
else begin
inhibitHeader := false;
if token.kind = semicolonch then {must end with a semicolon}
NextToken
else begin
Error(22);
SkipStatement;
end; {else}
end; {else}
end; {else}
1:
doingParameters := lDoingParameters; {restore the status}
useGlobalPool := lUseGlobalPool;
inhibitHeader := false;
end; {DoDeclaration}
procedure DoStatement;
{ process a statement from a function }
var
lToken: tokenType; {temporary copy of old token}
nToken: tokenType; {new token}
hasStatementNext: boolean; {is a stmt next within a compound stmt?}
lPrintMacroExpansions: boolean; {local copy of printMacroExpansions}
begin {DoStatement}
case statementList^.kind of
compoundSt: begin
hasStatementNext := true;
if token.kind = rbracech then begin
hasStatementNext := false;
EndCompoundStatement;
end {if}
else if (statementList^.doingDeclaration or allowMixedDeclarations)
and (token.kind in [autosy,externsy,registersy,staticsy,typedefsy,
unsignedsy,signedsy,intsy,longsy,charsy,shortsy,
floatsy,doublesy,compsy,extendedsy,enumsy,
structsy,unionsy,typedef,voidsy,volatilesy,
constsy])
then begin
hasStatementNext := false;
if token.kind <> typedef then
DoDeclaration(false, false)
else begin
lToken := token;
lPrintMacroExpansions := printMacroExpansions; {inhibit token echo}
printMacroExpansions := false;
NextToken;
printMacroExpansions := lPrintMacroExpansions;
nToken := token;
PutBackToken(nToken, false);
token := lToken;
if nToken.kind <> colonch then
DoDeclaration(false, false)
else
hasStatementNext := true;
end {else}
end; {else if}
if hasStatementNext then begin
if statementList^.doingDeclaration then begin
statementList^.doingDeclaration := false;
if firstCompoundStatement then begin
Gen1Name(dc_sym, ord(doingMain), pointer(table));
firstCompoundStatement := false;
end; {if}
end; {if}
Statement;
end; {else}
end;
ifSt:
EndIfStatement;
elseSt:
EndElseStatement;
doSt:
EndDoStatement;
whileSt:
EndWhileStatement;
forSt:
EndForStatement;
switchSt:
EndSwitchStatement;
otherwise: Error(57);
end; {case}
end; {DoStatement}
procedure AutoInit {variable: identPtr};
{ generate code to initialize an auto variable }
{ }
{ parameters: }
{ variable - the variable to initialize }
var
count: integer; {initializer counter}
iPtr: initializerPtr; {pointer to the next initializer}
procedure Initialize (id: identPtr; disp: longint; itype: typePtr);
{ initialize a variable }
{ }
{ parameters: }
{ id - pointer to the identifier }
{ disp - disp past the identifier to initialize }
{ itype - type of the variable to initialize }
{ }
{ variables: }
{ count - number of times to re-use the initializer }
{ ip - pointer to the initializer record to use }
label 1;
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}
while itype^.kind = definedType do
itype := itype^.dType;
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}
iPtr := variable^.iPtr;
count := iPtr^.count;
if variable^.class <> staticsy then
Initialize(variable, 0, variable^.itype);
end; {AutoInit}
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