Apple-2gs-SW/ORCA-C
1
0
Fork 0
mirror of https://github.com/byteworksinc/ORCA-C.git synced 2024-11-17 05:06:10 +00:00
Code Issues Projects Releases Wiki Activity
ff90151e77
ORCA-C/Parser.pas

4012 lines
144 KiB
ObjectPascal
Raw Normal View History

Change all text/source files to LF line endings.
2017-10-21 23:40:19 +00:00
{$optimize 1}
{---------------------------------------------------------------}
{ }
{ Parser }
{ }
{ External Subroutines: }
{ }
{ DoDeclaration - process a variable or function declaration }
{ DoStatement - process a statement from a function }
{ InitParser - initialize the parser }
{ Match - insure that the next token is of the specified type }
{ TermParser - shut down the parser }
{ TypeSpecifier - handle a type specifier }
{ }
{---------------------------------------------------------------}
unit Parser;
{$LibPrefix '0/obj/'}
interface
uses CCommon, Table, MM, CGI, Scanner, Header, Symbol, Expression, Asm;
{$segment 'parser'}
{---------------------------------------------------------------}
procedure DoDeclaration (doingPrototypes: boolean);
{ process a variable or function declaration }
{ }
{ parameters: }
{ doingPrototypes - are we processing a parameter list? }
procedure DoStatement;
{ process a statement from a function }
procedure InitParser;
{ Initialize the parser }
procedure Match (kind: tokenEnum; err: integer);
{ insure that the next token is of the specified type }
{ }
{ parameters: }
{ kind - expected token kind }
{ err - error number if the expected token is not found }
procedure TermParser;
{ shut down the parser }
procedure TypeSpecifier (doingFieldList,isConstant: boolean);
{ handle a type specifier }
{ }
{ parameters: }
{ doingFieldList - are we processing a field list? }
{ isConstant - did we already find a constsy? }
{---------------------------------------------------------------}
implementation
const
maxBitField = 32; {max # of bits in a bit field}
type
identList = ^identNode; {list of ids; used for initializers}
identNode = record
next: identList;
id: identPtr;
end;
{ The switch record is used to record the values for the }
{ switch jump table. The linked list of entries is in order }
{ of increasing switch value (val). }
switchPtr = ^switchRecord; {switch label table entry}
switchRecord = record
next,last: switchPtr; {doubly linked list (for inserts)}
lab: integer; {label to branch to}
val: longint; {switch value}
end;
{token stack}
{-----------}
tokenStackPtr = ^tokenStackRecord;
tokenStackRecord = record
next: tokenStackPtr;
token: tokenType;
end;
{statement stack}
{---------------}
statementPtr = ^statementRecord;
{kinds of nestable statements}
statementKind = (compoundSt,ifSt,elseSt,doSt,whileSt,forSt,switchSt);
statementRecord = record {element of the statement stack}
next: statementPtr; {next element on the stack}
breakLab, continueLab: integer; {branch points for break, continue}
case kind: statementKind of
compoundSt: (
doingDeclaration: boolean; {doing declarations? (or statements)}
);
ifSt: (
ifLab: integer; {branch point}
);
elseSt: (
elseLab: integer; {branch point}
);
doSt: (
doLab: integer; {branch point}
);
whileSt: (
whileTop: integer; {label at top of while loop}
whileEnd: integer; {label at bottom of while loop}
);
forSt: (
forLoop: integer; {branch here to loop}
e3List: tokenStackPtr; {tokens for last expression}
);
switchSt: (
maxVal: longint; {max switch value}
isLong: boolean; {do long switch?}
ln: integer; {temp var number}
size: integer; {temp var size}
labelCount: integer; {# of switch labels}
switchExit: integer; {branch point}
switchLab: integer; {branch point}
switchList: switchPtr; {list of labels and values}
switchDefault: integer; {default branch point}
);
end;
var
doingMain: boolean; {are we processing the main function?}
firstCompoundStatement: boolean; {are we doing a function level compound statement?}
fType: typePtr; {return type of the current function}
initializerList: identList; {list of initialized identifiers}
isForwardDeclared: boolean; {is the field list component }
{ referenceing a forward struct/union? }
isFunction: boolean; {is the declaration a function?}
isPascal: boolean; {has the pascal modifier been used?}
{ (set by DoDeclaration)}
returnLabel: integer; {label for exit point}
skipDeclarator: boolean; {for enum,struct,union with no declarator}
statementList: statementPtr; {list of open statements}
If 'volatile' is used within a function, only reduce optimization for that function. Previously, several optimizations would be disabled for the rest of the translation unit whenever the keyword 'volatile' appeared. Now, if 'volatile' is used within a function, it only reduces optimization for that function, since whatever was declared as 'volatile' will be out of scope after the function is over. Uses of 'volatile' outside functions still behave as before.
2017-07-12 05:28:11 +00:00
savedVolatile: boolean; {saved copy of volatile}
Change all text/source files to LF line endings.
2017-10-21 23:40:19 +00:00
{parameter processing variables}
{------------------------------}
lastParameter: identPtr; {next parameter to process}
numberOfParameters: integer; {number of indeclared parameters}
pfunc: identPtr; {func. for which parms are being defined}
protoType: typePtr; {type from a parameter list}
protoVariable: identPtr; {variable from a parameter list}
{type info for the current declaration}
{-------------------------------------}
storageClass: tokenEnum; {storage class of the declaration}
{ typeSpec: typePtr; (in CCommon) {type specifier}
{-- Parser Utility Procedures ----------------------------------}
procedure Match {kind: tokenEnum; err: integer};
{ insure that the next token is of the specified type }
{ }
{ parameters: }
{ kind - expected token kind }
{ err - error number if the expected token is not found }
begin {Match}
if token.kind = kind then
NextToken
else
Error(err);
end; {Match}
procedure SkipStatement;
{ Skip the remainder of the current statement }
var
bracketCount: integer; {for error skip}
begin {SkipStatement}
bracketCount := 0;
while (token.kind <> eofsy) and
((token.kind <> semicolonch) or (bracketCount <> 0)) do begin
if token.kind = lbrackch then
bracketCount := bracketCount+1;
if token.kind = rbrackch then
if bracketCount <> 0 then
bracketCount := bracketCount-1;
NextToken;
end; {while}
if token.kind = semicolonch then
NextToken;
end; {SkipStatement}
procedure GotoLabel (op: pcodes);
{ Find a label in the goto label list, creating one if one }
{ does not already exist. Generate the label or a jump to it }
{ based on op. }
{ }
{ paremeters: }
{ op - operation code to create }
label 1;
var
gt: gotoPtr; {work pointer}
begin {GotoLabel}
gt := gotoList; {try to find an existing label}
while gt <> nil do begin
if gt^.name^ = token.name^ then
goto 1;
gt := gt^.next;
end; {while}
gt := pointer(Malloc(sizeof(gotoRecord))); {no label record exists: create one}
gt^.next := gotoList;
gotoList := gt;
gt^.name := token.name;
gt^.lab := GenLabel;
gt^.defined := false;
1:
if op = dc_lab then begin
if gt^.defined then
Error(77)
else begin
gt^.defined := true;
Gen1(dc_lab, gt^.lab);
end; {else}
end {if}
else
Gen1(pc_ujp, gt^.lab);
end; {GotoLabel}
{-- Statements -------------------------------------------------}
procedure CompoundStatement (makeSymbols: boolean);
{ handle a compound statement }
{ }
{ Parameters: }
{ makeSymbols - create a symbol table? (False for a }
{ function's outer wrapper, true for imbeded statements) }
var
stPtr: statementPtr; {for creating a compound statement record}
begin {CompoundStatement}
Match(lbracech,27); {make sure there is an opening '{'}
new(stPtr); {create a statement record}
stPtr^.next := statementList;
statementList := stPtr;
stPtr^.kind := compoundSt;
if makeSymbols then {create a symbol table}
PushTable;
stPtr^.doingDeclaration := true; {allow declarations}
initializerList := nil; {no initializers, yet}
end; {CompoundStatement}
procedure EndCompoundStatement;
{ finish off a compound statement }
var
dumpLocal: boolean; {dump the local memory pool?}
tl: tempPtr; {work pointer}
stPtr: statementPtr; {work pointer}
begin {EndCompoundStatement}
dumpLocal := false;
stPtr := statementList; {pop the statement record}
statementList := stPtr^.next;
doingFunction := statementList <> nil; {see if we're done with the function}
if not doingFunction then begin {if so, finish it off}
Make the main function return 0 if execution reaches the closing brace of its body. This is required by C99 and later. It’s not required by C89, but it’s allowed and produces more predictable behavior.
2016-12-27 00:17:02 +00:00
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}
Change all text/source files to LF line endings.
2017-10-21 23:40:19 +00:00
Gen1(dc_lab, returnLabel);
with fType^ do {generate the pc_ret instruction}
case kind of
scalarType : Gen0t(pc_ret, baseType);
arrayType : ;
structType ,
unionType ,
pointerType : Gen0t(pc_ret, cgULong);
functionType: ;
enumConst : ;
enumType : Gen0t(pc_ret, cgWord);
definedType : ;
otherwise: Error(57);
end; {case}
Gen0 (dc_enp); {finish the segment}
CheckGotoList; {make sure all labels are declared}
while tempList <> nil do begin {dump the local labels}
tl := tempList;
tempList := tl^.next;
dispose(tl);
end; {while}
dumpLocal := true; {dump the local pool}
nameFound := false; {no pc_nam for the next function (yet)}
If 'volatile' is used within a function, only reduce optimization for that function. Previously, several optimizations would be disabled for the rest of the translation unit whenever the keyword 'volatile' appeared. Now, if 'volatile' is used within a function, it only reduces optimization for that function, since whatever was declared as 'volatile' will be out of scope after the function is over. Uses of 'volatile' outside functions still behave as before.
2017-07-12 05:28:11 +00:00
volatile := savedVolatile; {local volatile vars are out of scope}
Change all text/source files to LF line endings.
2017-10-21 23:40:19 +00:00
end; {if}
PopTable; {remove this symbol table}
dispose(stPtr); {dump the record}
if dumpLocal then begin
useGlobalPool := true; {start using the global memory pool}
LInit; {dispose of the local memory pool}
end; {if}
NextToken; {remove the rbracech token}
end; {EndCompoundStatement}
procedure Statement;
{ handle a statement }
label 1;
var
lToken,tToken: tokenType; {for look-ahead}
lPrintMacroExpansions: boolean; {local copy of printMacroExpansions}
function GetSwitchRecord: statementPtr;
{ Find the enclosing switch statement }
{ }
{ Returns a pointer to the closest switch statement record, }
{ or nil if there are none. }
label 1;
var
stPtr: statementPtr; {work pointer}
begin {GetSwitchRecord}
stPtr := statementList;
while stPtr <> nil do begin
if stPtr^.kind = switchSt then
goto 1;
stPtr := stPtr^.next;
end; {while}
1: GetSwitchRecord := stPtr;
end; {GetSwitchRecord}
procedure AssignmentStatement;
{ handle an asignment statement }
begin {AssignmentStatement}
if token.kind in startExpression then begin
Expression(normalExpression, [semicolonch]);
if expressionType^.baseType <> cgVoid then
Gen0t(pc_pop, UsualUnaryConversions);
if token.kind = semicolonch then
NextToken
else begin
Error(22);
SkipStatement;
end; {else}
end {if}
else begin
NextToken;
Error(92);
end; {else}
end; {AssignmentStatement}
procedure BreakStatement;
{ handle a break statement }
label 1,2;
var
stPtr: statementPtr; {work pointer}
begin {BreakStatement}
stPtr := statementList; {find the proper statement}
while stPtr <> nil do begin
if stPtr^.kind in [whileSt,doSt,forSt,switchSt] then
goto 1;
stPtr := stPtr^.next;
end; {while}
Error(76);
goto 2;
1: if stPtr^.breakLab = 0 then {if there is no break label, create one}
stPtr^.breakLab := GenLabel;
Gen1(pc_ujp, stPtr^.breakLab); {branch to the break label}
2:
NextToken; {skip the 'break' token}
Match(semicolonch,22); {insist on a closing ';'}
end; {BreakStatement}
procedure CaseStatement;
{ handle a case statement }
var
stPtr: statementPtr; {switch record for this case label}
swPtr,swPtr2: switchPtr; {work pointers for inserting new entry}
val: integer; {case label value}
begin {CaseStatement}
while token.kind = casesy do begin
NextToken; {skip the 'case' token}
stPtr := GetSwitchRecord; {get the proper switch record}
Expression(arrayExpression, [colonch]); {evaluate the branch condition}
val := long(expressionValue).lsw;
if val <> expressionValue then
if not stPtr^.isLong then
Allow case labels in switch statements that are out of range of the type being switched on. The case label values are converted to the promoted type of the expression being switched on, as if by a cast. In practice, this means discarding the high bits of a 32-bit value to produce a 16-bit one. Code requiring this is dubious and would be a good candidate for a warning or a lint error, but it's allowed under the C standards. The following code demonstrates the issue: #include <stdio.h> int main(void) { int i = 0x1234; switch (i) { case 0xABCD1234: puts("good"); break; default: puts("bad"); } }
2016-10-13 00:15:35 +00:00
expressionValue := val; {convert out-of-range value to (U)Word}
Change all text/source files to LF line endings.
2017-10-21 23:40:19 +00:00
if stPtr = nil then
Error(72)
else begin
new(swPtr2); {create the new label table entry}
swPtr2^.lab := GenLabel;
Gen1(dc_lab, swPtr2^.lab);
swPtr2^.val := expressionValue;
swPtr := stPtr^.switchList;
if swPtr = nil then begin {enter it in the table}
swPtr2^.last := nil;
swPtr2^.next := nil;
stPtr^.switchList := swPtr2;
stPtr^.maxVal := expressionValue;
stPtr^.labelCount := 1;
end {if}
else begin
while (swPtr^.next <> nil) and (swPtr^.val < expressionValue) do
swPtr := swPtr^.next;
if swPtr^.val = expressionValue then
Error(73)
else if swPtr^.val > expressionValue then begin
swPtr2^.next := swPtr;
if swPtr^.last = nil then
stPtr^.switchList := swPtr2
else
swPtr^.last^.next := swPtr2;
swPtr2^.last := swPtr^.last;
swPtr^.last := swPtr2;
end {else if}
else begin {at end of list}
swPtr2^.next := nil;
swPtr2^.last := swPtr;
swPtr^.next := swPtr2;
stPtr^.maxVal := expressionValue;
end; {else}
stPtr^.labelCount := stPtr^.labelCount + 1;
end; {else}
end; {else}
Match(colonch,29); {get the colon}
end; {while}
Statement; {process the labeled statement}
end; {CaseStatement}
procedure ContinueStatement;
{ handle a continue statement }
label 1,2;
var
stPtr: statementPtr; {work pointer}
begin {ContinueStatement}
stPtr := statementList; {find the proper statement}
while stPtr <> nil do begin
if stPtr^.kind in [whileSt,doSt,forSt] then
goto 1;
stPtr := stPtr^.next;
end; {while}
Error(75);
goto 2;
1: if stPtr^.continueLab = 0 then {if there is no continue label, create one}
stPtr^.continueLab := GenLabel;
Gen1(pc_ujp, stPtr^.continueLab); {branch to the continue label}
2:
NextToken; {skip the 'continue' token}
Match(semicolonch,22); {insist on a closing ';'}
end; {ContinueStatement}
procedure DefaultStatement;
{ handle a default statement }
var
stPtr: statementPtr; {work pointer}
begin {DefaultStatement}
NextToken; {skip the 'default' token}
Match(colonch,29); {get the colon}
stPtr := GetSwitchRecord; {record the presense of a default label}
if stPtr = nil then
Error(72)
else if stPtr^.switchDefault <> 0 then
Error(74)
else begin
stPtr^.switchDefault := GenLabel;
Gen1(dc_lab, stPtr^.switchDefault);
end; {else}
Statement; {process the labeled statement}
end; {DefaultStatement}
procedure DoStatement;
{ handle a do statement }
var
lab: integer; {branch label}
stPtr: statementPtr; {work pointer}
begin {DoStatement}
NextToken; {skip the 'do' token}
new(stPtr); {create a statement record}
stPtr^.next := statementList;
statementList := stPtr;
stPtr^.kind := doSt;
lab := GenLabel; {create the branch label}
Gen1(dc_lab, lab);
stPtr^.doLab := lab;
stPtr^.breakLab := 0;
stPtr^.continueLab := 0;
Statement; {process the first loop body statement}
end; {DoStatement}
procedure ForStatement;
{ handle a for statement }
var
errorFound: boolean; {did we find an error?}
forLoop, continueLab, breakLab: integer; {branch points}
lType: typePtr; {type of "left" expression}
parencount: integer; {number of unmatched '(' chars}
stPtr: statementPtr; {work pointer}
tl,tk: tokenStackPtr; {for forming expression list}
begin {ForStatement}
NextToken; {skip the 'for' token}
new(stPtr); {create a statement record}
stPtr^.next := statementList;
statementList := stPtr;
stPtr^.kind := forSt;
forLoop := GenLabel; {create the branch labels}
continueLab := GenLabel;
breakLab := GenLabel;
stPtr^.forLoop := forLoop;
stPtr^.continueLab := continueLab;
stPtr^.breakLab := breakLab;
Match(lparench,13); {evaluate the start condition}
if token.kind <> semicolonch then begin
Expression(normalExpression, [semicolonch]);
Gen0t(pc_pop, UsualUnaryConversions);
end; {if}
Match(semicolonch,22);
Gen1(dc_lab, forLoop); {this label points to the condition}
if token.kind <> semicolonch then {handle the loop test}
begin {evaluate the expression}
Expression(normalExpression, [semicolonch]);
CompareToZero(pc_neq); {Evaluate the condition}
Gen1(pc_fjp, breakLab);
end; {if}
Match(semicolonch,22);
tl := nil; {collect the tokens for the last expression}
parencount := 0;
errorFound := false;
while (token.kind <> eofsy)
and ((token.kind <> rparench) or (parencount <> 0))
and (token.kind <> semicolonch) do begin
new(tk); {place the token in the list}
tk^.next := tl;
tl := tk;
tk^.token := token;
if token.kind = lparench then {allow parens in the expression}
parencount := parencount+1
else if token.kind = rparench then
parencount := parencount-1;
NextToken; {next token}
end; {while}
if errorFound then {if an error was found, dump the list}
while tl <> nil do begin
tk := tl;
tl := tl^.next;
dispose(tk);
end; {while}
stPtr^.e3List := tl; {save the list}
Match(rparench,12); {get the closing for loop paren}
Statement; {process the first loop body statement}
end; {ForStatement}
procedure IfStatement;
{ handle an if statement }
var
lab: integer; {branch label}
lType: typePtr; {type of "left" expression}
stPtr: statementPtr; {work pointer}
begin {IfStatement}
NextToken; {skip the 'if' token}
Match(lparench, 13); {evaluate the condition}
Expression(normalExpression, [rparench]);
Match(rparench, 12);
lab := GenLabel; {create the branch label}
CompareToZero(pc_neq); {evaluate the condition}
Gen1(pc_fjp, lab);
new(stPtr); {create a statement record}
stPtr^.next := statementList;
statementList := stPtr;
stPtr^.kind := ifSt;
stPtr^.ifLab := lab;
Statement; {process the 'true' statement}
end; {IfStatement}
procedure GotoStatement;
{ handle a goto statement }
begin {GotoStatement}
NextToken; {skip the 'goto' token}
if token.kind in [ident,typedef] then begin
GotoLabel(pc_ujp); {jump to the label}
NextToken; {skip the token}
end {if}
else
Error(9); {flag the error}
Match(semicolonch, 22); {insist on a closing ';'}
end; {GotoStatement}
procedure LabelStatement;
{ handle a labeled statement }
begin {LabelStatement}
GotoLabel(dc_lab); {define the label}
NextToken; {skip the label}
if token.kind = colonch then {if present, skip the colon}
NextToken
else begin {bad statement - flag error and skip it}
Error(31);
SkipStatement;
end; {else}
end; {LabelStatement}
procedure ReturnStatement;
{ handle a return statement }
var
id: identPtr; {structure id}
size: longint; {size of the struct/union}
tk: tokenType; {structure name token}
begin {ReturnStatement}
NextToken; {skip the 'return' token}
if token.kind <> semicolonch then {if present, evaluate the return value}
begin
if fType^.kind in [structType,unionType] then begin
tk.kind := ident;
tk.class := identifier;
tk.name := @'@struct';
tk.symbolPtr := nil;
id := FindSymbol(tk, variableSpace, false, true);
Gen1Name(pc_lao, 0, id^.name);
size := fType^.size;
end; {if}
Expression(normalExpression, [semicolonch]);
AssignmentConversion(fType, expressionType, lastWasConst, lastConst,
Don't give an error when calling functions with const-qualified parameter types or returning from functions with const-qualified return type. This fixes the compco12.c test case.
2016-12-14 03:46:11 +00:00
true, false);
Change all text/source files to LF line endings.
2017-10-21 23:40:19 +00:00
case fType^.kind of
scalarType: Gen2t(pc_str, 0, 0, fType^.baseType);
enumType: Gen2t(pc_str, 0, 0, cgWord);
pointerType: Gen2t(pc_str, 0, 0, cgULong);
structType,
unionType: begin
Gen2(pc_mov, long(size).msw, long(size).lsw);
Gen0t(pc_pop, cgULong);
end;
otherwise: ;
end; {case}
end; {if}
Gen1(pc_ujp, returnLabel); {branch to the exit point}
Match(semicolonch, 22); {insist on a closing ';'}
end; {ReturnStatement}
procedure SwitchStatement;
{ handle a switch statement }
var
stPtr: statementPtr; {work pointer}
tp: typePtr; {for checking type}
begin {SwitchStatement}
NextToken; {skip the 'switch' token}
new(stPtr); {create a statement record}
stPtr^.next := statementList;
statementList := stPtr;
stPtr^.kind := switchSt;
stPtr^.maxVal := -maxint4;
stPtr^.isLong := false;
stPtr^.labelCount := 0;
stPtr^.switchLab := GenLabel;
stPtr^.switchExit := GenLabel;
stPtr^.breakLab := stPtr^.switchExit;
stPtr^.switchList := nil;
stPtr^.switchDefault := 0;
Match(lparench, 13); {evaluate the condition}
Expression(normalExpression,[rparench]);
Match(rparench, 12);
tp := expressionType; {make sure the expression is integral}
while tp^.kind = definedType do
tp := tp^.dType;
case tp^.kind of
scalarType:
if tp^.baseType in [cgLong,cgULong] then begin
stPtr^.isLong := true;
stPtr^.size := cgLongSize;
stPtr^.ln := GetTemp(cgLongSize);
Gen2t(pc_str, stPtr^.ln, 0, cgLong);
end {if}
else if tp^.baseType in [cgByte,cgUByte,cgWord,cgUWord] then begin
stPtr^.isLong := false;
stPtr^.size := cgWordSize;
stPtr^.ln := GetTemp(cgWordSize);
Gen2t(pc_str, stPtr^.ln, 0, cgWord);
end {else if}
else
Error(71);
enumType: begin
stPtr^.isLong := false;
stPtr^.size := cgWordSize;
stPtr^.ln := GetTemp(cgWordSize);
Gen2t(pc_str, stPtr^.ln, 0, cgWord);
end;
otherwise:
Error(71);
end; {case}
Gen1(pc_ujp, stPtr^.switchLab); {branch to the xjp instruction}
Statement; {process the loop body statement}
end; {SwitchStatement}
procedure WhileStatement;
{ handle a while statement }
var
lType: typePtr; {type of "left" expression}
stPtr: statementPtr; {work pointer}
top, endl: integer; {branch points}
begin {WhileStatement}
NextToken; {skip the 'while' token}
new(stPtr); {create a statement record}
stPtr^.next := statementList;
statementList := stPtr;
stPtr^.kind := whileSt;
top := GenLabel; {create the branch labels}
endl := GenLabel;
stPtr^.whileTop := top;
stPtr^.whileEnd := endl;
stPtr^.breakLab := endl;
stPtr^.continueLab := top;
Gen1(dc_lab, top); {define the top label}
Match(lparench, 13); {evaluate the condition}
Expression(normalExpression, [rparench]);
Match(rparench, 12);
CompareToZero(pc_neq); {evaluate the condition}
Gen1(pc_fjp, endl);
Statement; {process the first loop body statement}
end; {WhileStatement}
begin {Statement}
1:
{if trace names are enabled and a line # is due, generate it}
if traceBack or debugFlag then
if nameFound or debugFlag then
if lastLine <> lineNumber then begin
lastLine := lineNumber;
Gen2(pc_lnm, lineNumber, ord(debugType));
end; {if}
{handle the statement}
case token.kind of
asmsy: begin
NextToken;
AsmStatement;
end;
breaksy: BreakStatement;
casesy: CaseStatement;
continuesy: ContinueStatement;
defaultsy: DefaultStatement;
dosy: DoStatement;
elsesy: begin Error(25); SkipStatement; end;
forsy: ForStatement;
gotosy: GotoStatement;
typedef,
ident: begin
lPrintMacroExpansions := printMacroExpansions;
printMacroExpansions := false;
lToken := token;
NextToken;
tToken := token;
PutBackToken(token, true);
token := lToken;
printMacroExpansions := lPrintMacroExpansions;
if tToken.kind = colonch then begin
LabelStatement;
goto 1;
end {if}
else
AssignmentStatement;
end;
ifsy: IfStatement;
lbracech: CompoundStatement(true);
returnsy: ReturnStatement;
semicolonch: NextToken;
switchsy: SwitchStatement;
whilesy: WhileStatement;
otherwise: AssignmentStatement;
end; {case}
end; {Statement}
procedure EndDoStatement;
{ finish off a do statement }
var
lType: typePtr; {type of "left" expression}
stPtr: statementPtr; {work pointer}
begin {EndDoStatement}
stPtr := statementList; {get the statement record}
if token.kind = whilesy then begin {if a while clause exists, process it}
NextToken; {skip the 'while' token}
if stPtr^.continueLab <> 0 then {create the continue label}
Gen1(dc_lab, stPtr^.continueLab);
Match(lparench, 13); {evaluate the condition}
Expression(normalExpression, [rparench]);
Match(rparench, 12);
CompareToZero(pc_equ); {evaluate the condition}
Gen1(pc_fjp, stPtr^.doLab);
Match(semicolonch, 22); {process the closing ';'}
end {if}
else
Error(30); {'while' expected}
if stPtr^.breakLab <> 0 then {create the break label}
Gen1(dc_lab, stPtr^.breakLab);
statementList := stPtr^.next; {pop the statement record}
dispose(stPtr);
end; {EndDoStatement}
procedure EndIfStatement;
{ finish off an if statement }
var
lab1,lab2: integer; {branch labels}
stPtr: statementPtr; {work pointer}
begin {EndIfStatement}
stPtr := statementList; {get the label to branch to}
lab1 := stPtr^.ifLab;
statementList := stPtr^.next; {pop the statement record}
dispose(stPtr);
if token.kind = elsesy then begin {if an else clause exists, process it}
NextToken; {skip 'else'}
lab2 := GenLabel; {create the branch label}
Gen1(pc_ujp, lab2); {branch past the else clause}
Gen1(dc_lab, lab1); {create label for if to branch to}
new(stPtr); {create a statement record}
stPtr^.next := statementList;
statementList := stPtr;
stPtr^.kind := elseSt;
stPtr^.elseLab := lab2;
Statement; {evaluate the else clause}
end {if}
else
Gen1(dc_lab, lab1); {create label for if to branch to}
end; {EndIfStatement}
procedure EndElseStatement;
{ finish off an else clause }
var
stPtr: statementPtr; {work pointer}
begin {EndElseStatement}
stPtr := statementList; {create the label to branch to}
Gen1(dc_lab, stPtr^.elseLab);
statementList := stPtr^.next; {pop the statement record}
dispose(stPtr);
end; {EndElseStatement}
procedure EndForStatement;
{ finish off a for statement }
var
ltoken: tokenType; {for putting ; on stack}
stPtr: statementPtr; {work pointer}
tl,tk: tokenStackPtr; {for forming expression list}
lPrintMacroExpansions: boolean; {local copy of printMacroExpansions}
begin {EndForStatement}
stPtr := statementList;
Gen1(dc_lab, stPtr^.continueLab); {define the continue label}
tl := stPtr^.e3List; {place the expression back in the list}
if tl <> nil then begin
PutBackToken(token, false);
ltoken.kind := semicolonch;
ltoken.class := reservedSymbol;
PutBackToken(ltoken, false);
while tl <> nil do begin
PutBackToken(tl^.token, false);
tk := tl;
tl := tl^.next;
dispose(tk);
end; {while}
lPrintMacroExpansions := printMacroExpansions; {inhibit token echo}
printMacroExpansions := false;
NextToken; {evaluate the expression}
Expression(normalExpression, [semicolonch]);
Gen0t(pc_pop, UsualUnaryConversions);
NextToken; {skip the seminolon}
printMacroExpansions := lPrintMacroExpansions;
end; {if}
Gen1(pc_ujp, stPtr^.forLoop); {loop to the test}
Gen1(dc_lab, stPtr^.breakLab); {create the exit label}
statementList := stPtr^.next; {pop the statement record}
dispose(stPtr);
end; {EndForStatement}
procedure EndSwitchStatement;
{ finish off a switch statement }
const
sparse = 5; {label to tableSize ratio for sparse table}
var
default: integer; {default label}
ltp: baseTypeEnum; {base type}
minVal: integer; {min switch value}
stPtr: statementPtr; {work pointer}
{copies of vars (for efficiency)}
{-------------------------------}
exitLab: integer; {label at the end of the jump table}
isLong: boolean; {is the case expression long?}
swPtr,swPtr2: switchPtr; {switch label table list}
begin {EndSwitchStatement}
stPtr := statementList; {get the statement record}
exitLab := stPtr^.switchExit; {get the exit label}
isLong := stPtr^.isLong; {get the long flag}
swPtr := stPtr^.switchList; {Skip further generation if there were}
if swPtr <> nil then begin { no labels. }
default := stPtr^.switchDefault; {get a default label}
if default = 0 then
default := exitLab;
Gen1(pc_ujp, exitLab); {branch past the indexed jump}
Gen1(dc_lab, stPtr^.switchLab); {create the label for the xjp table}
if isLong then {decide on a base type}
ltp := cgLong
else
ltp := cgWord;
if stPtr^.isLong
or (((stPtr^.maxVal-swPtr^.val) div stPtr^.labelCount) > sparse) then
begin
{Long expressions and sparse switch statements are handled as a }
{series of if-goto tests. }
while swPtr <> nil do begin {generate the compares}
if isLong then
GenLdcLong(swPtr^.val)
else
Gen1t(pc_ldc, long(swPtr^.val).lsw, cgWord);
Gen2t(pc_lod, stPtr^.ln, 0, ltp);
Gen0t(pc_equ, ltp);
Gen1(pc_tjp, swPtr^.lab);
swPtr2 := swPtr;
swPtr := swPtr^.next;
dispose(swPtr2);
end; {while}
Gen1(pc_ujp, default); {anything else goes to default}
end {if}
else begin
{compact word switch statements are handled with xjp}
minVal := long(swPtr^.val).lsw; {record the min label value}
Gen2t(pc_lod, stPtr^.ln, 0, ltp); {get the value}
Gen1t(pc_dec, minVal, cgWord); {adjust the range}
Gen1(pc_xjp, ord(stPtr^.maxVal-minVal+1)); {do the indexed jump}
while swPtr <> nil do begin {generate the jump table}
while minVal < swPtr^.val do begin
Gen1(pc_add, default);
minVal := minVal+1;
end; {while}
minVal := minVal+1;
Gen1(pc_add, swPtr^.lab);
swPtr2 := swPtr;
swPtr := swPtr^.next;
dispose(swPtr2);
end; {while}
Gen1(pc_add, default);
end; {if}
Gen1(dc_lab, exitLab); {generate the default label}
end {if}
else begin
Gen1(pc_ujp, exitLab); {branch past the indexed jump}
Gen1(dc_lab, stPtr^.switchLab); {create the label for the xjp table}
default := stPtr^.switchDefault; {if there is one, jump to the default label}
if default <> 0 then
Gen1(pc_ujp, default);
Gen1(dc_lab, exitLab); {generate the default label}
end; {else}
FreeTemp(stPtr^.ln, stPtr^.size); {release temp variable}
statementList := stPtr^.next; {pop the statement record}
dispose(stPtr);
end; {EndSwitchStatement}
procedure EndWhileStatement;
{ finish off a while statement }
var
stPtr: statementPtr; {work pointer}
begin {EndWhileStatement}
stPtr := statementList; {loop to the test}
Gen1(pc_ujp, stPtr^.whileTop);
Gen1(dc_lab, stPtr^.whileEnd); {create the exit label}
statementList := stPtr^.next; {pop the statement record}
dispose(stPtr);
end; {EndWhileStatement}
{-- Type declarations ------------------------------------------}
procedure Declarator(tPtr: typePtr; var variable: identPtr; space: spaceType;
doingPrototypes: boolean);
{ handle a declarator }
{ }
{ parameters: }
{ tPtr - pointer to the type to use }
{ variable - pointer to variable being defined }
{ space - variable space to use }
{ doingPrototypes - are we compiling prototype parameter }
{ declarations? }
label 1;
type
typeDefPtr = ^typeDefRecord; {for stacking type records}
typeDefRecord = record
next: typeDefPtr;
typeDef: typePtr;
end;
pointerListPtr = ^pointerList; {for stacking pointer types}
pointerList = record
next: pointerListPtr;
isConstant: boolean;
end;
var
i: integer; {loop variable}
lastWasIdentifier: boolean; {for deciding if the declarator is a fuction}
lastWasPointer: boolean; {was the last type a pointer?}
newName: stringPtr; {new symbol name}
parameterStorage: boolean; {is the new symbol in a parm list?}
state: stateKind; {declaration state of the variable}
tPtr2: typePtr; {work pointer}
tsPtr: typeDefPtr; {work pointer}
typeStack: typeDefPtr; {stack of type definitions}
varParmList: boolean; {did we prototype a variable?}
Don't erroneously pop the symbol table at declarations of a pointer to a typedef'd function type. This problem could cause "duplicate symbol" and "undeclared identifier" errors, for example in the following program: typedef int f1( void ); void bar( void ) { int i; f1 *foo; int baz; i = 10; } int foo; long baz;
2017-06-21 05:20:35 +00:00
firstIteration: boolean; {first iteration of type-unstacking loop?}
Change all text/source files to LF line endings.
2017-10-21 23:40:19 +00:00
{for checking function compatibility}
{-----------------------------------}
checkParms: boolean; {do we need to do type checking on the parm?}
compatible: boolean; {are the parameters compatible?}
ftoken: tokenType; {for checking extern functions}
p1,p2,p3: parameterPtr; {used to trace parameter lists}
pt1,pt2: typePtr; {parameter types}
t1: typePtr; {function type}
tk1,tk2: typeKind; {parameter type kinds}
unnamedParm: boolean; {is this an unnamed prototype?}
procedure StackDeclarations (var varParmList: boolean);
{ stack the declaration operators }
{ }
{ Parameters: }
{ varParmList - did we create one? }
var
cp,cpList: pointerListPtr; {pointer list}
done,done2: boolean; {for loop termination}
isPtr: boolean; {is the parenthesized expr a ptr?}
Allow a typedef'd version of "void" to be used in the parameter list of a function taking no arguments. For example, the following is now allowed: typedef void v; void foo(v) {} This appears to be permitted under at least C99 and C11 (the C89 wording is less clear), and is accepted by other modern compilers.
2017-09-10 19:55:08 +00:00
isVoid: boolean; {is the type specifier void?}
Change all text/source files to LF line endings.
2017-10-21 23:40:19 +00:00
wp: parameterPtr; {used to build prototype var list}
pvar: identPtr; {work pointer}
tPtr2: typePtr; {work pointer}
ttPtr: typeDefPtr; {work pointer}
parencount: integer; {for skipping in parm list}
lvarParmList: boolean; {did we prototype a variable?}
{variables used to preserve states}
{ across recursive calls }
{---------------------------------}
lisFunction: boolean; {local copy of isFunction}
lisPascal: boolean; {local copy of isPascal}
lLastParameter: identPtr; {next parameter to process}
lstorageClass: tokenEnum; {storage class of the declaration}
ltypeSpec: typePtr; {type specifier}
luseGlobalPool: boolean; {local copy of useGlobalPool}
lPrintMacroExpansions: boolean; {local copy of printMacroExpansions}
begin {StackDeclarations}
varParmList := false; {no var parm list, yet}
lastWasIdentifier := false; {used to see if the declaration is a fn}
cpList := nil;
if token.kind = typedef then
token.kind := ident;
case token.kind of
ident: begin {handle 'ident'}
if space = fieldListSpace then
variable := nil
else
variable := FindSymbol(token, space, true, true);
newName := token.name;
if variable = nil then begin
if storageClass = typedefsy then begin
tPtr2 := pointer(Calloc(sizeof(typeRecord)));
{tPtr2^.size := 0;}
{tPtr2^.saveDisp := 0;}
tPtr2^.kind := definedType;
{tPtr^.isConstant := false;}
tPtr2^.dType := tPtr;
end {if}
else
tPtr2 := tPtr;
if doingParameters then begin
if not doingPrototypes then
if not (tPtr2^.kind in
[enumConst,structType,unionType,definedType,pointerType])
then Error(50);
parameterStorage := true;
end; {if}
end {if}
else
checkParms := true;
NextToken;
if token.kind = eqch then
state := initialized;
lastWasIdentifier := true;
end;
asteriskch: begin {handle '*' 'declarator'}
while token.kind = asteriskch do begin
NextToken;
new(cp);
cp^.next := cpList;
cpList := cp;
cp^.isConstant := false;
while token.kind in
[unsignedsy,signedsy,intsy,longsy,charsy,shortsy,floatsy,
doublesy,compsy,extendedsy,voidsy,enumsy,structsy,unionsy,
volatilesy,constsy] do begin
if token.kind = constsy then
cpList^.isConstant := true
else if token.kind = volatilesy then
volatile := true
else
Error(9);
NextToken;
end; {while}
end; {while}
StackDeclarations(lvarParmList);
end;
lparench: begin {handle '(' 'declarator' ')'}
NextToken;
isPtr := token.kind = asteriskch;
StackDeclarations(lvarParmList);
Match(rparench,12);
if isPtr then
lastWasIdentifier := false;
end;
otherwise:
if doingPrototypes then begin {allow for unnamed parameters}
pvar := pointer(Calloc(sizeof(identRecord)));
{pvar^.next := nil;}
{pvar^.saved := 0;}
pvar^.name := @'?';
pvar^.itype := tPtr;
{pvar^.disp := 0;}
{pvar^.bitDisp := 0;}
{pvar^.bitsize := 0;}
{pvar^.initialized := false;}
{pvar^.iPtr := nil;}
{pvar^.isForwardDeclared := false;}
pvar^.class := autosy;
pvar^.storage := parameter;
variable := pvar;
lastWasIdentifier := true;
newName := nil;
unnamedParm := true;
end; {if}
end; {case}
while token.kind in [lparench,lbrackch] do begin
{handle function declarations}
if token.kind = lparench then begin
lisPascal := isPascal; {preserve this flag}
PushTable; {create a symbol table}
{determine if it's a function}
isFunction := lastWasIdentifier or isFunction;
varParmList := not isFunction;
tPtr2 := pointer(GCalloc(sizeof(typeRecord))); {create the function type}
{tPtr2^.size := 0;}
{tPtr2^.saveDisp := 0;}
tPtr2^.kind := functionType;
{tPtr2^.isConstant := false;}
{tPtr2^.varargs := false;}
{tPtr2^.prototyped := false;}
{tPtr2^.overrideKR := false;}
{tPtr2^.parameterList := nil;}
{tPtr2^.isPascal := false;}
{tPtr2^.toolNum := 0;}
{tPtr2^.dispatcher := 0;}
new(ttPtr);
ttPtr^.next := typeStack;
typeStack := ttPtr;
ttPtr^.typeDef := tPtr2;
NextToken; {skip the '(' token}
Allow a typedef'd version of "void" to be used in the parameter list of a function taking no arguments. For example, the following is now allowed: typedef void v; void foo(v) {} This appears to be permitted under at least C99 and C11 (the C89 wording is less clear), and is accepted by other modern compilers.
2017-09-10 19:55:08 +00:00
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}
Change all text/source files to LF line endings.
2017-10-21 23:40:19 +00:00
lPrintMacroExpansions := printMacroExpansions;
printMacroExpansions := false;
NextToken;
printMacroExpansions := lPrintMacroExpansions;
if token.kind = rparench then begin
PutBackToken(token, false);
NextToken;
tPtr2^.prototyped := true;
end
else begin
PutBackToken(token, false);
token.kind := voidsy;
token.class := reservedSymbol;
end; {else}
end; {if}
if token.kind in {see if we are doing a prototyped list}
[autosy,externsy,registersy,staticsy,typedefsy,unsignedsy,intsy,
longsy,charsy,shortsy,floatsy,doublesy,compsy,extendedsy,voidsy,
enumsy,structsy,unionsy,typedef,signedsy,constsy] then begin
{handle a prototype variable list}
numberOfParameters := 0; {don't allow K&R parm declarations}
luseGlobalPool := useGlobalPool; {use global memory}
useGlobalPool := true;
done2 := false;
lisFunction := isFunction; {preserve global variables}
ltypeSpec := typeSpec;
lstorageClass := storageClass;
with tPtr2^ do begin
prototyped := true; {it is prototyped}
repeat {collect the declarations}
if (token.kind in [autosy,externsy,registersy,staticsy,
typedefsy,unsignedsy,signedsy,intsy,longsy,
charsy,shortsy,floatsy,doublesy,compsy,
extendedsy,enumsy,structsy,unionsy,
typedef,voidsy,volatilesy,constsy])
then begin
lLastParameter := lastParameter;
DoDeclaration(true);
lastParameter := lLastParameter;
if protoType <> nil then begin
wp := pointer(Malloc(sizeof(parameterRecord)));
wp^.next := parameterList;
parameterList := wp;
wp^.parameter := protoVariable;
wp^.parameterType := protoType;
if protoVariable <> nil then begin
protoVariable^.pnext := lastParameter;
lastParameter := protoVariable;
end; {if}
end; {if}
if token.kind = commach then begin
NextToken;
if token.kind = dotch then begin
NextToken;
Match(dotch,89);
Match(dotch,89);
varargs := true;
done2 := true;
end; {if}
end {if}
else
done2 := true;
end {if}
else begin
Error(26);
parencount := 0;
while (token.kind <> eofsy)
and ((parencount > 0) or (token.kind <> rparench)) do
begin
if token.kind = rparench then
parencount := parencount-1
else if token.kind = lparench then
parencount := parencount+1;
NextToken;
end; {while}
done2 := true;
end; {else}
until done2;
end; {with}
isFunction := lisFunction; {restore global variables}
storageClass := lstorageClass;
typeSpec := ltypeSpec;
useGlobalPool := luseGlobalPool;
end {if prototype}
else if token.kind = ident then begin
{handle a K&R variable list}
if (lint & lintNotPrototyped) <> 0 then
Error(105);
if doingFunction or doingPrototypes then
Error(12)
else begin
numberOfParameters := 0; {no function parms yet}
end; {else}
repeat {make a list of parameters}
if not doingFunction then begin
if token.kind <> ident then begin
Error(9);
while not (token.kind in [rparench,commach,ident]) do
NextToken;
end; {if}
if token.kind = ident then begin
pvar := NewSymbol(token.name, nil, ident, variableSpace,
declared);
pvar^.storage := parameter;
pvar^.pnext := lastParameter;
lastParameter := pvar;
numberOfParameters := numberOfParameters+1;
pvar^.bitdisp := numberOfParameters;
NextToken;
end; {if}
end; {if}
if token.kind = commach then begin
NextToken;
done := false;
end {if}
else
done := true;
until done or (token.kind = eofsy);
end {else if}
else if (lint & lintNotPrototyped) <> 0 then
if not tPtr2^.prototyped then
Error(105);
Match(rparench,12); {insist on a closing ')' token}
isPascal := lisPascal; {restore this flag}
end {if}
{handle array declarations}
else {if token.kind = lbrackch then} begin
lastWasIdentifier := false;
tPtr2 := pointer(Calloc(sizeof(typeRecord)));
{tPtr2^.size := 0;}
{tPtr2^.saveDisp := 0;}
{tPtr2^.isConstant := false;}
tPtr2^.kind := arrayType;
{tPtr2^.elements := 0;}
new(ttPtr);
ttPtr^.next := typeStack;
typeStack := ttPtr;
ttPtr^.typeDef := tPtr2;
NextToken;
if token.kind <> rbrackch then begin
Expression(arrayExpression, [rbrackch,semicolonch]);
if expressionValue <= 0 then begin
Error(45);
expressionValue := 1;
end; {if}
tPtr2^.elements := expressionValue;
end; {if}
Match(rbrackch,24);
end; {else if}
end; {while}
{stack pointer type records}
while cpList <> nil do begin
tPtr2 := pointer(Malloc(sizeof(typeRecord)));
tPtr2^.size := cgPointerSize;
tPtr2^.saveDisp := 0;
tPtr2^.isConstant := cpList^.isConstant;
tPtr2^.kind := pointerType;
new(ttPtr);
ttPtr^.next := typeStack;
typeStack := ttPtr;
ttPtr^.typeDef := tPtr2;
cp := cpList;
cpList := cp^.next;
dispose(cp);
end; {for}
end; {StackDeclarations}
begin {Declarator}
newName := nil; {no identifier, yet}
unnamedParm := false; {not an unnamed parameter}
if storageClass = externsy then {decide on a storage state}
state := declared
else
state := defined;
typeStack := nil; {no types so far}
parameterStorage := false; {symbol is not in a parameter list}
checkParms := false; {assume we won't need to check for parameter type errors}
StackDeclarations(varParmList); {stack the type records}
Don't erroneously pop the symbol table at declarations of a pointer to a typedef'd function type. This problem could cause "duplicate symbol" and "undeclared identifier" errors, for example in the following program: typedef int f1( void ); void bar( void ) { int i; f1 *foo; int baz; i = 10; } int foo; long baz;
2017-06-21 05:20:35 +00:00
firstIteration := true;
Change all text/source files to LF line endings.
2017-10-21 23:40:19 +00:00
while typeStack <> nil do begin {reverse the type stack}
tsPtr := typeStack;
typeStack := tsPtr^.next;
if isFunction and (not useGlobalPool) then begin
tPtr2 := pointer(GMalloc(sizeof(typeRecord)));
tPtr2^ := tsPtr^.typeDef^;
tPtr2^.saveDisp := 0;
end {if}
else
tPtr2 := tsPtr^.typeDef;
dispose(tsPtr);
if tPtr^.kind = functionType then
Don't erroneously pop the symbol table at declarations of a pointer to a typedef'd function type. This problem could cause "duplicate symbol" and "undeclared identifier" errors, for example in the following program: typedef int f1( void ); void bar( void ) { int i; f1 *foo; int baz; i = 10; } int foo; long baz;
2017-06-21 05:20:35 +00:00
if not firstIteration then
PopTable; {balance push in StackDeclarations}
Change all text/source files to LF line endings.
2017-10-21 23:40:19 +00:00
case tPtr2^.kind of
pointerType: begin
tPtr2^.pType := tPtr;
end;
functionType: begin
while tPtr^.kind = definedType do
tPtr := tPtr^.dType;
tPtr2^.fType := tPtr;
if tPtr^.kind in [functionType,arrayType] then
Error(103);
end;
arrayType: begin
tPtr2^.size := tPtr^.size * tPtr2^.elements;
tPtr2^.aType := tPtr;
end;
otherwise: ;
end; {case}
tPtr := tPtr2;
Don't erroneously pop the symbol table at declarations of a pointer to a typedef'd function type. This problem could cause "duplicate symbol" and "undeclared identifier" errors, for example in the following program: typedef int f1( void ); void bar( void ) { int i; f1 *foo; int baz; i = 10; } int foo; long baz;
2017-06-21 05:20:35 +00:00
firstIteration := false;
Change all text/source files to LF line endings.
2017-10-21 23:40:19 +00:00
end; {while}
if checkParms then begin {check for parameter type conflicts}
with variable^ do begin
if doingParameters then begin
if itype = nil then begin
itype := tPtr;
numberOfParameters := numberOfParameters-1;
if pfunc^.itype^.prototyped then begin
pfunc^.itype^.overrideKR := true;
p1 := nil;
for i := 1 to bitdisp do begin
p2 := pfunc^.itype^.parameterList;
while (p2^.next <> p1) and (p2 <> nil) do
p2 := p2^.next;
p1 := p2;
end; {for}
compatible := false;
if CompTypes(p1^.parameterType, tPtr) then
compatible := true
else begin
tk1 := p1^.parameterType^.kind;
tk2 := tPtr^.kind;
if (tk1 = arrayType) and (tk2 = pointerType) then
compatible :=
CompTypes(p1^.parameterType^.aType, tPtr^.pType)
else if (tk1 = pointerType) and (tk2 = arrayType) then
compatible :=
CompTypes(p1^.parameterType^.pType, tPtr^.aType);
end; {else}
if not compatible then
Error(47);
end; {if}
end {if}
else
Error(42);
storage := parameter;
parameterStorage := true;
end; {if}
end; {with}
end {if}
else if doingParameters then
if pfunc^.itype^.prototyped then
if not doingPrototypes then
if tPtr^.kind in
[enumConst,structType,unionType,definedType,pointerType]
then Error(50);
if tPtr^.kind = functionType then begin {declare the identifier}
if variable <> nil then begin
t1 := variable^.itype;
if CompTypes(t1, tPtr) then begin
if t1^.prototyped and tPtr^.prototyped then begin
p2 := tptr^.parameterList;
if isPascal then begin
{reverse the parameter list}
p1 := nil;
while p2 <> nil do begin
p3 := p2;
p2 := p2^.next;
p3^.next := p1;
p1 := p3;
end; {while}
tPtr^.parameterList := p1;
end; {if}
p2 := tPtr^.parameterList;
p1 := t1^.parameterList;
while (p1 <> nil) and (p2 <> nil) do begin
if p1^.parameter = nil then
pt1 := p1^.parameterType
else
pt1 := p1^.parameter^.itype;
if p2^.parameter = nil then
pt2 := p2^.parameterType
else
pt2 := p2^.parameter^.itype;
Treat array types as compatible with corresponding pointer types in function prototypes. This permits code like the following to compile, as it should: int foo(int*); int foo(int[]); int foo(int[42]);
2017-06-20 23:45:33 +00:00
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
Change all text/source files to LF line endings.
2017-10-21 23:40:19 +00:00
Error(47);
goto 1;
end; {if}
p1 := p1^.next;
p2 := p2^.next;
end; {while}
if p1 <> p2 then
Error(47);
p2 := tptr^.parameterList;
if isPascal then begin
{reverse the parameter list}
p1 := nil;
while p2 <> nil do begin
p3 := p2;
p2 := p2^.next;
p3^.next := p1;
p1 := p3;
end; {while}
tPtr^.parameterList := p1;
end; {if}
end; {if}
end {if}
else
Error(42);
1:
end; {if}
end; {if}
if tPtr^.kind = functionType then
state := declared;
if newName <> nil then {declare the variable}
variable := NewSymbol(newName, tPtr, storageClass, space, state)
else if unnamedParm then
variable^.itype := tPtr
else begin
if token.kind <> semicolonch then
Error(9);
variable := nil;
end; {else}
if variable <> nil then begin
if parameterStorage then
variable^.storage := parameter;
if isForwardDeclared then begin {handle forward declarations}
tPtr := variable^.itype;
lastWasPointer := false;
while tPtr^.kind in
[pointerType,arrayType,functionType,definedType] do begin
if tPtr^.kind = pointerType then
lastWasPointer := true
else if tPtr^.kind <> definedType then
lastWasPointer := false;
tPtr := tPtr^.pType;
end; {while}
if ((tPtr <> typeSpec) and (not (tPtr^.kind in [structType,unionType])))
then begin
Error(107);
SkipStatement;
end; {if}
variable^.isForwardDeclared := true;
end; {if}
end; {if}
end; {Declarator}
procedure Initializer (var variable: identPtr);
{ handle a variable initializer }
{ }
{ paramaters: }
{ variable - ptr to the identifier begin initialized }
var
bitcount: integer; {# if bits initialized}
bitvalue: longint; {bit field initializer value}
done: boolean; {for loop termination}
errorFound: boolean; {used to remove bad initializations}
iPtr,jPtr,kPtr: initializerPtr; {for reversing the list}
ip: identList; {used to place an id in the list}
luseGlobalPool: boolean; {local copy of useGlobalPool}
procedure InitializeBitField;
{ If bit fields have been initialized, fill them in }
{ }
{ Inputs: }
{ bitcount - # of bits initialized }
{ bitvalue - value of initializer }
var
iPtr: initializerPtr; {for creating an initializer entry}
begin {InitializeBitField}
if bitcount <> 0 then begin {skip if there has been no initializer}
{ writeln('InitializeBitField; bitcount = ', bitcount:1); {debug}
{create the initializer entry}
iPtr := pointer(Malloc(sizeof(initializerRecord)));
iPtr^.next := variable^.iPtr;
variable^.iPtr := iPtr;
iPtr^.isConstant := isConstant;
iPtr^.count := 1;
iPtr^.bitdisp := 0;
iPtr^.bitsize := 0;
Permit unions to be initialized by assignment from expressions of the appropriate union type. This patch should also permit the union initialization code to handle unions containing bit fields, but for the time being they are still prohibited by code elsewhere in the compiler.
2016-10-14 23:30:13 +00:00
iPtr^.isStructOrUnion := false;
Change all text/source files to LF line endings.
2017-10-21 23:40:19 +00:00
iPtr^.iVal := bitvalue;
if bitcount > 16 then
iPtr^.itype := cgULong
else if bitcount > 8 then
iPtr^.itype := cgUWord
else
iPtr^.itype := cgUByte;
bitcount := 0; {reset the bit field values}
bitvalue := 0;
end; {if}
end; {InitializeBitField}
procedure GetInitializerValue (tp: typePtr; bitsize,bitdisp: integer);
{ get the value of an initializer from a single expression }
{ }
{ parameters: }
{ tp - type of the variable being initialized }
{ bitsize - size of bit field (0 for non-bit fields) }
{ bitdisp - disp of bit field; unused if bitsize = 0 }
label 1,2,3;
var
bitmask: longint; {used to add a value to a bit field}
bKind: baseTypeEnum; {type of constant}
etype: typePtr; {expression type}
i: integer; {loop variable}
ip: identPtr; {ident in pointer constant}
iPtr: initializerPtr; {for creating an initializer entry}
kind: tokenEnum; {kind of constant}
offset, offset2: longint; {integer offset from a pointer}
operator: tokenEnum; {operator for constant pointers}
tKind: typeKind; {type of constant}
tree: tokenPtr; {for evaluating pointer constants}
function Subscript (tree: tokenPtr): typePtr;
{ handle subscripts in a pointer constant }
{ }
{ parameters: }
{ tree - subscript operators }
{ }
{ returns: type of the variable }
{ }
{ variables: }
{ iPtr - initializer location to store the array name }
{ offset - bytes past the start of the array }
var
ip: identPtr; {ident pointer}
rtree: tokenPtr; {work pointer}
tp: typePtr; {for tracking types}
select: longint; {selector size}
size: longint; {subscript value}
begin {Subscript}
if tree^.token.kind = uasterisk then begin
tree := tree^.left;
if tree^.token.kind = plusch then begin
rtree := tree^.right;
if rtree^.token.kind in [intconst,uintconst] then
size := rtree^.token.ival
else if rtree^.token.kind in [longconst,ulongconst] then
size := rtree^.token.lval
else begin
Error(18);
errorFound := true;
end; {else}
tp := Subscript(tree^.left);
if tp^.kind <> arrayType then
Error(47)
else begin
tp := tp^.atype;
offset := offset + size*tp^.size;
Subscript := tp;
end; {else}
end {if}
else begin
Error(47);
errorFound := true;
Subscript := wordPtr;
end; {else}
end {if}
else if tree^.token.kind = dotch then begin
tp := Subscript(tree^.left);
if tp^.kind in [structType,unionType] then begin
DoSelection(tp, tree^.right, select);
Subscript := expressionType;
offset := offset+select;
if isBitField then
Error(106);
end {if}
else begin
Error(47);
errorFound := true;
Subscript := wordPtr;
end; {else}
end {else if}
else if tree^.token.kind = ident then begin
ip := FindSymbol(tree^.token, allSpaces, false, true);
if ip = nil then begin
Error(31);
errorFound := true;
Subscript := wordPtr;
iPtr^.pName := @'?';
end {if}
else begin
Subscript := ip^.itype;
iPtr^.pName := ip^.name;
end; {else}
end {else if}
else begin
Error(47);
errorFound := true;
Subscript := wordPtr;
end; {else}
end; {Subscript}
begin {GetInitializerValue}
if variable^.storage = stackFrame then
Expression(autoInitializerExpression, [commach,rparench,rbracech])
else
Expression(initializerExpression, [commach,rparench,rbracech]);
if bitsize = 0 then begin
iPtr := pointer(Malloc(sizeof(initializerRecord)));
iPtr^.next := variable^.iPtr;
variable^.iPtr := iPtr;
iPtr^.isConstant := isConstant;
iPtr^.count := 1;
iPtr^.bitdisp := 0;
iPtr^.bitsize := 0;
Permit unions to be initialized by assignment from expressions of the appropriate union type. This patch should also permit the union initialization code to handle unions containing bit fields, but for the time being they are still prohibited by code elsewhere in the compiler.
2016-10-14 23:30:13 +00:00
iPtr^.isStructOrUnion := false;
Change all text/source files to LF line endings.
2017-10-21 23:40:19 +00:00
end; {if}
etype := expressionType;
AssignmentConversion(tp, expressionType, isConstant, expressionValue,
false, false);
if variable^.storage = external then
variable^.storage := global;
if isConstant and (variable^.storage in [external,global,private]) then begin
if bitsize = 0 then begin
iPtr^.iVal := expressionValue;
iPtr^.itype := tp^.baseType;
InitializeBitField;
end; {if}
case tp^.kind of
scalarType: begin
bKind := tp^.baseType;
if (bKind in [cgByte..cgULong])
and (etype^.baseType in [cgByte..cgULong]) then begin
if bKind in [cgLong,cgULong] then
if eType^.baseType = cgUByte then
iPtr^.iVal := iPtr^.iVal & $000000FF
else if eType^.baseType = cgUWord then
iPtr^.iVal := iPtr^.iVal & $0000FFFF;
goto 3;
end; {if}
if bKind in [cgReal,cgDouble,cgComp,cgExtended] then begin
if etype^.baseType in [cgByte..cgULong] then
iPtr^.rVal := expressionValue
else if etype^.baseType in
[cgReal,cgDouble,cgComp,cgExtended] then
iPtr^.rval := realExpressionValue;
goto 3;
end; {if}
Error(47);
errorFound := true;
goto 2;
3: if bitsize <> 0 then begin
{set up a bit field value}
if bitdisp < bitcount then
InitializeBitField;
bitmask := 0;
for i := 1 to bitsize do
bitmask := (bitmask << 1) | 1;
bitmask := bitmask & expressionValue;
for i := 1 to bitdisp do
bitmask := bitmask << 1;
bitvalue := bitvalue | bitmask;
bitcount := bitcount + bitsize;
end; {if}
end;
arrayType: begin
if tp^.aType^.kind = scalarType then
if tp^.aType^.baseType in [cgByte,cgUByte] then
if eType^.baseType = cgString then
goto 2;
Error(46);
errorFound := true;
end;
pointerType:
if etype = stringTypePtr then begin
iPtr^.isConstant := true;
iPtr^.iType := ccPointer;
iPtr^.pval := 0;
Remove access to uninitialized variable. There should be no functional change. Issue reported by Kelvin Sherlock.
2017-09-10 05:15:35 +00:00
iPtr^.pPlus := false;
Change all text/source files to LF line endings.
2017-10-21 23:40:19 +00:00
iPtr^.isName := false;
iPtr^.pStr := longstringPtr(expressionValue);
end {if}
else if etype^.kind = scalarType then
if etype^.baseType in [cgByte..cgULong] then
if expressionValue = 0 then
iPtr^.iType := cgULong
else begin
Error(47);
errorFound := true;
end {else}
else begin
Error(48);
errorFound := true;
end {else}
else if etype^.kind = pointerType then begin
iPtr^.iType := cgULong;
iPtr^.pval := expressionValue;
end {else if}
else begin
Error(48);
errorFound := true;
end; {else}
Permit unions to be initialized by assignment from expressions of the appropriate union type. This patch should also permit the union initialization code to handle unions containing bit fields, but for the time being they are still prohibited by code elsewhere in the compiler.
2016-10-14 23:30:13 +00:00
structType,unionType,enumType: begin
Change all text/source files to LF line endings.
2017-10-21 23:40:19 +00:00
Error(46);
errorFound := true;
end;
otherwise:
Error(57);
end; {case}
2: DisposeTree(initializerTree);
end {if}
else begin
if (tp^.kind = pointerType)
or ((tp^.kind = scalarType) and (tp^.baseType in [cgLong,cgULong]))
then begin
iPtr^.iType := ccPointer;
if variable^.storage in [external,global,private] then begin
{do pointer constants with + or -}
iPtr^.isConstant := true;
tree := initializerTree;
while tree^.token.kind = castoper do
tree := tree^.left;
offset := 0;
operator := tree^.token.kind;
while operator in [plusch,minusch] do begin
with tree^.right^.token do
if kind in [intConst,longConst] then begin
if kind = intConst then
offSet2 := ival
else
offset2 := lval;
if operator = plusch then
offset := offset + offset2
else
offset := offset - offset2;
end {if}
else begin
Error(47);
errorFound := true;
end; {else}
tree := tree^.left;
operator := tree^.token.kind;
end; {if}
kind := tree^.token.kind;
if kind = ident then begin
{handle names of functions or static arrays}
ip := FindSymbol(tree^.token, allSpaces, false, true);
if ip = nil then begin
Error(31);
errorFound := true;
end {if}
else begin
tKind := ip^.itype^.kind;
if tKind = functionType then begin
if operator in [plusch,minusch] then begin
Error(47);
errorFound := true;
end; {if}
end {if}
else if (tKind = arrayType)
and (ip^.storage in [external,global,private]) then begin
offset := offset*ip^.itype^.atype^.size;
end {else if}
else if tKind = pointerType then begin
Error(48);
errorFound := true;
end {else if}
else begin
Error(47);
errorFound := true;
end; {else}
iPtr^.pval := offset;
iPtr^.pPlus := true;
iPtr^.isName := true;
iPtr^.pName := ip^.name;
end; {if}
end {if}
else if kind = uand then begin
tree := tree^.left;
Fix bug where globals or static variables initialized with the address-of operator and pointer arithmetic could get the wrong value. For example, p would not be correctly initialized given the following global definitions: int a = 4; int *p = &a + 1; /* *(p-1) should be 4 */
2015-12-29 06:44:10 +00:00
iPtr^.pPlus := true;
Change all text/source files to LF line endings.
2017-10-21 23:40:19 +00:00
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;
Fix bug where globals or static variables initialized using pointer arithmetic on string constants could get the wrong value. This fixes the compca16.c test case.
2015-12-29 06:33:32 +00:00
iPtr^.pPlus := true;
Change all text/source files to LF line endings.
2017-10-21 23:40:19 +00:00
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}
Permit unions to be initialized by assignment from expressions of the appropriate union type. This patch should also permit the union initialization code to handle unions containing bit fields, but for the time being they are still prohibited by code elsewhere in the compiler.
2016-10-14 23:30:13 +00:00
else if tp^.kind in [structType,unionType] then
iPtr^.isStructOrUnion := true;
Change all text/source files to LF line endings.
2017-10-21 23:40:19 +00:00
{handle auto variables}
if bitsize <> 0 then begin
iPtr := pointer(Malloc(sizeof(initializerRecord)));
iPtr^.next := variable^.iPtr;
variable^.iPtr := iPtr;
iPtr^.isConstant := isConstant;
iPtr^.count := 1;
iPtr^.bitdisp := bitdisp;
iPtr^.bitsize := bitsize;
Permit unions to be initialized by assignment from expressions of the appropriate union type. This patch should also permit the union initialization code to handle unions containing bit fields, but for the time being they are still prohibited by code elsewhere in the compiler.
2016-10-14 23:30:13 +00:00
iPtr^.isStructOrUnion := false;
Change all text/source files to LF line endings.
2017-10-21 23:40:19 +00:00
end; {if}
if variable^.storage in [external,global,private] then begin
Error(41);
errorFound := true;
end; {else}
iPtr^.isConstant := false;
iPtr^.iTree := initializerTree;
iPtr^.bitdisp := bitdisp;
iPtr^.bitsize := bitsize;
end; {else}
1:
end; {GetInitializerValue}
procedure InitializeTerm (tp: typePtr; bitsize,bitdisp: integer;
main: boolean);
{ initialize one level of the type }
{ }
{ parameters: }
{ tp - pointer to the type being initialized }
{ bitsize - size of bit field (0 for non-bit fields) }
{ bitdisp - disp of bit field; unused if bitsize = 0 }
{ main - is this a call from the main level? }
var
bitCount: integer; {# of bits in a union}
braces: boolean; {is the initializer inclosed in braces?}
count,maxCount: longint; {for tracking the size of an initializer}
ep: tokenPtr; {for forming string expression}
iPtr: initializerPtr; {for creating an initializer entry}
ip: identPtr; {for tracing field lists}
kind: typeKind; {base type of an initializer}
ktp: typePtr; {array type with definedTypes removed}
procedure Fill (count: longint; tp: typePtr);
{ fill in unspecified space in an initialized array with 0 }
{ }
{ parameters: }
{ count - ^ elements of this type to create }
{ tp - ptr to type of elements to create }
var
i: longint; {loop variable}
iPtr: initializerPtr; {for creating an initializer entry}
tk: tokenPtr; {expression record}
ip: identPtr; {pointer to next field in a structure}
begin {Fill}
{ writeln('Fill tp^.kind = ', ord(tp^.kind):1, '; count = ', count:1); {debug}
InitializeBitField; {if needed, do the bit field}
if tp^.kind = arrayType then
{fill an array}
Fill(count*tp^.elements ,tp^.aType)
else if tp^.kind = structType then begin
{fill a structure}
i := count;
while i <> 0 do begin
ip := tp^.fieldList;
while ip <> nil do begin
Fill(1, ip^.iType);
ip := ip^.next;
end; {while}
i := i-1;
end; {while}
end {else if}
else if tp^.kind = unionType then
{fill a union}
Fill(count, tp^.fieldList^.iType)
else
{fill a single value}
while count <> 0 do begin
iPtr := pointer(Calloc(sizeof(initializerRecord)));
iPtr^.next := variable^.iPtr;
variable^.iPtr := iPtr;
iPtr^.isConstant := variable^.storage in [external,global,private];
{iPtr^.bitdisp := 0;}
{iPtr^.bitsize := 0;}
Permit unions to be initialized by assignment from expressions of the appropriate union type. This patch should also permit the union initialization code to handle unions containing bit fields, but for the time being they are still prohibited by code elsewhere in the compiler.
2016-10-14 23:30:13 +00:00
{iPtr^.isStructOrUnion := false;}
Change all text/source files to LF line endings.
2017-10-21 23:40:19 +00:00
if iPtr^.isConstant then begin
if tp^.kind = scalarType then
iPtr^.itype := tp^.baseType
else if tp^.kind = pointertype then begin
iPtr^.itype := cgULong;
{iPtr^.iVal := 0;}
end {else if}
else begin
iPtr^.itype := cgWord;
Error(47);
errorFound := true;
end; {else}
end {if}
else begin
new(tk);
tk^.next := nil;
tk^.left := nil;
tk^.middle := nil;
tk^.right := nil;
tk^.token.kind := intconst;
tk^.token.class := intConstant;
tk^.token.ival := 0;
iPtr^.iTree := tk;
end; {else}
if count < 16384 then begin
iPtr^.count := long(count).lsw;
count := 0;
end {if}
else begin
iPtr^.count := 16384;
count := count-16384;
end; {else}
end; {while}
end; {Fill}
procedure RecomputeSizes (tp: typePtr);
{ a size has been infered from an initializer - set the }
{ appropriate type size values }
{ }
{ parameters: }
{ tp - type to check }
begin {RecomputeSizes}
if tp^.aType^.kind = arrayType then
RecomputeSizes(tp^.aType);
with tp^ do
size := aType^.size*elements;
end; {RecomputeSizes}
begin {InitializeTerm}
braces := false; {allow for an opening brace}
if token.kind = lbracech then begin
NextToken;
braces := true;
end; {if}
{handle arrays}
while tp^.kind = definedType do
tp := tp^.dType;
kind := tp^.kind;
if kind = arrayType then begin
ktp := tp^.atype;
while ktp^.kind = definedType do
ktp := ktp^.dType;
kind := ktp^.kind;
{handle string constants}
if (token.kind = stringConst) and (kind = scalarType)
and (ktp^.baseType in [cgByte,cgUByte]) then begin
if tp^.elements = 0 then begin
tp^.elements := token.sval^.length + 1;
RecomputeSizes(variable^.itype);
end {if}
else if tp^.elements < token.sval^.length then begin
Error(44);
errorFound := true;
end; {else if}
with ktp^ do begin
iPtr := pointer(Malloc(sizeof(initializerRecord)));
iPtr^.next := variable^.iPtr;
variable^.iPtr := iPtr;
iPtr^.count := 1;
iPtr^.bitdisp := 0;
iPtr^.bitsize := 0;
Permit unions to be initialized by assignment from expressions of the appropriate union type. This patch should also permit the union initialization code to handle unions containing bit fields, but for the time being they are still prohibited by code elsewhere in the compiler.
2016-10-14 23:30:13 +00:00
iPtr^.isStructOrUnion := false;
Change all text/source files to LF line endings.
2017-10-21 23:40:19 +00:00
if (variable^.storage in [external,global,private]) then begin
iPtr^.isConstant := true;
iPtr^.itype := cgString;
iPtr^.sval := token.sval;
count := tp^.elements - token.sval^.length;
if count <> 0 then
Fill(count, bytePtr);
end {if}
else begin
iPtr^.isConstant := false;
new(ep);
iPtr^.iTree := ep;
ep^.next := nil;
ep^.left := nil;
ep^.middle := nil;
ep^.right := nil;
ep^.token := token;
end; {else}
end; {with}
NextToken;
end {if}
{handle arrays of non-strings}
else if kind in
[scalarType,pointerType,enumType,arrayType,structType,unionType] then
begin
count := 0; {get the expressions|initializers}
maxCount := tp^.elements;
if token.kind <> rbracech then
repeat
InitializeTerm(ktp, 0, 0, false);
count := count+1;
if count <> maxCount then begin
if token.kind = commach then begin
NextToken;
done := token.kind = rbracech;
end {if}
else
done := true;
end {if}
else
done := true;
until done or (token.kind = eofsy) or (count = maxCount);
if maxCount <> 0 then begin
count := maxCount-count;
if count <> 0 then {if there weren't enough initializers...}
Fill(count,ktp); { fill in the blank spots}
end {if}
else begin
tp^.elements := count; {set the array size}
RecomputeSizes(variable^.itype);
end; {else}
end {else if}
else begin
Error(47);
errorFound := true;
end; {else}
end {if}
Permit unions to be initialized by assignment from expressions of the appropriate union type. This patch should also permit the union initialization code to handle unions containing bit fields, but for the time being they are still prohibited by code elsewhere in the compiler.
2016-10-14 23:30:13 +00:00
{handle structures and unions}
else if kind in [structType, unionType] then begin
Change all text/source files to LF line endings.
2017-10-21 23:40:19 +00:00
if braces or (not main) then begin
count := tp^.size;
ip := tp^.fieldList;
bitCount := 0;
Prevent struct/union members from having incomplete type, except for flexible array member. ORCA/C previously allowed struct/union members to be declared with incomplete type. Because of this, it allowed C99-style flexible array members to be declared, albeit by accident rather than by design. In some basic testing, these seem to work correctly, except that they could be initialized and that would give rise to odd behavior. I have restricted it to allowing flexible array members only in the cases allowed by C99/C11, and otherwise disallowing members with incomplete type. I have also prohibited initializing flexible array members.
2016-10-17 03:56:34 +00:00
while (ip <> nil) and (ip^.itype^.size > 0)
and (token.kind <> rbracech) do begin
Change all text/source files to LF line endings.
2017-10-21 23:40:19 +00:00
if ip^.isForwardDeclared then
ResolveForwardReference(ip);
InitializeTerm(ip^.itype, ip^.bitsize, ip^.bitdisp, false);
if ip^.bitSize <> 0 then begin
bitCount := bitCount + ip^.bitSize;
if bitCount > maxBitField then begin
count := count - (maxBitField div 8);
bitCount := ip^.bitSize;
end; {if}
end {if}
else begin
if bitCount > 0 then begin
bitCount := (bitCount+7) div 8;
count := count-bitCount;
bitCount := 0;
end; {if}
count := count-ip^.itype^.size;
end; {else}
{ writeln('Initializer: ', ip^.bitsize:10, ip^.bitdisp:10, bitCount:10); {debug}
Permit unions to be initialized by assignment from expressions of the appropriate union type. This patch should also permit the union initialization code to handle unions containing bit fields, but for the time being they are still prohibited by code elsewhere in the compiler.
2016-10-14 23:30:13 +00:00
if kind = unionType then
ip := nil
else
ip := ip^.next;
Change all text/source files to LF line endings.
2017-10-21 23:40:19 +00:00
if token.kind = commach then begin
if ip <> nil then
NextToken;
end {if}
else
ip := nil;
end; {while}
if bitCount > 0 then begin
InitializeBitField;
bitCount := (bitCount+7) div 8;
count := count-bitCount;
bitCount := 0;
end; {if}
if count > 0 then
Fill(count, bytePtr);
end {if}
Permit unions to be initialized by assignment from expressions of the appropriate union type. This patch should also permit the union initialization code to handle unions containing bit fields, but for the time being they are still prohibited by code elsewhere in the compiler.
2016-10-14 23:30:13 +00:00
else {struct/union assignment initializer}
Change all text/source files to LF line endings.
2017-10-21 23:40:19 +00:00
GetInitializerValue(tp, bitsize, bitdisp);
end {else if}
{handle single-valued types}
else if kind in [scalarType,pointerType,enumType] then
GetInitializerValue(tp, bitsize, bitdisp)
else begin
Error(47);
errorFound := true;
end; {else}
if braces then begin {if there was an opening brace then }
if token.kind = commach then { insist on a closing brace }
NextToken;
if token.kind = rbracech then
NextToken
else begin
Error(23);
while not (token.kind in [rbracech,eofsy]) do
NextToken;
NextToken;
errorFound := true;
end; {else}
end; {if}
end; {InitializeTerm}
begin {Initializer}
bitcount := 0; {set up for bit fields}
bitvalue := 0;
errorFound := false; {no errors found so far}
luseGlobalPool := useGlobalPool; {use global memory for global vars}
useGlobalPool := (variable^.storage in [external,global,private])
or useGlobalPool;
{make sure a required '{' is there}
if not (token.kind in [lbracech,stringConst]) then
if variable^.itype^.kind = arrayType then begin
Error(27);
errorFound := true;
end; {if}
InitializeTerm(variable^.itype, 0, 0, true); {do the initialization}
variable^.state := initialized; {mark the variable as initialized}
iPtr := variable^.iPtr; {reverse the initializer list}
jPtr := nil;
while iPtr <> nil do begin
kPtr := iPtr;
iPtr := iPtr^.next;
kPtr^.next := jPtr;
jPtr := kPtr;
end; {while}
variable^.iPtr := jPtr;
if errorFound then {eliminate bad initializers}
variable^.state := defined;
new(ip); {place the initializer in the list}
ip^.next := initializerList;
ip^.id := variable;
initializerList := ip;
useGlobalPool := luseGlobalPool; {restore useGlobalPool}
end; {Initializer}
procedure TypeSpecifier {doingFieldList,isConstant: boolean};
{ handle a type specifier }
{ }
{ parameters: }
{ doingFieldList - are we processing a field list? }
{ isConstant - did we already find a constsy? }
{ }
{ outputs: }
{ isForwardDeclared - is the field list component }
{ referenceing a forward struct/union? }
{ skipDeclarator - for enum,struct,union with no }
{ declarator }
{ typespec - type specifier }
label 1,2;
var
done: boolean; {for loop termination}
enumVal: integer; {default value for the next enum constant}
tPtr: typePtr; {for building types}
variable: identPtr; {enumeration variable}
structPtr: identPtr; {structure identifier}
structTypePtr: typePtr; {structure type}
tKind: typeKind; {defining structure or union?}
ttoken: tokenType; {temp variable for struct name}
lUseGlobalPool: boolean; {local copy of useGlobalPool}
globalStruct: boolean; {did we force global pool use?}
procedure FieldList (tp: typePtr; kind: typeKind);
{ handle a field list }
{ }
{ parameters }
{ tp - place to store the type pointer }
var
bitDisp: integer; {current bit disp}
disp: longint; {current byte disp}
done: boolean; {for loop termination}
fl,tfl,ufl: identPtr; {field list}
ldoingParameters: boolean; {local copy of doingParameters}
lisForwardDeclared: boolean; {local copy of isForwardDeclared}
lstorageClass: tokenEnum; {storage class of the declaration}
maxDisp: longint; {for determining union sizes}
variable: identPtr; {variable being defined}
Prevent struct/union members from having incomplete type, except for flexible array member. ORCA/C previously allowed struct/union members to be declared with incomplete type. Because of this, it allowed C99-style flexible array members to be declared, albeit by accident rather than by design. In some basic testing, these seem to work correctly, except that they could be initialized and that would give rise to odd behavior. I have restricted it to allowing flexible array members only in the cases allowed by C99/C11, and otherwise disallowing members with incomplete type. I have also prohibited initializing flexible array members.
2016-10-17 03:56:34 +00:00
didFlexibleArray: boolean; {have we seen a flexible array member?}
Change all text/source files to LF line endings.
2017-10-21 23:40:19 +00:00
begin {FieldList}
ldoingParameters := doingParameters; {allow fields in K&R dec. area}
doingParameters := false;
lisForwardDeclared := isForwardDeclared; {stack this value}
lStorageClass := storageClass; {don't allow auto in a struct}
storageClass := ident;
bitDisp := 0; {start allocation from byte 0}
disp := 0;
maxDisp := 0;
Prevent struct/union members from having incomplete type, except for flexible array member. ORCA/C previously allowed struct/union members to be declared with incomplete type. Because of this, it allowed C99-style flexible array members to be declared, albeit by accident rather than by design. In some basic testing, these seem to work correctly, except that they could be initialized and that would give rise to odd behavior. I have restricted it to allowing flexible array members only in the cases allowed by C99/C11, and otherwise disallowing members with incomplete type. I have also prohibited initializing flexible array members.
2016-10-17 03:56:34 +00:00
didFlexibleArray := false;
Change all text/source files to LF line endings.
2017-10-21 23:40:19 +00:00
fl := nil; {nothing in the field list, yet}
{check for no declarations}
if not (token.kind in [unsignedsy,signedsy,intsy,longsy,charsy,shortsy,
floatsy,doublesy,compsy,extendedsy,enumsy,structsy,unionsy,typedefsy,
typedef,voidsy,constsy,volatilesy]) then
Error(26);
{while there are entries in the field list...}
while token.kind in [unsignedsy,signedsy,intsy,longsy,charsy,shortsy,floatsy,
doublesy,compsy,extendedsy,enumsy,structsy,unionsy,typedefsy,typedef,
voidsy,constsy,volatilesy] do begin
typeSpec := wordPtr; {default type specifier is an integer}
TypeSpecifier(true,false); {get the type specifier}
if not skipDeclarator then
repeat {declare the variables...}
Prevent struct/union members from having incomplete type, except for flexible array member. ORCA/C previously allowed struct/union members to be declared with incomplete type. Because of this, it allowed C99-style flexible array members to be declared, albeit by accident rather than by design. In some basic testing, these seem to work correctly, except that they could be initialized and that would give rise to odd behavior. I have restricted it to allowing flexible array members only in the cases allowed by C99/C11, and otherwise disallowing members with incomplete type. I have also prohibited initializing flexible array members.
2016-10-17 03:56:34 +00:00
if didFlexibleArray then
Error(118);
Change all text/source files to LF line endings.
2017-10-21 23:40:19 +00:00
variable := nil;
if token.kind <> colonch then begin
Declarator(typeSpec, variable, fieldListSpace, false);
if variable <> nil then {enter the var in the field list}
begin
tfl := fl; {(check for dups)}
while tfl <> nil do begin
if tfl^.name^ = variable^.name^ then
Error(42);
tfl := tfl^.next;
end; {while}
variable^.next := fl;
fl := variable;
end; {if}
end; {if}
if token.kind = colonch then {handle a bit field}
begin
if kind = unionType then
Error(56);
NextToken;
Expression(arrayExpression,[commach,semicolonch]);
if (expressionValue >= maxBitField) or (expressionValue < 0) then
begin
Error(54);
expressionValue := maxBitField-1;
end; {if}
if (bitdisp+long(expressionValue).lsw > maxBitField)
or (long(expressionValue).lsw = 0) then begin
disp := disp+((bitDisp+7) div 8);
bitdisp := 0;
if long(expressionValue).lsw = 0 then
if variable <> nil then
Error(55);
end; {if}
if variable <> nil then begin
variable^.disp := disp;
variable^.bitdisp := bitdisp;
variable^.bitsize := long(expressionValue).lsw;
bitdisp := bitdisp+long(expressionValue).lsw;
Restrict bit fields to having integer types, and to having no more bits than the type specified. C89 restricts bit fields to (signed) int and unsigned int only, although later standards note that additional types may be supported. ORCA/C supports the other integer types as an extension. This fixes the compco01.c test case.
2016-10-15 06:43:31 +00:00
tPtr := variable^.itype;
end {if}
else
tPtr := typeSpec;
if (tPtr^.kind <> scalarType)
or not (tPtr^.baseType in
[cgByte,cgUByte,cgWord,cgUWord,cgLong,cgULong])
or (expressionValue > tPtr^.size*8) then
Error(115);
Change all text/source files to LF line endings.
2017-10-21 23:40:19 +00:00
end {if}
else if variable <> nil then begin
if bitdisp <> 0 then begin
disp := disp+((bitDisp+7) div 8);
bitdisp := 0;
end {if}
else if kind = unionType then
disp := 0;
variable^.disp := disp;
variable^.bitdisp := bitdisp;
variable^.bitsize := 0;
disp := disp + variable^.itype^.size;
if disp > maxDisp then
maxDisp := disp;
Prevent struct/union members from having incomplete type, except for flexible array member. ORCA/C previously allowed struct/union members to be declared with incomplete type. Because of this, it allowed C99-style flexible array members to be declared, albeit by accident rather than by design. In some basic testing, these seem to work correctly, except that they could be initialized and that would give rise to odd behavior. I have restricted it to allowing flexible array members only in the cases allowed by C99/C11, and otherwise disallowing members with incomplete type. I have also prohibited initializing flexible array members.
2016-10-17 03:56:34 +00:00
if variable^.itype^.size = 0 then
if (variable^.itype^.kind = arrayType)
and (disp > 0) then {handle flexible array member}
didFlexibleArray := true
else
Error(117);
Flag an error if a struct or enum field declaration contains no declarator (i.e. no name). This may be someone trying to use a C11-style anonymous struct/union, which should be flagged as an error until and unless those are supported. Otherwise, it probably just indicates that the programmer is confused. In any case, an error should be flagged for it.
2016-10-16 00:47:06 +00:00
end {if}
else
Error(116);
Change all text/source files to LF line endings.
2017-10-21 23:40:19 +00:00
if token.kind = commach then {allow repeated declarations}
begin
NextToken;
done := false;
end {if}
else
done := true;
Flag an error if a struct or enum field declaration contains no declarator (i.e. no name). This may be someone trying to use a C11-style anonymous struct/union, which should be flagged as an error until and unless those are supported. Otherwise, it probably just indicates that the programmer is confused. In any case, an error should be flagged for it.
2016-10-16 00:47:06 +00:00
until done or (token.kind = eofsy)
else
Error(116);
Change all text/source files to LF line endings.
2017-10-21 23:40:19 +00:00
Match(semicolonch,22); {insist on a closing ';'}
end; {while}
if fl <> nil then begin
ufl := nil; {reverse the field list}
while fl <> nil do begin
tfl := fl;
fl := fl^.next;
tfl^.next := ufl;
ufl := tfl;
end; {while}
if kind = structType then begin {return the field list}
if bitdisp <> 0 then
disp := disp+((bitDisp+7) div 8);
tp^.size := disp;
end {if}
else
tp^.size := maxDisp;
tp^.fieldList := ufl;
end; {if}
storageClass := lStorageClass; {restore default storage class}
isForwardDeclared := lisForwardDeclared; {restore the forward flag}
doingParameters := ldoingParameters; {restore the parameters flag}
end; {FieldList}
procedure CheckConst;
{ Check the token to see if it is a const or volatile }
begin {CheckConst}
while token.kind in [constsy,volatilesy] do begin
if token.kind = constsy then
isConstant := true
else
volatile := true;
NextToken;
end; {while}
end; {CheckConst}
begin {TypeSpecifier}
isForwardDeclared := false; {not doing a forward reference (yet)}
skipDeclarator := false; {declarations are required (so far)}
CheckConst;
case token.kind of
unsignedsy: begin {unsigned}
NextToken;
CheckConst;
if token.kind = shortsy then begin
NextToken;
CheckConst;
if token.kind = intsy then begin
NextToken;
CheckConst;
end; {if}
typeSpec := uWordPtr;
end {if}
else if token.kind = longsy then begin
NextToken;
CheckConst;
if token.kind = intsy then begin
NextToken;
CheckConst;
end; {if}
typeSpec := uLongPtr;
end {else if}
else if token.kind = charsy then begin
NextToken;
CheckConst;
typeSpec := uBytePtr;
end {else if}
else if token.kind = intsy then begin
NextToken;
CheckConst;
if unix_1 then
typeSpec := uLongPtr
else
typeSpec := uWordPtr;
end {else if}
else begin
CheckConst;
if unix_1 then
typeSpec := uLongPtr
else
typeSpec := uWordPtr;
end; {else if}
end;
signedsy: begin {signed}
NextToken;
CheckConst;
if token.kind = shortsy then begin
NextToken;
CheckConst;
if token.kind = intsy then begin
NextToken;
CheckConst;
end; {if}
typeSpec := wordPtr;
end {if}
else if token.kind = longsy then begin
NextToken;
CheckConst;
if token.kind = intsy then begin
NextToken;
CheckConst;
end; {if}
typeSpec := longPtr;
end {else if}
else if token.kind = intsy then begin
NextToken;
CheckConst;
if unix_1 then
typeSpec := longPtr
else
typeSpec := wordPtr;
end {else if}
else if token.kind = charsy then begin
NextToken;
CheckConst;
typeSpec := bytePtr;
end; {else if}
end;
intsy: begin {int}
NextToken;
CheckConst;
if unix_1 then
typeSpec := longPtr
else
typeSpec := wordPtr;
end;
longsy: begin {long}
NextToken;
CheckConst;
typeSpec := longPtr;
if token.kind in [intsy,floatsy] then begin
if token.kind = floatsy then
typeSpec := doublePtr;
NextToken;
CheckConst;
end {if}
else if token.kind = doublesy then begin
typeSpec := extendedPtr;
NextToken;
CheckConst;
end; {else if}
end;
charsy: begin {char}
NextToken;
CheckConst;
typeSpec := uBytePtr;
end;
shortsy: begin {short}
NextToken;
CheckConst;
if token.kind = intsy then begin
NextToken;
CheckConst;
end; {if}
typeSpec := wordPtr;
end;
floatsy: begin {float}
NextToken;
CheckConst;
typeSpec := realPtr;
end;
doublesy: begin {double}
NextToken;
CheckConst;
typeSpec := doublePtr;
end;
compsy: begin {comp}
NextToken;
CheckConst;
typeSpec := compPtr;
end;
extendedsy: begin {extended}
NextToken;
CheckConst;
typeSpec := extendedPtr;
end;
voidsy: begin {void}
NextToken;
CheckConst;
typeSpec := voidPtr;
end;
enumsy: begin {enum}
NextToken; {skip the 'enum' token}
if token.kind = ident then begin {handle a type definition}
variable := FindSymbol(token, tagSpace, true, true);
ttoken := token;
NextToken;
if variable <> nil then
if variable^.itype^.kind = enumType then
if token.kind <> lbracech then
goto 1;
tPtr := pointer(Malloc(sizeof(typeRecord)));
tPtr^.size := cgWordSize;
tPtr^.saveDisp := 0;
tPtr^.isConstant := false;
tPtr^.kind := enumType;
variable :=
NewSymbol(ttoken.name, tPtr, storageClass, tagSpace, defined);
CheckConst;
end {if}
else if token.kind <> lbracech then
Error(9);
enumVal := 0; {set the default value}
if token.kind = lbracech then begin
NextToken; {skip the '{'}
repeat {declare the enum constants}
tPtr := pointer(Malloc(sizeof(typeRecord)));
tPtr^.size := cgWordSize;
tPtr^.saveDisp := 0;
tPtr^.isConstant := false;
tPtr^.kind := enumConst;
if token.kind = ident then begin
variable :=
NewSymbol(token.name, tPtr, ident, variableSpace, defined);
NextToken;
end {if}
else
Error(9);
if token.kind = eqch then begin {handle explicit enumeration values}
NextToken;
Expression(arrayExpression,[commach,rbracech]);
enumVal := long(expressionValue).lsw;
if enumVal <> expressionValue then
Error(6);
end; {if}
tPtr^.eval := enumVal; {set the enumeration constant value}
enumVal := enumVal+1; {inc the default enumeration value}
if token.kind = commach then {next enumeration...}
begin
done := false;
NextToken;
Allow trailing comma in enum (as in C99). Patch from Kelvin Sherlock.
2017-06-18 03:36:09 +00:00
{kws -- allow trailing , in enum }
{ C99 6.7.2.2 Enumeration specifiers }
if token.kind = rbracech then done := true;
Change all text/source files to LF line endings.
2017-10-21 23:40:19 +00:00
end {if}
else
done := true;
until done or (token.kind = eofsy);
if token.kind = rbracech then
NextToken
else begin
Error(23);
SkipStatement;
end; {else}
end; {if}
1: skipDeclarator := token.kind = semicolonch;
end;
structsy, {struct}
unionsy: begin {union}
globalStruct := false; {we didn't make it global}
if token.kind = structsy then {set the type kind to use}
tKind := structType
else
tKind := unionType;
structPtr := nil; {no record, yet}
structTypePtr := defaultStruct; {use int as a default type}
NextToken; {skip 'struct' or 'union'}
if token.kind in [ident,typedef] {if there is a struct name then...}
then begin
{look up the name}
structPtr := FindSymbol(token, tagSpace, true, true);
ttoken := token; {record the structure name}
NextToken; {skip the structure name}
if structPtr = nil then begin {if the name hasn't been defined then...}
if token.kind <> lbracech then
structPtr := FindSymbol(ttoken, tagSpace, false, true);
if structPtr <> nil then
structTypePtr := structPtr^.itype
else begin
isForwardDeclared := true;
globalStruct := doingParameters and (token.kind <> lbracech);
if globalStruct then begin
lUseGlobalPool := useGlobalPool;
useGlobalPool := true;
end; {if}
structTypePtr := pointer(Calloc(sizeof(typeRecord)));
{structTypePtr^.size := 0;}
{structTypePtr^.saveDisp := 0;}
{structTypePtr^.isConstant := false;}
structTypePtr^.kind := tkind;
{structTypePtr^.fieldList := nil;}
{structTypePtr^.sName := nil;}
structPtr := NewSymbol(ttoken.name, structTypePtr, ident,
tagSpace, defined);
structTypePtr^.sName := structPtr^.name;
end;
end {if}
{the name has been defined, so...}
else if structPtr^.itype^.kind <> tKind then begin
Error(42); {it's an error if it's not a struct}
structPtr := nil;
end {else}
else begin {record the existing structure type}
structTypePtr := structPtr^.itype;
CheckConst;
end; {else}
end {if}
else if token.kind <> lbracech then
Error(9); {its an error if there's no name or struct}
2: if token.kind = lbracech then {handle a structure definition...}
begin {error if we already have one!}
if (structTypePtr <> defaultStruct)
and (structTypePtr^.fieldList <> nil) then begin
Error(53);
structPtr := nil;
end; {if}
NextToken; {skip the '{'}
if structTypePtr = defaultStruct then begin
structTypePtr := pointer(Calloc(sizeof(typeRecord)));
{structTypePtr^.size := 0;}
{structTypePtr^.saveDisp := 0;}
{structTypePtr^.isConstant := false;}
structTypePtr^.kind := tkind;
{structTypePtr^.fieldList := nil;}
{structTypePtr^.sName := nil;}
end; {if}
if structPtr <> nil then
structPtr^.itype := structTypePtr;
FieldList(structTypePtr,tKind); {define the fields}
if token.kind = rbracech then {insist on a closing rbrace}
NextToken
else begin
Error(23);
SkipStatement;
end; {else}
end; {if}
if globalStruct then
useGlobalPool := lUseGlobalPool;
typeSpec := structTypePtr;
skipDeclarator := token.kind = semicolonch;
end;
typedef: begin {named type definition}
typeSpec := token.symbolPtr^.itype;
NextToken;
end;
otherwise: ;
end; {case}
if isconstant then begin {handle a constant type}
new(tPtr);
if typeSpec^.kind in [structType,unionType] then begin
with tPtr^ do begin
size := typeSpec^.size;
kind := definedType;
dType := typeSpec;
end; {with}
end {if}
else
tPtr^ := typeSpec^;
tPtr^.isConstant := true;
typeSpec := tPtr;
end; {if}
end; {TypeSpecifier}
{-- Externally available subroutines ---------------------------}
procedure DoDeclaration {doingPrototypes: boolean};
{ process a variable or function declaration }
{ }
{ parameters: }
{ doingPrototypes - are we processing a parameter list? }
label 1,2,3;
var
done: boolean; {for loop termination}
foundConstsy: boolean; {did we find a constsy?}
fName: stringPtr; {for forming uppercase names}
i: integer; {loop variable}
isAsm: boolean; {has the asm modifier been used?}
Allow "static inline" function declarations. This should give C99-compatible behavior, as far as it goes. The functions aren't actually inlined, but that's just a quality-of-implementation issue. No C standard requires actual inlining. Non-static inline functions are still not supported. The C99 semantics for them are more complicated, and they're less widely used, so they're a lower priority for now. The "inline" function specifier can currently only come after the "static" storage class specifier. This relates to a broader issue where not all legal orderings of declaration specifiers are supported. Since "inline" was already treated as a keyword in ORCA/C, this shouldn't create any extra compatibility issues for C89 code.
2017-06-18 06:32:54 +00:00
isInline: boolean; {has the inline specifier been used?}
Change all text/source files to LF line endings.
2017-10-21 23:40:19 +00:00
lDoingParameters: boolean; {local copy of doingParameters}
lisPascal: boolean; {local copy of isPascal}
lp,tlp,tlp2: identPtr; {for tracing parameter list}
ltypeSpec: typePtr; {copy of type specifier}
lUseGlobalPool: boolean; {local copy of useGlobalPool}
nextPdisp: integer; {for calculating parameter disps}
noFDefinitions: boolean; {are function definitions inhibited?}
p1,p2,p3: parameterPtr; {for reversing prototyped parameters}
variable: identPtr; {pointer to the variable being declared}
fnType: typePtr; {function type}
segType: integer; {segment type}
tp: typePtr; {for tracing type lists}
tk: tokenType; {work token}
typeFound: boolean; {has some type specifier been found?}
procedure CheckArray (v: identPtr; firstVariable: boolean);
{ make sure all required array sizes are specified }
{ }
{ parameters: }
{ v - pointer to the identifier to check }
{ firstVariable - can the first array subscript be of a }
{ non-fixed size? }
label 1;
var
tp: typePtr; {work pointer}
begin {CheckArray}
if v <> nil then begin {skip check if there's no variable}
tp := v^.itype; {initialize the type pointer}
while tp <> nil do begin {check all types}
if tp^.kind = arrayType then {if it's an array with an unspecified }
if tp^.elements = 0 then { size and an unspecified size is not }
if not firstVariable then { allowed here, flag an error. }
begin
Error(49);
goto 1;
end; {if}
firstVariable := false; {unspecified sizes are only allowed in }
{ the first subscript }
case tp^.kind of {next type...}
arrayType:
tp := tp^.aType;
pointerType: begin
tp := tp^.pType;
firstVariable := true; {(also allowed for pointers to arrays)}
end;
functionType:
tp := tp^.fType;
otherwise:
tp := nil;
end; {case}
end; {while}
end; {if}
1:
end; {CheckArray}
procedure SegmentStatement;
{ compile a segment statement }
{ }
{ statement syntax: }
{ }
{ 'segment' string-constant [',' 'dynamic'] }
var
i: integer; {loop variable}
len: integer; {segment name length}
begin {SegmentStatement}
NextToken;
if token.kind = stringConst then begin
for i := 1 to 10 do begin
defaultSegment[i] := chr(0);
currentSegment[i] := chr(0);
end; {for}
len := token.sval^.length;
if len > 10 then
len := 10;
for i := 1 to len do
defaultSegment[i] := token.sval^.str[i];
for i := 1 to len do
currentSegment[i] := token.sval^.str[i];
FlagPragmas(p_segment);
NextToken;
if token.kind = commach then begin
NextToken;
if token.kind = ident then begin
if token.name^ = 'dynamic' then
segmentKind := $8000
else Error(84);
NextToken;
end {if}
else Error(84);
end {if}
else
segmentKind := 0;
Match(semicolonch,22);
end {if}
else begin
Error(83);
SkipStatement;
end; {else}
end; {SegmentStatement}
function InPartialList (fName: stringPtr): boolean;
{ See if the function is in the partial compile list. }
{ }
{ If the function is in the list, the function name is }
{ removed from the list, and true is returned. If not, }
{ false is returned. }
{ }
{ parameters: }
{ fName - name of the function to check for }
label 1,2;
var
ch: char; {work character}
i,j: integer; {loop variable}
len: integer; {length of fName}
begin {InPartialList}
i := partialFileGS.theString.size; {strip trailing blanks}
while (i > 0) and (partialFileGS.theString.theString[i] = ' ') do begin
partialFileGS.theString.theString[i] := chr(0);
i := i-1;
end; {while}
while partialFileGS.theString.theString[1] = ' ' do {skip leading blanks}
for i := 1 to partialFileGS.theString.size do
partialFileGS.theString.theString[i] :=
partialFileGS.theString.theString[i+1];
InPartialList := true; {assume success}
i := 1; {scan the name list}
len := length(fName^);
while partialFileGS.theString.theString[i] <> chr(0) do begin
for j := 1 to len do begin
if partialFileGS.theString.theString[i+j-1] <> fName^[j] then
goto 1;
end; {for}
if partialFileGS.theString.theString[i+len] in [' ', chr(0)] then begin
{found a match - remove from list & return}
j := i+len;
while partialFileGS.theString.theString[j] = ' ' do
j := j+1;
repeat
ch := partialFileGS.theString.theString[j];
partialFileGS.theString.theString[i] := ch;
i := i+1;
j := j+1;
until ch = chr(0);
goto 2;
end; {if}
1: {no match - skip to next name}
while not (partialFileGS.theString.theString[i] in [chr(0), ' ']) do
i := i+1;
while partialFileGS.theString.theString[i] = ' ' do
i := i+1;
end; {while}
InPartialList := false; {no match found}
2:
end; {InPartialList}
procedure SkipFunction (isAsm: boolean);
{ Skip a function body for a partial compile }
{ }
{ Parameters: }
{ isAsm - are we compiling an asm function? }
var
braceCount: integer; {# of unmatched { chars}
doingAsm: boolean; {compiling an asm statement?}
begin {SkipFunction}
Match(lbracech,27); {skip to the closing rbrackch}
braceCount := 1;
doingAsm := false;
if isAsm then
charKinds[ord('#')] := ch_pound;
while (not (token.kind = eofsy)) and (braceCount <> 0) do begin
if token.kind = asmsy then begin
doingAsm := true;
charKinds[ord('#')] := ch_pound;
end {if}
else if token.kind = lbracech then
braceCount := braceCount+1
else if token.kind = rbracech then begin
braceCount := braceCount-1;
if doingAsm then begin
doingAsm := false;
charKinds[ord('#')] := illegal;
end; {if}
end; {else if}
NextToken;
end; {while}
nameFound := false; {no pc_nam for the next function (yet)}
doingFunction := false; {no longer doing a function}
charKinds[ord('#')] := illegal; {# is a preprocessor command}
end; {SkipFunction}
begin {DoDeclaration}
lDoingParameters := doingParameters; {record the status}
noFDefinitions := false; {are function definitions inhibited?}
typeFound := false; {no explicit type found, yet}
foundConstsy := false; {did not find a constsy}
if doingPrototypes then {prototypes implies a parm list}
doingParameters := true
else
lastParameter := nil; {init parm list if we're not doing prototypes}
isFunction := false; {assume it's not a function}
if not doingFunction then {handle any segment statements}
while token.kind = segmentsy do
SegmentStatement;
inhibitHeader := true; {block imbedded includes in headers}
if token.kind in [constsy,volatilesy] {handle leading constsy, volatile}
then begin
while token.kind in [constsy,volatilesy] do begin
if token.kind = constsy then
foundConstsy := true
else
volatile := true;
NextToken;
end; {while}
end; {if}
storageClass := ident; {handle a StorageClassSpecifier}
lUseGlobalPool := useGlobalPool;
if token.kind in [autosy,externsy,registersy,staticsy,typedefsy] then begin
typeFound := true;
storageClass := token.kind;
if not doingFunction then
if token.kind = autosy then
Error(62);
if doingParameters then begin
if token.kind <> registersy then
Error(87);
end {if}
else if storageClass in [staticsy,typedefsy] then
useGlobalPool := true;
NextToken;
end; {if}
isAsm := false;
isPascal := false;
Allow "static inline" function declarations. This should give C99-compatible behavior, as far as it goes. The functions aren't actually inlined, but that's just a quality-of-implementation issue. No C standard requires actual inlining. Non-static inline functions are still not supported. The C99 semantics for them are more complicated, and they're less widely used, so they're a lower priority for now. The "inline" function specifier can currently only come after the "static" storage class specifier. This relates to a broader issue where not all legal orderings of declaration specifiers are supported. Since "inline" was already treated as a keyword in ORCA/C, this shouldn't create any extra compatibility issues for C89 code.
2017-06-18 06:32:54 +00:00
isInline := false;
while token.kind in [pascalsy,asmsy,inlinesy] do begin
Change all text/source files to LF line endings.
2017-10-21 23:40:19 +00:00
if token.kind = pascalsy then
isPascal := true
Allow "static inline" function declarations. This should give C99-compatible behavior, as far as it goes. The functions aren't actually inlined, but that's just a quality-of-implementation issue. No C standard requires actual inlining. Non-static inline functions are still not supported. The C99 semantics for them are more complicated, and they're less widely used, so they're a lower priority for now. The "inline" function specifier can currently only come after the "static" storage class specifier. This relates to a broader issue where not all legal orderings of declaration specifiers are supported. Since "inline" was already treated as a keyword in ORCA/C, this shouldn't create any extra compatibility issues for C89 code.
2017-06-18 06:32:54 +00:00
else if token.kind = asmsy then
isAsm := true
else {if token.kind = inlinesy then}
isInline := true;
Change all text/source files to LF line endings.
2017-10-21 23:40:19 +00:00
NextToken;
end; {while}
lisPascal := isPascal;
typeSpec := wordPtr; {default type specifier is an integer}
if token.kind in {handle a TypeSpecifier/declarator}
[unsignedsy,signedsy,intsy,longsy,charsy,shortsy,floatsy,doublesy,compsy,
extendedsy,voidsy,enumsy,structsy,unionsy,typedef,volatilesy,constsy] then
begin
typeFound := true;
TypeSpecifier(false,foundConstsy);
if not skipDeclarator then begin
variable := nil;
Declarator(typeSpec, variable, variableSpace, doingPrototypes);
if variable = nil then begin
inhibitHeader := false;
if token.kind = semicolonch then
NextToken
else begin
Error(22);
SkipStatement;
end; {else}
goto 1;
end; {if}
end; {if}
end {if}
else begin
variable := nil;
Declarator (typeSpec, variable, variableSpace, doingPrototypes);
if variable = nil then begin
inhibitHeader := false;
if token.kind = semicolonch then
NextToken
else begin
Error(22);
SkipStatement;
end; {else}
goto 1;
end; {if}
end;
isPascal := lisPascal;
{make sure variables have some type info}
if isFunction then begin
if not typeFound then
if (lint & lintNoFnType) <> 0 then
Error(104);
end {if}
else
if not typeFound then
Error(26);
3:
{handle a function declaration}
if isFunction then begin
if doingParameters then {a function cannot be a parameter}
Error(28);
fnType := variable^.itype; {get the type of the function}
while (fnType <> nil) and (fnType^.kind <> functionType) do
case fnType^.kind of
arrayType : fnType := fnType^.aType;
pointerType: fnType := fnType^.pType;
definedType: fnType := fnType^.dType;
otherwise : fnType := nil;
end; {case}
if fnType = nil then begin
SkipStatement;
goto 1;
end; {if}
Allow "static inline" function declarations. This should give C99-compatible behavior, as far as it goes. The functions aren't actually inlined, but that's just a quality-of-implementation issue. No C standard requires actual inlining. Non-static inline functions are still not supported. The C99 semantics for them are more complicated, and they're less widely used, so they're a lower priority for now. The "inline" function specifier can currently only come after the "static" storage class specifier. This relates to a broader issue where not all legal orderings of declaration specifiers are supported. Since "inline" was already treated as a keyword in ORCA/C, this shouldn't create any extra compatibility issues for C89 code.
2017-06-18 06:32:54 +00:00
if isInline then
if storageClass <> staticsy then
Error(120);
Change all text/source files to LF line endings.
2017-10-21 23:40:19 +00:00
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}
Allow 'extern' storage-class specifier in function definitions. Per the C standards, this is allowed and is equivalent to not specifying a storage-class specifier.
2016-10-20 22:47:01 +00:00
else if token.kind in [commach,semicolonch,inlinesy] then begin
Change all text/source files to LF line endings.
2017-10-21 23:40:19 +00:00
fnType^.isPascal := isPascal; {note if we have pascal parms}
if token.kind = inlinesy then {handle tool declarations}
with fnType^ do begin
NextToken;
Match(lparench,13);
if token.kind in [intconst,uintconst] then begin
toolNum := token.ival;
NextToken;
end {if}
else
Error(18);
Match(commach,86);
if token.kind in [longconst,ulongconst] then begin
dispatcher := token.lval;
NextToken;
end {if}
else if token.kind in [intconst,uintconst] then begin
dispatcher := token.ival;
NextToken;
end {if}
else
Error(18);
Match(rparench,12);
end; {with}
doingParameters := doingPrototypes; {not doing parms any more}
if token.kind = semicolonch then begin
inhibitHeader := false;
NextToken; {skip the trailing semicolon}
end {if}
else if (token.kind = commach) and (not doingPrototypes) then begin
PopTable; {pop the symbol table}
NextToken; {allow further declarations}
variable := nil;
isFunction := false;
Declarator (typeSpec, variable, variableSpace, doingPrototypes);
if variable = nil then begin
inhibitHeader := false;
if token.kind = semicolonch then
NextToken
else begin
Error(22);
SkipStatement;
end; {else}
goto 1;
end; {if}
goto 3;
end {else if}
else begin
Error(22);
SkipStatement;
end; {else}
PopTable; {pop the symbol table}
end {if}
{cannot imbed functions...}
else if doingFunction then begin
isPascal := false;
Error(28);
while token.kind <> eofsy do
NextToken;
end {if}
{local declaration}
else begin
if noFDefinitions then
Error(22);
ftype := fnType^.ftype; {record the type of the function}
while fType^.kind = definedType do
fType := fType^.dType;
variable^.state := defined; {note that the function is defined}
pfunc := variable; {set the identifier for parm checks}
fnType^.isPascal := isPascal; {note if we have pascal parms}
doingFunction := true; {read the parameter list}
doingParameters := true;
{declare the parameters}
lp := lastParameter; {(save now; it's volatile)}
while not (token.kind in [lbracech,eofsy]) do
if (token.kind in [autosy,externsy,registersy,staticsy,typedefsy,
unsignedsy,signedsy,intsy,longsy,charsy,shortsy,
floatsy,doublesy,compsy,extendedsy,enumsy,
structsy,unionsy,typedef,voidsy,volatilesy,
constsy,ident]) then
DoDeclaration(false)
else begin
Error(27);
NextToken;
end; {else}
if numberOfParameters <> 0 then {default K&R parm type is int}
begin
tlp := lp;
while tlp <> nil do begin
if tlp^.itype = nil then
tlp^.itype := wordPtr;
tlp := tlp^.pnext;
end; {while}
end; {if}
tlp := lp; {make sure all parameters have an}
while tlp <> nil do { identifier }
if tlp^.name^ = '?' then begin
Error(113);
tlp := nil;
end {if}
else
tlp := tlp^.pnext;
doingParameters := false;
fName := variable^.name; {skip if this is not needed for a }
if doingPartial then { partial compile }
if not InPartialList(fName) then begin
SkipFunction(isAsm);
goto 2;
end; {if}
TermHeader; {make sure the header file is closed}
if progress then {write progress information}
writeln('Compiling ', fName^);
useGlobalPool := false; {start a local label pool}
if not codegenStarted and (liDCBGS.kFlag <> 0) then begin {init the code generator (if it needs it)}
CodeGenInit (outFileGS, liDCBGS.kFlag, doingPartial);
liDCBGS.kFlag := 3;
codegenStarted := true;
end; {if}
foundFunction := true; {got one...}
segType := ord(variable^.class = staticsy) * $4000;
if fnType^.isPascal then begin
fName := pointer(Malloc(length(variable^.name^)+1));
CopyString(pointer(fName), pointer(variable^.name));
for i := 1 to length(fName^) do
if fName^[i] in ['a'..'z'] then
fName^[i] := chr(ord(fName^[i]) & $5F);
Gen2Name (dc_str, segType, 0, fName);
end {if}
else
Gen2Name (dc_str, segType, 0, variable^.name);
doingMain := variable^.name^ = 'main';
firstCompoundStatement := true;
Gen0 (dc_pin);
if not isAsm then
Add support for inline procedure names as documented in IIgs tech note #103. These are enabled when bit 15 is set in the #pragma debug directive. Support is still needed to ensure these work properly with pre-compiled headers. This patch is from Kelvin Sherlock.
2017-09-10 00:23:27 +00:00
Gen1Name(pc_ent, 0, variable^.name);
Change all text/source files to LF line endings.
2017-10-21 23:40:19 +00:00
nextLocalLabel := 1; {initialize GetLocalLabel}
returnLabel := GenLabel; {set up an exit point}
tempList := nil; {initialize the work label list}
if not isAsm then {generate traceback, profile code}
if traceBack or profileFlag then begin
if traceBack then
nameFound := true;
GenPS(pc_nam, variable^.name);
end; {if}
nextPdisp := 0; {assign displacements to the parameters}
if not fnType^.isPascal then begin
tlp := lp;
lp := nil;
while tlp <> nil do begin
tlp2 := tlp;
tlp := tlp^.pnext;
tlp2^.pnext := lp;
lp := tlp2;
end; {while}
end; {if}
while lp <> nil do begin
lp^.pdisp := nextPdisp;
if lp^.itype^.kind = arrayType then
nextPdisp := nextPdisp + cgPointerSize
else begin
if lp^.itype^.kind = scalarType then
if lp^.itype^.baseType in [cgReal,cgDouble,cgComp] then
{all floating-points are passed as extended}
lp^.itype := extendedPtr;
nextPdisp := nextPdisp + long(lp^.itype^.size).lsw;
if (long(lp^.itype^.size).lsw = 1)
and (lp^.itype^.kind = scalarType) then
nextPdisp := nextPdisp+1;
end; {else}
lp := lp^.pnext;
end; {while}
gotoList := nil; {initialize the label list}
{set up struct/union area}
if variable^.itype^.ftype^.kind in [structType,unionType] then begin
lp := NewSymbol(@'@struct', variable^.itype^.ftype, staticsy,
variablespace, declared);
tk.kind := ident;
tk.class := identifier;
tk.name := @'@struct';
tk.symbolPtr := nil;
lp := FindSymbol(tk, variableSpace, false, true);
Gen1Name(pc_lao, 0, lp^.name);
Gen2t(pc_str, 0, 0, cgULong);
end; {if}
if isAsm then begin
AsmFunction(variable); {handle assembly language functions}
PopTable;
end {if}
else begin
{generate parameter labels}
if fnType^.overrideKR then
GenParameters(nil)
else
GenParameters(fnType^.parameterList);
If 'volatile' is used within a function, only reduce optimization for that function. Previously, several optimizations would be disabled for the rest of the translation unit whenever the keyword 'volatile' appeared. Now, if 'volatile' is used within a function, it only reduces optimization for that function, since whatever was declared as 'volatile' will be out of scope after the function is over. Uses of 'volatile' outside functions still behave as before.
2017-07-12 05:28:11 +00:00
savedVolatile := volatile;
Change all text/source files to LF line endings.
2017-10-21 23:40:19 +00:00
CompoundStatement(false); {process the statements}
end; {else}
end; {else}
2: ;
end {if}
{handle a variable declaration}
else {if not isFunction then} begin
noFDefinitions := true;
if not SkipDeclarator then
repeat
if isPascal then begin
tp := variable^.itype;
while tp <> nil do
case tp^.kind of
scalarType,
enumType,
enumConst,
definedType,
structType,
unionType: begin tp := nil; Error(94); end;
arrayType: tp := tp^.atype;
pointerType: tp := tp^.pType;
functionType: begin tp^.isPascal := true; tp := nil; end;
end; {case}
end; {if}
Allow "static inline" function declarations. This should give C99-compatible behavior, as far as it goes. The functions aren't actually inlined, but that's just a quality-of-implementation issue. No C standard requires actual inlining. Non-static inline functions are still not supported. The C99 semantics for them are more complicated, and they're less widely used, so they're a lower priority for now. The "inline" function specifier can currently only come after the "static" storage class specifier. This relates to a broader issue where not all legal orderings of declaration specifiers are supported. Since "inline" was already treated as a keyword in ORCA/C, this shouldn't create any extra compatibility issues for C89 code.
2017-06-18 06:32:54 +00:00
if isInline then
Error(119);
Change all text/source files to LF line endings.
2017-10-21 23:40:19 +00:00
if token.kind = eqch then begin
if storageClass = typedefsy then
Error(52);
if doingPrototypes then
Error(88);
When arrays are declared using a typedef'd incomplete array type, don't fix the size for all arrays of that type based on the initializer of the first array using it. This fixes the compca07.c test case.
2015-12-31 23:01:26 +00:00
{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;
Change all text/source files to LF line endings.
2017-10-21 23:40:19 +00:00
NextToken; {handle an initializer}
ltypeSpec := typeSpec;
Initializer(variable);
typeSpec := ltypeSpec;
end; {if}
{check to insure array sizes are specified}
if storageClass <> typedefsy then
CheckArray(variable, (storageClass = externsy) or doingParameters);
{allocate space}
if variable^.storage = stackFrame then begin
variable^.lln := GetLocalLabel;
Gen2(dc_loc, variable^.lln, long(variable^.itype^.size).lsw);
end; {if}
if (token.kind = commach) and (not doingPrototypes) then begin
done := false; {allow multiple variables on one line}
NextToken;
variable := nil;
Declarator(typeSpec, variable, variableSpace, doingPrototypes);
if variable = nil then begin
if token.kind = semicolonch then
NextToken
else begin
Error(22);
SkipStatement;
end; {else}
goto 1;
end; {if}
goto 3;
end {if}
else
done := true;
until done or (token.kind = eofsy);
if doingPrototypes then begin
protoVariable := variable; {make the var available to Declarator}
if protoVariable = nil then
protoType := typeSpec
else
protoType := protoVariable^.iType;
end {if}
else begin
inhibitHeader := false;
if token.kind = semicolonch then {must end with a semicolon}
NextToken
else begin
Error(22);
SkipStatement;
end; {else}
end; {else}
end; {else}
1:
doingParameters := lDoingParameters; {restore the status}
useGlobalPool := lUseGlobalPool;
inhibitHeader := false;
end; {DoDeclaration}
procedure DoStatement;
{ process a statement from a function }
procedure AutoInit;
{ initialize auto variables }
var
count: integer; {initializer counter}
ip: identPtr; {pointer to a symbol table entry}
lp1,lp2: identList; {used to reverse, track the list}
iPtr: initializerPtr; {pointer to the next initializer}
procedure Initialize (id: identPtr; disp: longint; itype: typePtr);
{ initialize a variable }
{ }
{ parameters: }
{ id - pointer to the identifier }
{ disp - disp past the identifier to initialize }
{ itype - type of the variable to initialize }
{ }
{ variables: }
{ count - number of times to re-use the initializer }
{ ip - pointer to the initializer record to use }
label 1;
var
elements: longint; {# array elements}
fp: identPtr; {for tracing field lists}
size: integer; {fill size}
union: boolean; {are we doing a union?}
{bit field manipulation}
{----------------------}
bitcount: integer; {# if bits so far}
bitsize,bitdisp: integer; {defines size, location of a bit field}
{assignment conversion}
{---------------------}
tree: tokenPtr; {expression tree}
val: longint; {constant expression value}
isConstant: boolean; {is the expression a constant?}
procedure LoadAddress;
{ Load the address of the operand }
begin {LoadAddress}
with id^ do {load the base address}
case storage of
stackFrame: Gen2(pc_lda, lln, 0);
parameter: if itype^.kind = arrayType then
Gen2t(pc_lod, pln, 0, cgULong)
else
Gen2(pc_lda, pln, 0);
external,
global,
private: Gen1Name(pc_lao, 0, name);
otherwise: ;
end; {case}
if disp <> 0 then
Gen1t(pc_inc, long(disp).lsw, cgULong)
end; {LoadAddress}
function ZeroFill (elements: longint; itype: typePtr;
count: integer; iPtr: initializerPtr): boolean;
{ See if an array can be zero filled }
{ }
{ parameters: }
{ elements - elements in the array }
{ itype - type of each array element }
{ count - remaining initializer repititions }
{ iPtr - initializer record }
begin {ZeroFill}
ZeroFill := false;
if not iPtr^.isConstant then
if itype^.kind in [scalarType,enumType] then
if count >= elements then
with iPtr^.itree^ do
if token.kind = intconst then
if token.ival = 0 then
Fix a problem where zero-initializing a one-byte array would crash the system. Also, generate better code for zero-initializing small arrays. The problem was that the code would call the library routine ~ZERO with a size of 1, but it only works properly with a size of 2 or more. While adding a check here, I also changed it to not call ~ZERO for other small arrays (<=10 bytes), since it is generally more efficient to just initialize them directly. The initializations in the following are examples that could trigger the problem: int main(void) { struct { int i; char s[1]; } foo = {1, 0}; char arr[2][1] = {2}; }
2016-10-17 00:22:29 +00:00
{don't call ~ZERO for very small arrays}
if elements * itype^.size > 10 then
ZeroFill := true;
Change all text/source files to LF line endings.
2017-10-21 23:40:19 +00:00
end; {ZeroFill}
begin {Initialize}
case itype^.kind of
scalarType,pointerType,enumType,functionType: begin
LoadAddress; {load the destination address}
doDispose := count = 1; {generate the expression value}
tree := iptr^.itree; {see if this is a constant}
{do assignment conversions}
while tree^.token.kind = castoper do
tree := tree^.left;
isConstant := tree^.token.class in [intConstant,longConstant];
if isConstant then
if tree^.token.class = intConstant then
val := tree^.token.ival
else
val := tree^.token.lval;
{ if isConstant then
if tree^.token.class = intConstant then
Writeln('loc 2: bitsize = ', iPtr^.bitsize:1, '; ival = ', tree^.token.ival:1) {debug}
{ else
Writeln('loc 2: bitsize = ', iPtr^.bitsize:1, '; lval = ', tree^.token.lval:1) {debug}
{ else
Writeln('loc 2: bitsize = ', iPtr^.bitsize:1); {debug}
GenerateCode(iptr^.iTree);
AssignmentConversion(itype, expressionType, isConstant, val, true,
false);
case itype^.kind of {save the value}
scalarType:
if iptr^.bitsize <> 0 then
Gen2t(pc_sbf, iptr^.bitdisp, iptr^.bitsize, itype^.basetype)
else
Gen0t(pc_sto, itype^.baseType);
enumType:
Gen0t(pc_sto, cgWord);
pointerType,functionType:
Gen0t(pc_sto, cgULong);
end; {case}
end;
arrayType: begin
if itype^.aType^.kind = scalarType then
if itype^.aType^.baseType in [cgByte,cgUByte] then
if iPtr^.iTree^.token.kind = stringConst then begin
GenLdcLong(itype^.elements);
Gen0t(pc_stk, cgULong);
GenS(pc_lca, iPtr^.iTree^.token.sval);
Gen0t(pc_stk, cgULong);
Gen0t(pc_bno, cgULong);
LoadAddress;
Gen0t(pc_stk, cgULong);
Gen0t(pc_bno, cgULong);
Gen1tName(pc_cup, 0, cgVoid, @'strncpy');
iPtr := iPtr^.next;
goto 1;
end; {if}
elements := itype^.elements;
itype := itype^.atype;
if ZeroFill(elements, itype, count, iPtr) then begin
if itype^.kind = enumType then
size := cgWordSize
else
size := TypeSize(itype^.baseType);
size := size * long(elements).lsw;
LoadAddress;
Gen0t(pc_stk, cgULong);
Gen1t(pc_ldc, size, cgWord);
Gen0t(pc_stk, cgWord);
Gen0t(pc_bno, cgULong);
Gen1tName(pc_cup, 0, cgVoid, @'~ZERO');
disp := disp + size;
count := count - long(elements).lsw;
if count = 0 then begin
iPtr := iPtr^.next;
count := iPtr^.count;
end; {if}
end {if}
else begin
while elements <> 0 do begin
Initialize(id, disp, itype);
if itype^.kind in [scalarType,pointerType,enumType] then begin
count := count-1;
if count = 0 then begin
iPtr := iPtr^.next;
count := iPtr^.count;
end; {if}
end; {if}
disp := disp+itype^.size;
elements := elements-1;
end; {while}
end; {else}
1: end;
structType,unionType: begin
Permit unions to be initialized by assignment from expressions of the appropriate union type. This patch should also permit the union initialization code to handle unions containing bit fields, but for the time being they are still prohibited by code elsewhere in the compiler.
2016-10-14 23:30:13 +00:00
if iPtr^.isStructOrUnion then begin
Change all text/source files to LF line endings.
2017-10-21 23:40:19 +00:00
LoadAddress; {load the destination address}
GenerateCode(iptr^.iTree); {load the stuct address}
{do the assignment}
AssignmentConversion(itype, expressionType, isConstant, val,
true, false);
with expressionType^ do
Gen2(pc_mov, long(size).msw, long(size).lsw);
Gen0t(pc_pop, UsualUnaryConversions);
end {if}
else begin
union := itype^.kind = unionType;
fp := itype^.fieldList;
bitsize := iPtr^.bitsize;
bitdisp := iPtr^.bitdisp;
bitcount := 0;
while fp <> nil do begin
itype := fp^.itype;
{ writeln('Initialize: disp = ', disp:3, '; fp^. Disp = ', fp^.disp:3, 'itype^.size = ', itype^.size:1); {debug}
{ writeln(' bitDisp = ', bitDisp:3, '; fp^.bitDisp = ', fp^.bitDisp:3); {debug}
{ writeln(' bitSize = ', bitSize:3, '; fp^.bitSize = ', fp^.bitSize:3); {debug}
Initialize(id, disp, itype);
if bitsize = 0 then begin
if bitcount <> 0 then begin
disp := disp + (bitcount+7) div 8;
bitcount := 0;
end {if}
else if fp^.bitSize <> 0 then begin
bitcount := 8;
while (fp <> nil) and (bitcount > 0) do begin
bitcount := bitcount - fp^.bitSize;
if bitcount > 0 then
if fp^.next <> nil then
if fp^.next^.bitSize <> 0 then
fp := fp^.next
else
bitcount := 0;
end; {while}
bitcount := 0;
disp := disp + 1;
end {else if}
else
disp := disp + itype^.size;
end {if}
else if fp^.bitSize = 0 then begin
bitsize := 0;
disp := disp + itype^.size;
end {else if}
else begin
if bitsize + bitdisp < bitcount then
disp := disp + (bitcount + 7) div 8;
bitcount := bitsize + bitdisp;
end; {else}
if itype^.kind in [scalarType,pointerType,enumType] then begin
count := count-1;
if count = 0 then begin
iPtr := iPtr^.next;
count := iPtr^.count;
bitsize := iPtr^.bitsize;
bitdisp := iPtr^.bitdisp;
end; {if}
end; {if}
if union then
fp := nil
else
fp := fp^.next;
end; {while}
end; {else}
end;
otherwise: Error(57);
end; {case}
end; {Initialize}
begin {AutoInit}
lp1 := nil; {reverse the list}
while initializerList <> nil do begin
lp2 := initializerList;
initializerList := lp2^.next;
lp2^.next := lp1;
lp1 := lp2;
end; {while}
while lp1 <> nil do begin {initialize the variables}
ip := lp1^.id;
iPtr := ip^.iPtr;
count := iPtr^.count;
if ip^.class <> staticsy then
Initialize(ip, 0, ip^.itype);
lp2 := lp1;
lp1 := lp1^.next;
dispose(lp2);
end; {while}
end; {AutoInit}
begin {DoStatement}
case statementList^.kind of
compoundSt: begin
if token.kind = rbracech then begin
if statementList^.doingDeclaration then
if initializerList <> nil then
AutoInit;
EndCompoundStatement;
end {if}
else if (statementList^.doingDeclaration = true)
and (token.kind in [autosy,externsy,registersy,staticsy,typedefsy,
unsignedsy,signedsy,intsy,longsy,charsy,shortsy,
floatsy,doublesy,compsy,extendedsy,enumsy,
structsy,unionsy,typedef,voidsy,volatilesy,
constsy])
then
DoDeclaration(false)
else begin
if statementList^.doingDeclaration then begin
statementList^.doingDeclaration := false;
if firstCompoundStatement then begin
Gen1Name(dc_sym, ord(doingMain), pointer(table));
firstCompoundStatement := false;
end; {if}
if initializerList <> nil then
AutoInit;
end; {if}
Statement;
end; {else}
end;
ifSt:
EndIfStatement;
elseSt:
EndElseStatement;
doSt:
EndDoStatement;
whileSt:
EndWhileStatement;
forSt:
EndForStatement;
switchSt:
EndSwitchStatement;
otherwise: Error(57);
end; {case}
end; {DoStatement}
procedure InitParser;
{ Initialize the parser }
begin {InitParser}
doingFunction := false; {not doing a function (yet)}
doingParameters := false; {not processing parameters}
lastLine := 0; {no pc_lnm generated yet}
nameFound := false; {no pc_nam generated yet}
statementList := nil; {no open statements}
codegenStarted := false; {code generator is not started}
end; {InitParser}
procedure TermParser;
{ shut down the parser }
begin {TermParser}
if statementList <> nil then
case statementList^.kind of
compoundSt : Error(34);
doSt : Error(33);
elseSt : Error(67);
forSt : Error(69);
ifSt : Error(32);
switchSt : Error(70);
whileSt : Error(68);
otherwise: Error(57);
end; {case}
end; {TermParser}
end.
Reference in New Issue Copy Permalink