Apple-2gs-SW/ORCA-C
1
0
Fork 0
mirror of https://github.com/byteworksinc/ORCA-C.git synced 2024-12-30 14:31:04 +00:00
Code Issues Projects Releases Wiki Activity
5476118951
ORCA-C/Parser.pas

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