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