unit dpglib.DelphiGenerator; interface uses System.Classes, System.SysUtils, dpgrtl.types, dpglib.Utils, dpglib.Types, dpglib.CodeGenerator, dpglib.DelphiCharFormatter, dpglib.DelphiBlockFinishingInfo; type // ------------------------------------------------------------------------- // TDelphiGenerator class declaration // ------------------------------------------------------------------------- TDelphiGenerator = class( TCodeGenerator, ICodeGenerator) protected fSaveText : boolean; fSyntacticPredLevel : integer; // ------------------------------------------------------------ // Grammar parameters set up to handle different grammar classes. // There are used to get instance of tests out of code generation. // ------------------------------------------------------------ fLabeledElemType : AnsiString; fLabeledElemInit : AnsiString; fCommonExtraArgs : AnsiString; fCommonExtraParams : AnsiString; fCommonLocalVars : AnsiString; fLT1Value : AnsiString; fExceptionThrown : AnsiString; fThrowNoViable : AnsiString; fSemPreds : TStringList; // ------------------------------------------------------------ // AST studd // ------------------------------------------------------------ fCurrentASTResult : AnsiString; // ------------------------------------------------------------ // Tracks the rule being generated. Used for mapTreeId. // ------------------------------------------------------------ fCurrentRule : IRuleBlock; function altIsEmpty( pAlt: IAlternative) : boolean; function throw( pLA1: ILookahead) : AnsiString; function needsLexerInit : boolean; private // function suitableForCaseExpression( pAlt: IAlternative): boolean; function lookaheadIsEmpty( pAlt: IAlternative; pMaxDepth: integer): boolean; // function lookaheadString( pK: integer): AnsiString; procedure genRule( pRuleSymbol : IRuleSymbol); procedure genSemPred( pSemPred : AnsiString); procedure genSynPred( pBlock : ISynPredBlock; pLookaheadExpr : AnsiString); function genCommonBlock( pBlock : IAlternativeBlock; pNoTestForSingle : boolean) : TDelphiBlockFinishingInfo; procedure genBlockFinish( pHowToFinish : TDelphiBlockFinishingInfo; pNoViableAction : AnsiString; pSingleLine : boolean = false); protected GenAST : boolean; protected // ------------------------------------------------------------ // Internals // ------------------------------------------------------------ procedure genTokens; procedure genUses; procedure genUses2; procedure genClassDecl; procedure genMethodDecl( pRuleSymbol : IRuleSymbol; pLength : integer=0; pFull : boolean=true); procedure genClassDef; procedure genRuleLocals( pRuleBlock: IRuleBlock); procedure genInitLiterals; procedure genNextToken; procedure genLiteralsTest; procedure genLiteralsTestForPartialToken; procedure genBlockInitAction( pBlock : IAlternativeBlock); procedure genRuleInvocation( pRuleRefElem : IRuleRefElem); procedure genAlt( pAlt : IAlternative; pBlk : IAlternativeBlock); // ------------------------------------------------------------ // ICodeGenerator overrides // ------------------------------------------------------------ procedure Gen( pGrammar : IGrammar); overload; override; procedure genMatch( pAtom : IGrammarAtom); procedure genMatchUsingAtomText( pAtom : IGrammarAtom); procedure genMatchUsingAtomTokenType(pAtom : IGrammarAtom); function getValueString( pType : integer): AnsiString; procedure genPredictExpr( pLaList : TInterfaceList; pLaDepth : integer); protected procedure Gen( pAction : IActionElem); overload; override; procedure Gen( pBlock : IAlternativeBlock); overload; override; procedure Gen( pEnd : IBlockEndElem); overload; override; procedure Gen( pAtom : ICharLiteralElem); overload; override; procedure Gen( pAtom : ICharRangeElem); overload; override; procedure Gen( pAtom : IGrammarAtom); overload; override; procedure Gen( pBlk : IRuleBlock); overload; override; procedure Gen( pElem : IRuleEndElem); overload; override; procedure Gen( pRuleRef : IRuleRefElem); overload; override; procedure Gen( pAtom : IStringLiteralElem); overload; override; procedure Gen( pBlk : ISynPredBlock); overload; override; procedure Gen( pTokenRef: ITokenRefElem); overload; override; procedure Gen( pElem : ITokenRangeElem); overload; override; procedure Gen( pBlock : IOneOrMoreBlock); overload; override; procedure Gen( pBlock : INMBlock); overload; override; procedure Gen( pWc : IWildcardElem); overload; override; procedure Gen( pBlock : IZeroOrMoreBlock); overload; override; function getLookaheadTestExpr( pAlt : IAlternative; pMaxDepth : integer) : AnsiString; overload; function getLookaheadTestExpr( pLaList : TInterfaceList; pLaDepth : integer) : AnsiString; overload; function getLookaheadTestTerm( pK : integer; pLA : ILookahead) : AnsiString; function getLookaheadString( pK: integer) : AnsiString; protected function addSemPred( pSemPred: AnsiString): integer; procedure exitIfError; protected fIsLexer : boolean; fIsParser : boolean; fIsTreeWalker : boolean; fLexerGrammar : ILexerGrammar; fParserGrammar : IParserGrammar; fTreeWalkerGrammar : ITreeWalkerGrammar; public constructor Create( OutputDir : AnsiString; ExchangeDir : AnsiString); destructor Destroy; override; end; implementation uses dpglib.GrammarMaker, dpglib.RuleSymbol, dpglib.Version, dpglib.Messages; // ---------------------------------------------------------------------------- // Constructor // ---------------------------------------------------------------------------- constructor TDelphiGenerator.Create( OutputDir : AnsiString; ExchangeDir : AnsiString); begin inherited; fSaveText := true; fSyntacticPredLevel := 0; fCharFormatter := TDelphiCharFormatter.Create; fIsLexer := false; fIsParser := false; fIsTreeWalker := false; fLexerGrammar := nil; fParserGrammar := nil; fTreeWalkerGrammar := nil; GenAST := false; end; // ---------------------------------------------------------------------------- // Destructor // ---------------------------------------------------------------------------- destructor TDelphiGenerator.Destroy; begin fLexerGrammar := nil; fParserGrammar := nil; fTreeWalkerGrammar := nil; fCharFormatter := nil; fCurrentRule := nil; FreeAndNil(fSemPreds); inherited; end; // **************************************************************************** // ICodeGenerator overrides // **************************************************************************** // ---------------------------------------------------------------------------- // Gen (grammar) // ---------------------------------------------------------------------------- procedure TDelphiGenerator.Gen(pGrammar: IGrammar); begin fGrammar := pGrammar; fGrammar.Generator := self; fAnalyzer := fGrammar.LLkAnalyzer; fTool := fGrammar.Tool; fTabs := 0; // --------------------------------------------------------------- // Set up internals depending on grammar type // --------------------------------------------------------------- fGrammar.QueryInterface( ILexerGrammar, fLexerGrammar); fGrammar.QueryInterface( IParserGrammar, fParserGrammar); fGrammar.QueryInterface( ITreeWalkerGrammar, fTreeWalkerGrammar); if fLexerGrammar <> nil then fIsLexer := true; if fParserGrammar <> nil then fIsParser := true; if fTreeWalkerGrammar<> nil then fIsTreeWalker := true; if fLexerGrammar <> nil then fLT1Value := 'LA(1)'; if fParserGrammar <> nil then fLT1Value := 'LT(1)'; if fTreeWalkerGrammar<> nil then fLT1Value := '_t'; fThrowNoViable := 'Raise EMismatchedChar.Create(' + 'LA(1), _first, InputState.FileName, InputState.Line, InputState.Column);'; if Assigned(fParserGrammar) then GenAST := fParserGrammar.BuildAST else GenAST := false; // --------------------------------------------------------------- // Generate token exchange and token type definition file. // --------------------------------------------------------------- genTokenExchange; genTokens; // --------------------------------------------------------------- // Calculate the output file name, and open it. // --------------------------------------------------------------- fFile := fOutDir + fGrammar.UnitName + '.pas'; fOutput := TFileStream.Create( fFile, fmCreate); // --------------------------------------------------------------- // Generate red tape // --------------------------------------------------------------- println('// ============================================================================'); println('// This file is generated by the Delphi Parser Generator.'); println('// ----------------------------------------------------------------------------'); println('// DPG version: ' + version); println('// Grammar: ' + fGrammar.GrammarFile); println('// ============================================================================'); println('unit ' + fGrammar.UnitName + ';'); println(''); println('interface'); println(''); // --------------------------------------------------------------- // Generate uses clause, class declaration // --------------------------------------------------------------- genUses; genClassDecl; println(''); println('implementation'); genUses2; println(''); // println('uses'); // INC(fTabs); // println('dpgException,'); // println('dpgExceptionSemantic,'); // if fIsLexer then // println('dpgExceptionMismatchedChar;') // else // println('dpgExceptionMismatchedToken;'); // DEC(fTabs); // println(''); // --------------------------------------------------------------- // Generate the class definition // --------------------------------------------------------------- genClassDef; println('end.'); fOutput.Free; end; // **************************************************************************** // Internals // **************************************************************************** // ============================================================================ // Gen(Action) - {...} // ============================================================================ procedure TDelphiGenerator.Gen(pAction: IActionElem); begin if pAction.IsSemPred then genSemPred( pAction.ActionText) else begin if fGrammar.HasSynPred then begin println(''); println('if InputState.Guessing = 0 then'); println('begin'); INC(fTabs); end; printAction( pAction.ActionText); if fGrammar.HasSynPred then begin DEC(fTabs ); println('end;'); end; end; end; // ============================================================================ // Gen(AlternativeBlock) // ============================================================================ procedure TDelphiGenerator.Gen(pBlock: IAlternativeBlock); var htf : TDelphiBlockFinishingInfo; cur : AnsiString; begin genBlockInitAction( pBlock); // Tell AST generation to build subrule result cur := fCurrentASTResult; if pBlock.Lbl <> '' then fCurrentASTResult := pBlock.Lbl; fGrammar.LLkAnalyzer.Deterministic( pBlock); htf := genCommonBlock( pBlock, true); genBlockFinish( htf, throw(pBlock.Look(1)), true); // Restore previous AST generation fCurrentASTResult := cur; end; // ============================================================================ // Gen(CharLiteralElem) // ============================================================================ procedure TDelphiGenerator.Gen(pAtom: ICharLiteralElem); var oldSaveText: boolean; begin if pAtom.Lbl <> '' then println(pAtom.Lbl + ' := ' + fLT1Value + ';'); oldSaveText := fSaveText; fSaveText := fSaveText and (pAtom.AutoGenType = AUTOGEN_NONE); if oldSaveText and not fSaveText then println('SaveConsumedInput := false;'); genMatch( pAtom); if oldSaveText and not fSaveText then println('SaveConsumedInput := true;'); fSaveText := oldSaveText; end; // ============================================================================ // Gen(CharRangeElem) // ============================================================================ procedure TDelphiGenerator.Gen(pAtom: ICharRangeElem); var oldSaveText: boolean; begin if (pAtom.Lbl <> '') and (fSyntacticPredLevel = 0) then println(pAtom.Lbl + ':=' + fLT1Value + ';'); oldSaveText := fSaveText; fSaveText := fSaveText and (pAtom.AutoGenType = AUTOGEN_NONE); if oldSaveText and not fSaveText then println('SaveConsumedInput := false;'); if pAtom.BeginChar < pAtom.EndChar then println('match( [' + CharSetToStr( [pAtom.BeginChar..pAtom.EndChar]) + ']);') else println('match( [' + CharSetToStr( [pAtom.EndChar..pAtom.BeginChar]) + ']);'); if oldSaveText and not fSaveText then println('SaveConsumedInput := true;'); fSaveText := oldSaveText; end; // ============================================================================ // Gen(OneOrMoreBlock) - (...)+ // ============================================================================ procedure TDelphiGenerator.Gen(pBlock: IOneOrMoreBlock); var i : integer; lbl : AnsiString; cnt : AnsiString; predictExit : AnsiString; nonGreedyExitPath : boolean; nonGreedyExitDepth: integer; laList : TInterfaceList; htf : TDelphiBlockFinishingInfo; exitBranch : AnsiString; begin if pBlock.Lbl <> '' then begin cnt := '_cnt_' + pBlock.Lbl; lbl := '_loop' + pBlock.Lbl; end else begin cnt := '_cnt_' + IntToStr(pBlock.ID); lbl := '_loop' + IntToStr(pBlock.ID); end; println(cnt + ' := 0;'); println(''); println('while(true) do'); println('begin'); INC(fTabs); // --------------------------------------------------------------- // Generate init action for (...)+ // --------------------------------------------------------------- genBlockInitAction( pBlock); fGrammar.LLkAnalyzer.Deterministic( pBlock); // --------------------------------------------------------------- // Generate exit test if greedy set to false and an alt is ambigous // with exit branch or when lookahead derived purely from // end-of-file. Lookahead analysis stops when end-of-file is hit, // returning set (epsilon). Since (epsilon) is not ambigous with // any real tokens, no error is reported by deterministic() routines // and we have to check for the case where the lookahead depth // didn't get set to NONDETERMINISTIC (this only happens when the // FOLLOW contains real atoms + epsilon. // --------------------------------------------------------------- nonGreedyExitPath := false; nonGreedyExitDepth := fGrammar.MaxK; if (not pBlock.Greedy) and (pBlock.ExitDepth <= fGrammar.MaxK) and pBlock.ExitCache[pBlock.ExitDepth].HasEpsilon then begin nonGreedyExitPath := true; nonGreedyExitDepth:= pBlock.ExitDepth; end else if (not pBlock.Greedy) and (pBlock.ExitDepth = NONDETERMINISTIC) then nonGreedyExitPath := true; // --------------------------------------------------------------- // Generate exit test if greedy set to false and an alternative // is ambiguous with exit branch. // --------------------------------------------------------------- if nonGreedyExitPath then begin // ------------------------------------------------------------ // Generate lookahead test expression // ------------------------------------------------------------ laList := TInterfaceList.Create; for i:=1 to nonGreedyExitDepth do laList.Add( pBlock.ExitCache[i]); predictExit := getLookaheadTestExpr( laList, nonGreedyExitDepth); println('// non-greedy exit test'); println('if (' + cnt + ') >= 1) and '); INC(fTabs); printAction('{'+#13+#10 + predictExit +#13+#10+'}'); println('then break;'); println(''); DEC(fTabs); end; // --------------------------------------------------------------- // Prepare exit branch // --------------------------------------------------------------- exitBranch := ''; exitBranch := exitBranch + 'if ' + cnt + ' >= 1 then' +#13+#10; exitBranch := exitBranch + fTab + 'break' +#13+#10; exitBranch := exitBranch + 'else' +#13+#10; exitBranch := exitBranch + fTab + throw(pBlock.Look(1)) +#13+#10; htf := genCommonBlock(pBlock,false); genBlockFinish( htf, exitBranch); // --------------------------------------------------------------- // Finalize the loop // --------------------------------------------------------------- println(''); println('INC(' + cnt + ');'); DEC(fTabs); println('end;'); end; // ================================================================================================ // M to N Block (...)@(m,n) // ================================================================================================ procedure TDelphiGenerator.Gen( pBlock: INMBlock); var i : integer; lbl : AnsiString; cnt : AnsiString; predictExit : AnsiString; nonGreedyExitPath : boolean; nonGreedyExitDepth: integer; laList : TInterfaceList; htf : TDelphiBlockFinishingInfo; exitBranch : AnsiString; m : integer; n : integer; mStr : AnsiString; nStr : AnsiString; begin if pBlock.Lbl <> '' then begin cnt := '_cnt_' + pBlock.Lbl; lbl := '_loop' + pBlock.Lbl; end else begin cnt := '_cnt_' + IntToStr(pBlock.ID); lbl := '_loop' + IntToStr(pBlock.ID); end; m := pBlock.Low; n := pBlock.High; mStr := IntToStr( m); nStr := IntToStr( n); println(cnt + ' := 0;'); println(''); // println('while(true) do'); println('while ' +cnt+ ' < ' +nStr+ ' do'); println('begin'); INC(fTabs); // --------------------------------------------------------------- // Generate init action for (...)@ // --------------------------------------------------------------- genBlockInitAction( pBlock); fGrammar.LLkAnalyzer.Deterministic( pBlock); // --------------------------------------------------------------- // Generate exit test if greedy set to false and an alt is ambigous // with exit branch or when lookahead derived purely from // end-of-file. Lookahead analysis stops when end-of-file is hit, // returning set (epsilon). Since (epsilon) is not ambigous with // any real tokens, no error is reported by deterministic() routines // and we have to check for the case where the lookahead depth // didn't get set to NONDETERMINISTIC (this only happens when the // FOLLOW contains real atoms + epsilon. // --------------------------------------------------------------- nonGreedyExitPath := false; nonGreedyExitDepth := fGrammar.MaxK; if (not pBlock.Greedy) and (pBlock.ExitDepth <= fGrammar.MaxK) and pBlock.ExitCache[pBlock.ExitDepth].HasEpsilon then begin nonGreedyExitPath := true; nonGreedyExitDepth:= pBlock.ExitDepth; end else if (not pBlock.Greedy) and (pBlock.ExitDepth = NONDETERMINISTIC) then nonGreedyExitPath := true; // --------------------------------------------------------------- // Generate exit test if greedy set to false and an alternative // is ambiguous with exit branch. // --------------------------------------------------------------- if nonGreedyExitPath then begin // ------------------------------------------------------------ // Generate lookahead test expression // ------------------------------------------------------------ laList := TInterfaceList.Create; for i:=1 to nonGreedyExitDepth do laList.Add( pBlock.ExitCache[i]); predictExit := getLookaheadTestExpr( laList, nonGreedyExitDepth); println('// non-greedy exit test'); println('if (' + cnt + ') >= 1) and '); INC(fTabs); printAction('{'+#13+#10 + predictExit +#13+#10+'}'); println('then break;'); println(''); DEC(fTabs); end; // --------------------------------------------------------------- // Prepare exit branch // --------------------------------------------------------------- exitBranch := ''; // --------------------------------------------------------------- // @(m) // // The exit condition is tested by teh *while* loop, so here we // define the exception generation. // --------------------------------------------------------------- if (m>0) and (m=n) then exitBranch := fTab + throw(pBlock.Look(1)) +#13+#10 // ------------------------------------------------------------------------- // @(,n) // ------------------------------------------------------------------------- else if (m=0) and (n>0) then exitBranch := fTab + 'break' +#13+#10 // ------------------------------------------------------------------------- // @(m,n), @(m,) // ------------------------------------------------------------------------- else if (m>0) and (n>m) then begin exitBranch := ''; exitBranch := exitBranch + 'if ' +cnt+ ' >= ' +mStr+ ' then' +#13+#10; exitBranch := exitBranch + fTab + 'break' +#13+#10; exitBranch := exitBranch + 'else' +#13+#10; exitBranch := exitBranch + fTab + throw(pBlock.Look(1)) +#13+#10; end; htf := genCommonBlock(pBlock,false); genBlockFinish( htf, exitBranch); // --------------------------------------------------------------- // Finalize the loop // --------------------------------------------------------------- println(''); println('INC(' + cnt + ');'); DEC(fTabs); println('end;'); end; // ============================================================================ // Gen(RuleRef) // ============================================================================ procedure TDelphiGenerator.Gen(pRuleRef: IRuleRefElem); var ts : ITokenSymbol; rs : IRuleSymbol; save : boolean; rname : AnsiString; begin ts := fGrammar.Symbol[pRuleRef.TargetRule]; // --------------------------------------------------------------- // If the symbol not exists in the grammar, error... // --------------------------------------------------------------- if ts = nil then begin if fIsLexer then rname := TCodeGenerator.decodeLexerRuleName( pRuleRef.TargetRule) else rname := pRuleRef.TargetRule; fTool.Error(Format(MSG_E_RULENOTDEFINED,[rname]), fGrammar.GrammarFile, pRuleRef.Line, pRuleRef.Column); exit; end; // --------------------------------------------------------------- // If the symbol exists, but not defined, error... // --------------------------------------------------------------- rs := ts as IRuleSymbol; if not rs.Defined then begin if fIsLexer then rname := TCodeGenerator.decodeLexerRuleName( pRuleRef.TargetRule) else rname := pRuleRef.TargetRule; fTool.Error(Format(MSG_E_RULENOTDEFINED,[rname]), fGrammar.GrammarFile, pRuleRef.Line, pRuleRef.Column); exit; end; // --------------------------------------------------------------- // If in lexer and ! on ruleref or alt or rule, save buffer index // to kill later. // --------------------------------------------------------------- if fIsLexer and ((not fSaveText) or (pRuleRef.AutoGenType = AUTOGEN_BANG)) then println('_save := Length( TokenText);'); print(''); // --------------------------------------------------------------- // Process return value if any. // --------------------------------------------------------------- if pRuleRef.IdAssign <> '' then begin // ------------------------------------------------------------ // Warn if the rule has no return value. // ------------------------------------------------------------ if rs.Block.ReturnAction = '' then begin fTool.Warning( Format(MSG_W_RULEHASNORETURN,[pRuleRef.TargetRule]), fGrammar.GrammarFile, pRuleRef.Line, pRuleRef.Column); end; _print( pRuleRef.IdAssign + ' := '); end else begin // ------------------------------------------------------------ // Warn about return value if any, but not inside syntactic // predicate. // ------------------------------------------------------------ if (not fIsLexer) and (fSyntacticPredLevel = 0) and (rs.Block.ReturnAction <> '') then begin fTool.Warning( Format(MSG_W_RULEHASRETURN,[pRuleRef.TargetRule]), fGrammar.GrammarFile, pRuleRef.Line, pRuleRef.Column); end; end; // --------------------------------------------------------------- // Call the rule. // --------------------------------------------------------------- genRuleInvocation( pRuleRef); // --------------------------------------------------------------- // Now kill the buffer... // --------------------------------------------------------------- if fIsLexer and ((not fSaveText) or (pRuleRef.AutoGenType = AUTOGEN_BANG)) then println('TokenText := Copy(TokenText, 1, _save);'); // --------------------------------------------------------------- // Always generate variable for rule return on labeled rules // --------------------------------------------------------------- if pRuleRef.Lbl <> '' then begin if fIsTreeWalker then ; if fIsLexer then println( pRuleRef.Lbl + ' := ReturnToken;'); end; end; // ============================================================================ // Gen(ZeroOrMoreBlock) (...)* // ============================================================================ procedure TDelphiGenerator.Gen(pBlock: IZeroOrMoreBlock); var i: integer; nonGreedyExitPath : boolean; nonGreedyExitDepth : integer; predictExit : AnsiString; laList : TInterfaceList; htf : TDelphiBlockFinishingInfo; begin println(''); println('while(true) do'); println('begin'); INC(fTabs); // --------------------------------------------------------------- // Generate the init action for ()+ ()* inside the loop. // This allows us to do useful EOF checking. // --------------------------------------------------------------- genBlockInitAction( pBlock); fGrammar.LLkAnalyzer.Deterministic( pBlock); // --------------------------------------------------------------- // Generate exit test if greedy set to false and an alt is ambigous // with exit branch or when lookahead derived purely from end-of-file. // Lookahead analysis stops when end-of-file is hit, returning set // (epsilon). Since (epsilon) is not ambigous with any real tokens, // no error is reported by deterministic() routines and we have to // check for to NONDETERMINISTIC (this only happens when the FOLLOW // contains real atoms + epsilon). // --------------------------------------------------------------- nonGreedyExitPath := false; nonGreedyExitDepth := fGrammar.MaxK; if (not pBlock.Greedy) and (pBlock.ExitDepth <= fGrammar.MaxK) and (pBlock.ExitCache[pBlock.ExitDepth].HasEpsilon) then begin nonGreedyExitPath := true; nonGreedyExitDepth:= pBlock.ExitDepth; end else if (not pBlock.Greedy) and (pBlock.ExitDepth = NONDETERMINISTIC) then nonGreedyExitPath := true; // --------------------------------------------------------------- // Generate exit test if greedy set to false and an alternative // is ambiguous with exit branch. // --------------------------------------------------------------- if nonGreedyExitPath then begin // ------------------------------------------------------------ // Generate lookahead test expression // ------------------------------------------------------------ laList := TInterfaceList.Create; for i:=1 to nonGreedyExitDepth do laList.Add( pBlock.ExitCache[i]); predictExit := getLookaheadTestExpr( laList, nonGreedyExitDepth); println('// non-greedy exit test'); println('if' + predictExit + ' then'); INC(fTabs); println('break;'); println(''); DEC(fTabs); end; htf := genCommonBlock( pBlock, false); genBlockFinish( htf, fTab + 'break;', true); DEC( fTabs); println('end;'); println(''); end; // ============================================================================ // genTokens // ============================================================================ procedure TDelphiGenerator.genTokens; var i : integer; len : integer; xxx : integer; line : AnsiString; frm : AnsiString; _file : AnsiString; name : AnsiString; value : AnsiString; ts : ITokenSymbol; ss : IStringSymbol; begin // --------------------------------------------------------------- // Calculate the output file name, and open it. // --------------------------------------------------------------- _file := (*fOutDir +*) fGrammar.ExportVocab + 'Tokens.pas'; _file := fOutDir + fGrammar.UnitName + 'Tokens.pas'; fOutput := TFileStream.Create( _file, fmCreate); // --------------------------------------------------------------- // Calculate maximum length of the token names. // --------------------------------------------------------------- len := 0; for i:=0 to fGrammar.TokenManager.Vocabulary.Count -1 do begin ts := fGrammar.TokenManager.TokenSymbolAt[i]; if ts <> nil then if len < Length( ts.ID) then len := Length( ts.ID); end; // --------------------------------------------------------------- // Add prefix length also // --------------------------------------------------------------- if Length(fTokPrefix) > Length( fLitPrefix) then len := len + Length( fTokPrefix) else len := len + Length( fLitPrefix); // --------------------------------------------------------------- // Write a header :) // --------------------------------------------------------------- println('// ============================================================================'); println('// This file is generated by the Delphi Parser Generator.'); println('// ----------------------------------------------------------------------------'); println('// DPG version: ' + version); println('// Grammar: ' + fGrammar.GrammarFile); println('// ============================================================================'); println('unit ' + fGrammar.ExportVocab + 'Tokens;'); println(''); println('interface'); println(''); println('const'); // --------------------------------------------------------------- // Write out the tokens // --------------------------------------------------------------- fTabs := 1; frm := '%-' + IntToStr(len) + 's = %s;'; for name in fGrammar.TokenManager.Vocabulary.Keys do begin value := IntToStr( fGrammar.TokenManager.Vocabulary.Items[name]); ts := fGrammar.TokenManager.TokenSymbol[name]; ss := nil; if ts <> nil then ts.QueryInterface( IStringSymbol, ss); if name[1] <> '<' then begin // --------------------------------------------------------- // Handle AnsiString symbols. // --------------------------------------------------------- if name[1] = '"' then begin if ss <> nil then begin if ss.Lbl = '' then ss.Lbl := fLitPrefix + Copy( name, 2, Length(name)-2); line := Format( frm, [ss.Lbl, value]); println( line); end; end // --------------------------------------------------------- // Handle token symbols. // --------------------------------------------------------- else begin if ts <> nil then begin line := Format( frm, [fTokPrefix + name, value]); println( line); end // else // fGrammar.Tool.Error( 'Undefined token symbol' + name); end end end; (* for i:=0 to fGrammar.TokenManager.Vocabulary.Count -1 do begin name := fGrammar.TokenManager.Vocabulary.Names[i]; value := fGrammar.TokenManager.Vocabulary.Values[name]; ts := fGrammar.TokenManager.TokenSymbol[name]; ss := nil; if ts <> nil then ts.QueryInterface( IStringSymbol, ss); if name[1] <> '<' then begin // --------------------------------------------------------- // Handle AnsiString symbols. // --------------------------------------------------------- if name[1] = '"' then begin if ss <> nil then begin if ss.Lbl = '' then ss.Lbl := fLitPrefix + Copy( name, 2, Length(name)-2); line := Format( frm, [ss.Lbl, value]); println( line); end; end // --------------------------------------------------------- // Handle token symbols. // --------------------------------------------------------- else begin if ts <> nil then begin line := Format( frm, [fTokPrefix + name, value]); println( line); end // else // fGrammar.Tool.Error( 'Undefined token symbol' + name); end end end; *) fTabs := 0; // --------------------------------------------------------------- // Generate the rest... // --------------------------------------------------------------- println(''); println('implementation'); println('end.'); fOutput.Free; end; // ============================================================================ // genInitLiterals // ============================================================================ procedure TDelphiGenerator.genInitLiterals; var i : integer; l : integer; len : integer; line : AnsiString; frm : AnsiString; name : AnsiString; value : AnsiString; s : AnsiString; begin println('// ----------------------------------------------------------------------------'); println('// InitLiterals'); println('// ----------------------------------------------------------------------------'); println('procedure ' + fGrammar.GrammarName + '.initialize;'); println('begin'); INC(fTabs); if not fLexerGrammar.CaseSensitive then begin println('fCaseSensitive := false;'); println('fLiterals.CaseSensitive := false;'); println(''); end; // --------------------------------------------------------------- // Calculate maximum length of the AnsiString literal names. // --------------------------------------------------------------- len := 0; for name in fGrammar.TokenManager.Vocabulary.Keys do begin if name[1] = '"' then begin l := Length(name) -2; if len < l then len := l; end; end; (* for i:=0 to fGrammar.TokenManager.Vocabulary.Count -1 do begin name := fGrammar.TokenManager.Vocabulary.Names[i]; if name[1] = '"' then begin name := Copy( name, 2, Length(name)-2); if len < Length( name) then len := Length( name); end; end; *) // --------------------------------------------------------------- // Add minimum 1 extra space for spearator // --------------------------------------------------------------- INC(len); // --------------------------------------------------------------- // Write out the code // --------------------------------------------------------------- for s in fGrammar.TokenManager.Vocabulary.Keys do begin value := IntToStr( fGrammar.TokenManager.Vocabulary.Items[s]); if not fLexerGrammar.CaseSensitive then name := AnsiLowerCase(s) else name := s; if name[1] = '"' then begin name := Copy( name, 2, Length(name)-2); frm := 'fLiterals[''%s''%' + IntToStr( len - Length(name)) +'s] :=%3.3s;'; line := Format( frm, [name,' ',value]); println(line); end end; (* for i:=0 to fGrammar.TokenManager.Vocabulary.Count -1 do begin name := fGrammar.TokenManager.Vocabulary.Names[i]; value := fGrammar.TokenManager.Vocabulary.Values[name]; if not fLexerGrammar.CaseSensitive then name := LowerCase( name); if name[1] = '"' then begin name := Copy( name, 2, Length(name)-2); frm := 'fLiterals[''%s''%' + IntToStr( len - Length(name)) +'s] :=%3.3s;'; line := Format( frm, [name,' ',value]); println(line); end; end; *) // --------------------------------------------------------------- // Close the procedure // --------------------------------------------------------------- DEC(fTabs); println('end;'); println(''); end; // ---------------------------------------------------------------------------- // genNextToken // ---------------------------------------------------------------------------- procedure TDelphiGenerator.genNextToken; var i : integer; b : boolean; a : IAlternative; rs : IRuleSymbol; rb : IRuleBlock; filterMode : boolean; filterRule : AnsiString; errFin : AnsiString; blkFin : TDelphiBlockFinishingInfo; first : TByteSet; begin // --------------------------------------------------------------- // Generate method header // --------------------------------------------------------------- println('// ----------------------------------------------------------------------------'); println('// NextToken'); println('// ----------------------------------------------------------------------------'); println('function ' + fGrammar.GrammarName + '.NextToken : IToken;'); // --------------------------------------------------------------- // Check for at least 1 public rule. // --------------------------------------------------------------- b := false; for i:=0 to fGrammar.Rules.Count -1 do begin fGrammar.Rules.Items[i].QueryInterface(IRuleSymbol, rs); if rs.Access = 'public' then begin b := true; break; end; end; // --------------------------------------------------------------- // If the grammar has no public rule, then generate fake method // returning TT_EOF // --------------------------------------------------------------- if b = false then begin println('begin'); INC(fTabs); println('result := TToken.Create(TT_EOF);'); DEC(fTabs); println('end;'); exit; end; // --------------------------------------------------------------- // OK. Here we have at least one public rule. // Create a synthesized NextToken rule // --------------------------------------------------------------- rb := TGrammarMaker.CreateNextTokenRule( fGrammar, fGrammar.Rules, 'NextToken'); rs := TRuleSymbol.Create('mNextToken'); rs.Defined := true; rs.Block := rb; rs.Access := 'private'; fGrammar.Define( rs); // --------------------------------------------------------------- // Analyze the rule // --------------------------------------------------------------- fGrammar.LLkAnalyzer.Deterministic(rb); first := rb.Look(1).LaSet; // --------------------------------------------------------------- // OK, now generate... // --------------------------------------------------------------- filterMode := fLexerGrammar.FilterMode; filterRule := fLexerGrammar.FilterRule; // --------------------------------------------------------------- // ...local vars... // --------------------------------------------------------------- // println('var'); // INC(fTabs); // println('_ttype : integer;'); // --------------------------------------------------------------- // If the lexer isn't a filter lexer, then we need the FIRST set // in error message. // --------------------------------------------------------------- if not filterMode then begin println('var'); println(fTab + '_first : TCharSet;'); println(''); end // --------------------------------------------------------------- // In filter lexer check that this is a simple filter or a filter // rule is defined. If filter rule defined, then define local var // to mark the lexer state. // --------------------------------------------------------------- else begin if filterRule <> '' then begin println('var'); println(fTab + '_mark : integer;'); println(''); end; end; println('begin'); INC(fTabs); // --------------------------------------------------------------- // ...local var init... // --------------------------------------------------------------- // --------------------------------------------------------------- // If the lexer isn't a filter lexer, initialize FIRST set. // in error message. // --------------------------------------------------------------- if not filterMode then begin println('_first := [' + CharSetToStr( first) + '];'); println(''); end; // --------------------------------------------------------------- // ...code... // --------------------------------------------------------------- println('while( true) do'); println('begin'); INC(fTabs); // println('_ttype := TT_INVALID;'); // println('CommitToPath := false;'); if filterRule <> '' then begin // ------------------------------------------------------------ // Here's a good place to ensure that the filter rule // actually exists. // ------------------------------------------------------------ if not fGrammar.Defined( encodeLexerRuleName( filterRule)) then fTool.Error(Format(MSG_E_NOFILTERRULE, [filterRule])) else begin fGrammar.Symbol[encodeLexerRuleName(filterRule)].QueryInterface( IRuleSymbol,rs); if rs.Access <> 'protected' then fTool.Error( Format( MSG_E_PROTECTEDFILTER, [filterRule])); // fTool.Error('Filter rule ' + filterRule + 'must be protected.'); end; println('_mark := mark;'); end; println('ResetText;'); println(''); // ------------------------------------------------------------ // Generate try around whole thing to trap scanner errors. // ------------------------------------------------------------ println('try'); INC(fTabs); // --------------------------------------------------------------- // Test for public lexical rules with empty paths // --------------------------------------------------------------- for i:=0 to rb.Alternatives.Count -1 do begin rb.Alternatives[i].QueryInterface(IAlternative, a); if a.Cache[1].Epsilon <> [] then begin fTool.Warning( MSG_W_OPTIONALPATH, fGrammar.GrammarFile, 0, 0); // fTool.Warning('Optional path found in NextToken.'); // fLexerGrammar.Tool.Warning('Optional path found in NextToken.'); break; end; end; // --------------------------------------------------------------- // Generate the block // --------------------------------------------------------------- genCommonBlock( rb, false); errFin := 'if LA(1) = EOF_CHAR then' +#13+#10; errFin := errFin + 'begin' +#13+#10; errFin := errFin + fTab + 'uponEof;' +#13+#10; errFin := errFin + fTab + 'result := TToken.Create(TT_EOF);' +#13+#10; errFin := errFin + 'end' +#13+#10; errFin := errFin +#13+#10; // ------------------------------------------------------------ // Filter mode // ------------------------------------------------------------ if filterMode then begin if filterRule = '' then begin errFin := errFin + 'else' +#13+#10; errFin := errFin + 'begin' +#13+#10; errFin := errFin + fTab + 'consume;' +#13+#10; errFin := errFin + fTab + 'continue;' +#13+#10; errFin := errFin + 'end;';// +#13+#10; end else begin errFin := errFin + 'else' +#13+#10; errFin := errFin + 'begin' +#13+#10; errFin := errFin + fTab + 'commit;' +#13+#10; errFin := errFin +#13+#10; errFin := errFin + fTab + 'try' +#13+#10; errFin := errFin + fTab + fTab +'m' +filterRule +'(false);' +#13+#10; errFin := errFin + fTab + 'except' +#13+#10; errFin := errFin + fTab + fTab + 'on e:Exception do' +#13+#10; errFin := errFin + fTab + fTab + 'begin' +#13+#10; errFin := errFin + fTab + fTab + fTab + 'reportError(e);' +#13+#10; errFin := errFin + fTab + fTab + fTab + 'consume;' +#13+#10; errFin := errFin + fTab + fTab + 'end;' +#13+#10; errFin := errFin + fTab + 'end;' +#13+#10; errFin := errFin +#13+#10; errFin := errFin + fTab + 'continue;' +#13+#10; errFin := errFin + 'end;' +#13+#10; end; end // ------------------------------------------------------------ // Normal mode // ------------------------------------------------------------ else begin errFin := errFin + 'else'+#13+#10; errFin := errFin + fTab + 'Raise EMismatchedChar.Create(' + 'LA(1), _first, InputState.FileName, InputState.Line, InputState.Column);' +#13+#10; end; blkFin := TDelphiBlockFinishingInfo.Create; blkFin.NeedAnErrorClause := true; blkFin.GeneratedAnIf := true; blkFin.GeneratedSwitch := false; genBlockFinish( blkFin, errFin); // --------------------------------------------------------------- // At this point a valid token has been matched, undo "mark" that // was done // --------------------------------------------------------------- if filterMode and (filterRule <> '') then begin println(''); println('commit;'); end; // --------------------------------------------------------------- // Generate literals test if desired. // Make sure _ttype is set first; note _returnToken must be // non-null as the rule was required to create it. // --------------------------------------------------------------- println(''); println('// --------------------------------------------------------------'); println('// If we found a SKIP token, then try again...'); println('// --------------------------------------------------------------'); println('if result = nil then'); INC(fTabs); println('continue;'); println(''); DEC(fTabs); if fLexerGrammar.TestLiterals then begin println('// --------------------------------------------------------------'); println('// Literals test'); println('// --------------------------------------------------------------'); println('result.TokenType := TestLiteral(result.TokenType);'); println(''); end; println('// --------------------------------------------------------------'); println('// Now we have a valid token, so exit the function'); println('// --------------------------------------------------------------'); println('break;'); println(''); // --------------------------------------------------------------- // Close try block // --------------------------------------------------------------- DEC(fTabs); println('except'); INC(fTabs); if fLexerGrammar.FilterMode then begin if filterRule = '' then begin println('consume;'); println('continue;'); end else begin println('rewind(_mark);'); println('ResetText;'); println(''); println('try'); println(fTab + 'm'+filterRule+'(false);'); println(''); println('except'); println(fTab + 'on e:Exception do'); println(fTab + 'begin'); println(fTab + fTab + 'reportError(e);'); println(fTab + fTab + 'consume;'); println(fTab + 'end;'); println('end;'); end; end else begin println('Raise;'); end; DEC(fTabs); println('end;'); // --------------------------------------------------------------- // Close while(true) block // --------------------------------------------------------------- DEC(fTabs); println('end;'); // --------------------------------------------------------------- // Finish the method // --------------------------------------------------------------- fTabs := 0; println('end;'); println(''); end; // ================================================================================================ // genUses // // Generate uses clause form interface section. // ================================================================================================ procedure TDelphiGenerator.genUses; var i : integer; items : TStringList; begin items := fGrammar.UsesList; if fGrammar.ExportVocab = '' then items.Add( fGrammar.UnitName + 'Tokens') else items.Add(fGrammar.ExportVocab + 'Tokens'); fTabs := 0; println('uses'); fTabs := 1; for i:=0 to items.count -1 do begin print( items.Strings[i]); if i < (items.Count -1) then _println(',') else _println(';'); end; fTabs := 0; println(''); end; // ================================================================================================ // genUses2 // // Generate uses clause form implementation section. // ================================================================================================ procedure TDelphiGenerator.genUses2; var i : integer; items : TStringList; begin items := fGrammar.UsesList2; fTabs := 0; println('uses'); fTabs := 1; for i:=0 to items.count -1 do begin print( items.Strings[i]); if i < (items.Count -1) then _println(',') else _println(';'); end; fTabs := 0; println(''); end; // ============================================================================ // genClassDecl // ============================================================================ procedure TDelphiGenerator.genClassDecl; var i : integer; rs : IRuleSymbol; cntPriv : integer; cntProt : integer; cntPub : integer; lenMax : integer; fmt : AnsiString; begin fTabs := 0; // --------------------------------------------------------------- // generate "class" section // --------------------------------------------------------------- if fGrammar.ConstAction <> nil then begin println('const'); inc(fTabs); println('// ========================================================================='); println('// Const declarations from grammar.'); println('// ========================================================================='); printAction( fGrammar.ConstAction.TokenText); println(''); dec(fTabs); end; // --------------------------------------------------------------- // generate "type" section // --------------------------------------------------------------- println('type'); INC(fTabs); if fGrammar.TypeAction <> nil then begin println('// ========================================================================='); println('// Type declarations from grammar.'); println('// ========================================================================='); printAction( fGrammar.TypeAction.TokenText); println(''); end; // --------------------------------------------------------------- // Generate class declaration header // --------------------------------------------------------------- println('// ========================================================================='); println('// Class ' + fGrammar.GrammarName + ' declaration'); println('// ========================================================================='); if fIsLexer then println( fGrammar.GrammarName + ' = class( TLexer)') else if fIsParser then println( fGrammar.GrammarName + ' = class( TLLkParser)'); println(''); // --------------------------------------------------------------- // Generate memberdecl{...} section // --------------------------------------------------------------- if fGrammar.MemberDecl <> '' then begin printAction( fGrammar.MemberDecl); println(''); end; // --------------------------------------------------------------- // Mandatory method declarations for lexer grammar. // --------------------------------------------------------------- if fIsLexer then begin if needsLexerInit then begin println('protected // Internals'); println(fTab + 'procedure initialize; override;'); println(''); end; end; // --------------------------------------------------------------- // Calculate counts and length // --------------------------------------------------------------- cntPriv := 0; cntProt := 0; cntPub := 0; lenMax := 0; for i:=0 to fGrammar.Rules.Count -1 do begin fGrammar.Rules.Items[i].QueryInterface( IRuleSymbol, rs); if rs.Access = 'private' then INC( cntPriv) else if rs.Access = 'protected' then INC( cntProt) else INC( cntPub); if Length( rs.ID) > lenMax then lenMax := Length( rs.ID); end; INC( lenMax); // --------------------------------------------------------------- // Generate private method declarations // --------------------------------------------------------------- if cntPriv > 0 then begin fTabs := 1; println('private // Private grammar rules'); fTabs := 2; for i:=0 to fGrammar.Rules.Count -1 do begin fGrammar.Rules.Items[i].QueryInterface( IRuleSymbol, rs); if rs.Access = 'private' then genMethodDecl( rs, lenMax, false); end; fTabs := 1; println(''); end; // --------------------------------------------------------------- // Generate protected method declarations // --------------------------------------------------------------- if cntProt > 0 then begin fmt := 'procedure %-' + IntToStr( lenMax) + 's' + ' pCreate: boolean);'; fTabs := 1; println('public // Protected grammar rules'); println(' // Must callable from parser too'); fTabs := 2; for i:=0 to fGrammar.Rules.Count -1 do begin fGrammar.Rules.Items[i].QueryInterface( IRuleSymbol, rs); if rs.Access = 'protected' then genMethodDecl( rs, lenMax, false); end; fTabs := 1; println(''); end; // --------------------------------------------------------------- // Generate public method declarations // // NOTE: // // by definition!!!! // --------------------------------------------------------------- if cntPub > 0 then begin fTabs := 1; if fIsLexer then println('public // Public grammar rules') else println('public // Public grammar rules'); fTabs := 2; for i:=0 to fGrammar.Rules.Count -1 do begin fGrammar.Rules.Items[i].QueryInterface( IRuleSymbol, rs); if rs.Access = 'public' then genMethodDecl( rs, lenMax, false); end; fTabs := 1; println(''); end; // --------------------------------------------------------------- // NextToken method declaration for lexer grammar. // --------------------------------------------------------------- if fIsLexer then begin println('public'); INC(fTabs); println('function NextToken: IToken; override;'); DEC(fTabs); end; println('end;'); fTabs := 0; end; // ============================================================================ // genMethodDecl // ============================================================================ procedure TDelphiGenerator.genMethodDecl( pRuleSymbol : IRuleSymbol; pLength : integer; pFull : boolean); var rb : IRuleBlock; l : AnsiString; fmt: AnsiString; begin // --------------------------------------------------------------- // Special case: Public method in lexer grammar. In this case the // rule should not have parameters and return value. // --------------------------------------------------------------- if (pRuleSymbol.Access = 'public') and fIsLexer then begin // ------------------------------------------------------------ // Generate declaration // ------------------------------------------------------------ if not pFull then begin fmt := 'procedure %-' + IntToStr( pLength) + 's' + '( pCreate: boolean);'; println( Format(fmt, [pRuleSymbol.ID])); end // ------------------------------------------------------------ // Generate definition // ------------------------------------------------------------ else begin l := 'procedure ' + fGrammar.GrammarName + '.' + pRuleSymbol.ID; l := l + '( pCreate: boolean);'; println( l); end; end // --------------------------------------------------------------- // General case // --------------------------------------------------------------- else begin l := ''; rb := pRuleSymbol.Block; // ------------------------------------------------------------ // Determine method type (function/procedure) // ------------------------------------------------------------ if rb.ReturnAction <> '' then l := 'function ' else l := 'procedure '; // ------------------------------------------------------------ // gernerate class name // ------------------------------------------------------------ if pFull then l := l + fGrammar.GrammarName + '.' + pRuleSymbol.ID else begin fmt := '%-' + IntToStr( pLength) + 's'; l := l + Format( fmt, [pRuleSymbol.ID]); end; // ------------------------------------------------------------ // Generate arguments for lexer grammar // ------------------------------------------------------------ if fIsLexer then begin l := l + '( pCreate: boolean'; if rb.Arguments <> '' then l := l + '; ' + rb.Arguments; l := l + ')'; end // ------------------------------------------------------------ // Generate arguments for parser grammar // ------------------------------------------------------------ else if fIsParser then begin if rb.Arguments <> '' then l := l + '( ' + rb.Arguments + ')'; end; // ------------------------------------------------------------ // Generate return value // ------------------------------------------------------------ if rb.ReturnAction <> '' then l := l + ': ' + rb.ReturnAction; // ------------------------------------------------------------ // Close the declaration // ------------------------------------------------------------ l := l + ';'; println( l); end; end; // ============================================================================ // genBlockFinish // ============================================================================ procedure TDelphiGenerator.genBlockFinish( pHowToFinish : TDelphiBlockFinishingInfo; pNoViableAction : AnsiString; pSingleLine : boolean); begin if pHowToFinish.NeedAnErrorClause and (pHowToFinish.GeneratedAnIf or pHowToFinish.GeneratedSwitch) then begin // ------------------------------------------------------------ // Handle generated if // ------------------------------------------------------------ if pHowToFinish.GeneratedAnIf then begin // if not pSingleLine then println(''); println('else'); if not pSingleLine then println('begin'); end // ------------------------------------------------------------ // Handle generated switch // ------------------------------------------------------------ else println('begin'); INC(fTabs); // printAction( '{'+#13+#10+#13+#10+pNoViableAction+#13+#10+'}'); printAction( '{'+#13+#10+#13+#10+pNoViableAction+'}'); DEC(fTabs); if not pSingleLine then println('end;'); end; if pHowToFinish.PostScript <> '' then printAction( '{'+#13+#10+#13+#10+pHowToFinish.PostScript+#13+#10+'}'); if pHowToFinish.NeedAClosingEnd then begin DEC(fTabs); println('end;'); end; // println(''); end; // ============================================================================ // genCommonBlock // ============================================================================ function TDelphiGenerator.genCommonBlock( pBlock : IAlternativeBlock; pNoTestForSingle : boolean) : TDelphiBlockFinishingInfo; var nIF : integer; closingBracesOfIFSequence : integer; oldSaveText : boolean; p : ILookahead; alt : IAlternative; i : integer; ps : AnsiString; e : AnsiString; unpredicted : boolean; hasEmptyAlt : boolean; effectiveDepth : integer; startDepth : integer; altDepth : integer; semPred : AnsiString; begin result := TDelphiBlockFinishingInfo.Create; nIF := 0; closingBracesOfIFSequence := 0; // --------------------------------------------------------------- // Save the save text state // --------------------------------------------------------------- oldSaveText := fSaveText; fSaveText := fSaveText and pBlock.AutoGen; // --------------------------------------------------------------- // Is this block inverted? If so, generate special-case code. // --------------------------------------------------------------- if pBlock.IsNot and fAnalyzer.SubRuleCanBeInverted( pBlock, fIsLexer) then begin p := fAnalyzer.Look( 1, pBlock); // ------------------------------------------------------------ // Variable assignment for labeled elems // ------------------------------------------------------------ if (pBlock.Lbl <> '') and (fSyntacticPredLevel = 0) then println( pBlock.Lbl + ':= ' + fLT1Value + ';'); // ------------------------------------------------------------ // Match the alternative // ------------------------------------------------------------ println('match( [' + CharSetToStr(p.LaSet) + ']);'); exit; end; // --------------------------------------------------------------- // Special handling for single alt. // --------------------------------------------------------------- if pBlock.Alternatives.Count = 1 then begin alt := pBlock.Alternative[0]; // ------------------------------------------------------------ // Generate a warning if there is a synPred for single alt. // ------------------------------------------------------------ if alt.SynPred <> nil then fTool.Warning( MSG_W_SYNTSUPERFLUOUS, fGrammar.GrammarFile, alt.SynPred.Line, alt.SynPred.Column); if pNoTestForSingle then begin if alt.SemPred <> '' then genSemPred( alt.SemPred); genAlt( alt, pBlock); exit; end; end; // --------------------------------------------------------------- // Do non-LL(1) and nondeterministic cases. // This is tricky in the lexer, because of cases like: // STAR : '*'; // ASSIGN_STAR : "*="; // Since NextToken is generated whitout a loop, then the STAR will // have end-of-token as it's lookahead set for LA(2). So we must // generate the alternatives containing trailing end-of-token in // their lookahead sets *after* the alternatives without end-of-token. // This implements the usual lexer convention that longer matches // come before shorter ones, e.g. "*=" matches ASSIGN_STAR not STAR. // // For non-lexer grammars, this does not sort the alternatives by // depth. Note that alternatives whose lookahead is purely end-of-token // at k=1 end up as default or else clauses. // --------------------------------------------------------------- if fIsLexer then startDepth := fLexerGrammar.MaxK else startDepth := 0; // --------------------------------------------------------------- // Check for empty alternative in the block // --------------------------------------------------------------- hasEmptyAlt := false; for i:=0 to pBlock.Alternatives.Count -1 do begin if altIsEmpty( pBlock.Alternative[i]) then begin hasEmptyAlt := true; break; end; end; // --------------------------------------------------------------- // Generate syntactic predicates first! // // Note: the rule must have minimum one non-empty alternative which // has no syntactic predicate // --------------------------------------------------------------- if pBlock.HasASynPred then begin for i:=0 to pBlock.Alternatives.Count -1 do begin alt := pBlock.Alternative[i]; if alt.SynPred <> nil then begin println('if not _spMatch then'); println('begin'); INC(fTabs); genSynPred( alt.SynPred, e); INC(fTabs); genAlt( alt, pBlock); DEC(fTabs); println('end;'); DEC(fTabs); println('end;'); println(''); end; end; // ------------------------------------------------------ // Well, the rest of the alternatives must be in an if // clause. // ------------------------------------------------------ println('if not _spMatch then'); println('begin'); INC(fTabs); end; // --------------------------------------------------------------- // Now generate the normal alternatives // --------------------------------------------------------------- for altDepth := startDepth downto 0 do begin for i:=0 to pBlock.Alternatives.Count -1 do begin alt := pBlock.Alternative[i]; unpredicted := False; // --------------------------------------------------------- // Skip already generates alternatives with syntactic // predicates. // --------------------------------------------------------- if alt.SynPred <> nil then continue; // --------------------------------------------------------- // Lexer grammar // --------------------------------------------------------- if fIsLexer then begin // ------------------------------------------------------ // Calculate the "effective depth" of the alt, which is // the max depth at which cache[dept] <> end-of-token. // ------------------------------------------------------ effectiveDepth := alt.LookaheadDepth; // ------------------------------------------------------ // If the alt's lookahead depth is NONDETERMINISTIC then // use the maximum lookahead. // ------------------------------------------------------ if effectiveDepth = NONDETERMINISTIC then effectiveDepth := fLexerGrammar.MaxK; while (effectiveDepth >= 1) and (alt.Cache[effectiveDepth].HasEpsilon or (alt.Cache[effectiveDepth].LaSet = [1..255])) do begin DEC(effectiveDepth); end; // ------------------------------------------------------ // Ignore alts whose effective depth is other than the // ones we are generating for this iteration. // ------------------------------------------------------ if effectiveDepth <> altDepth then continue; unpredicted := lookaheadIsEmpty( alt, effectiveDepth); e := getLookaheadTestExpr( alt, effectiveDepth); end // --------------------------------------------------------- // Non-lexer grammar. // --------------------------------------------------------- else begin unpredicted := lookaheadIsEmpty( alt, fGrammar.MaxK); e := getLookaheadTestExpr( alt, fGrammar.MaxK); end; // --------------------------------------------------------- // If the alternative is empty, then don't generate checking // code for the follow set, and say we don't need an error // clause. The following token will handle the possible // token mismatch. // --------------------------------------------------------- if altIsEmpty(alt) then begin result.NeedAnErrorClause := false; continue; end else if (unpredicted) and (alt.SemPred = '') and (alt.SynPred = nil) then begin // ------------------------------------------------------ // The alt has empty prediction set and no predicate to // help out. If we have not generated a previous if, just // put {...} around the end-of-token clause. // ------------------------------------------------------ if nIF = 0 then begin println('begin'); end else begin println('else'); println('begin'); end; result.NeedAnErrorClause := false; end else begin // ------------------------------------------------------ // Generate semantic predicate // ------------------------------------------------------ if alt.SemPred <> '' then begin semPred := Copy( alt.SemPred,2,Length(alt.SemPred)-2); if e = 'true' then e := '( ' + semPred + ')' else e := '(' + e + ' and (' + semPred + '))'; end; // ------------------------------------------------------ // Generate syntactic predicate // ------------------------------------------------------ if nIF > 0 then begin println(''); // if pBlock.HasASynPred then // e := e + ' and not _spMatch'; println('else if ' + e + ' then'); println('begin'); end else begin // if pBlock.HasASynPred then // e := e + ' and not _spMatch'; println('if ' + e + ' then'); println('begin'); end; end; INC(nIF); INC(fTabs); genAlt( alt, pBlock); DEC(fTabs); if i = pBlock.Alternatives.Count -2 then begin if hasEmptyAlt then println('end;') else println('end') end else println('end') end; end; // --------------------------------------------------------------- // Close the synpred's if // --------------------------------------------------------------- if pBlock.HasASynPred then result.NeedAClosingEnd := true; // --------------------------------------------------------------- // Restore save text state. // --------------------------------------------------------------- fSaveText := oldSaveText; // --------------------------------------------------------------- // Return the finishing info. // --------------------------------------------------------------- result.PostScript := ps; result.GeneratedAnIf := nIF > 0; end; // ============================================================================ // suitableForCaseExpression // ============================================================================ //function TDelphiGenerator.suitableForCaseExpression( pAlt: IAlternative): boolean; //begin // result := false; //end; // ============================================================================ // lookaheadIsEmpty // ============================================================================ function TDelphiGenerator.lookaheadIsEmpty( pAlt : IAlternative; pMaxDepth: integer): boolean; var depth : integer; i : integer; p : TByteSet; begin result := true; depth := pAlt.LookaheadDepth; if depth = NONDETERMINISTIC then depth := fGrammar.MaxK; for i:=1 to depth do begin p := pAlt.Cache[i].LaSet; if p <> [] then begin result := false; break; end; end; end; // ============================================================================ // genClassDef // ============================================================================ procedure TDelphiGenerator.genClassDef; var i : integer; rs : IRuleSymbol; begin // --------------------------------------------------------------- // Generate rules // --------------------------------------------------------------- for i:=0 to fGrammar.Rules.Count -1 do begin rs := fGrammar.Rules[i] as IRuleSymbol; if rs.ID <> 'mNextToken' then genRule( fGrammar.Rules[i] as IRuleSymbol); end; // --------------------------------------------------------------- // Generate lexer specific methods // --------------------------------------------------------------- if fIsLexer then begin genNextToken; if needsLexerInit then genInitLiterals; end; // --------------------------------------------------------------- // finally generate member definitions,.... // --------------------------------------------------------------- if fGrammar.MemberDef <> '' then printAction( fgrammar.MemberDef); end; // ============================================================================ // genRule // ============================================================================ procedure TDelphiGenerator.genRule(pRuleSymbol: IRuleSymbol); var rblk : IRuleBlock; ulEx : IExceptionSpec; alt : IAlternative; pred : AnsiString; htf : TDelphiBlockFinishingInfo; // sl : TInterfaceList; // sp : ISynPredBlock; // i : integer; follow : TByteSet; rname : AnsiString; begin fTabs := 0; // --------------------------------------------------------------- // If the rule not defined, leave. // --------------------------------------------------------------- if not pRuleSymbol.Defined then begin if fIsLexer then rname := TCodeGenerator.decodeLexerRuleName( pRuleSymbol.ID) else rname := pRuleSymbol.ID; fTool.Error( Format( MSG_E_RULENOTDEFINED, [rname]), fGrammar.GrammarFile, -1,0); // fTool.Error('Undefined rule: "' + pRuleSymbol.ID); exit; end; // --------------------------------------------------------------- // Get the rule block // --------------------------------------------------------------- rblk := pRuleSymbol.Block; println('// ============================================================================'); println('// ' + pRuleSymbol.ID); println('// ============================================================================'); genMethodDecl( pRuleSymbol, 0, true); genRuleLocals( rblk); println('begin'); INC(fTabs); // --------------------------------------------------------------- // Initialize some of the local variables // --------------------------------------------------------------- if fIsLexer then begin println('_begin := Length( TokenText) +1;'); println('_token := nil;'); println('_ttype := TT_' + TCodeGenerator.decodeLexerRuleName(pRuleSymbol.ID)+';'); end; // --------------------------------------------------------------- // Initialize synpred vars // --------------------------------------------------------------- if rblk.HasASynPred then begin println('_spMatch := false;'); println('_mkMatch := 0;'); end; println(''); // --------------------------------------------------------------- // Generate try block around the entire rule if necessary // --------------------------------------------------------------- if (rblk.ExHandlerType <> '') or (rblk.DefaultErrorHandler and (not fIsLexer)) then begin println('try'); INC(fTabs); end; // --------------------------------------------------------------- // Generate block init action // --------------------------------------------------------------- genBlockInitAction( rblk); // --------------------------------------------------------------- // Generate the alternatives // --------------------------------------------------------------- if rblk.Alternatives.Count = 1 then begin // ------------------------------------------------------------ // One alternative -- use simple form // ------------------------------------------------------------ alt := rblk.Alternative[0]; pred := alt.SemPred; if pred <> '' then genSemPred( pred); if alt.SynPred <> nil then begin fTool.Warning( MSG_W_SYNTIGNORED, fGrammar.GrammarFile, alt.SynPred.Line, alt.SynPred.Column); end; genAlt( alt, rblk); end else begin // ------------------------------------------------------------ // More than one alternatives -- generate complex form // ------------------------------------------------------------ fGrammar.LLkAnalyzer.Deterministic( rblk); htf := genCommonBlock( rblk, false); genBlockFinish( htf, throw(rblk.Look(1)), true); end; // --------------------------------------------------------------- // Generate exception handler // --------------------------------------------------------------- if (rblk.ExHandlerType <> '') or (rblk.DefaultErrorHandler and (not fIsLexer)) then begin println(''); // ------------------------------------------------------------ // Generate user exception-handler code, or.... // ------------------------------------------------------------ if rblk.ExHandlerType <> '' then begin DEC( fTabs); println(rblk.ExHandlerType); INC(fTabs); if( rblk.ExHandlerType = 'except') then begin println('on e:Exception do'); println('begin'); INC(fTabs); end; end // ------------------------------------------------------------ // ... default error handler code.... // ------------------------------------------------------------ else begin DEC( fTabs); println('except'); INC(fTabs); println('on e:Exception do'); println('begin'); INC(fTabs); end; // ------------------------------------------------------------ // Generate code to handle error if not guessing... // ------------------------------------------------------------ if fGrammar.HasSynPred then begin println('if InputState.Guessing = 0 then'); println('begin'); INC(fTabs); end; // ------------------------------------------------------------ // Now the real handler... // ------------------------------------------------------------ if rblk.ExHandlerType <> '' then begin printAction( rblk.ExHandlerCode); end else begin follow := rblk.EndElem.Look(1).LaSet; println('reportError(e);'); println('Consume;'); println('ConsumeUntil( [' + TokenSetToStr(follow,fGrammar.TokenManager)+ ']);'); end; // --------------------------------------------------------- // When guiessing, rethrow exception // --------------------------------------------------------- if fGrammar.HasSynPred then begin DEC(fTabs); println('end'); if rblk.ExHandlerType <> 'finally' then begin println('else'); println(fTab + 'Raise;'); end; end; DEC(fTabs); println('end;'); if rblk.ExHandlerType <> 'finally' then begin DEC(fTabs); println('end;'); end; end; // --------------------------------------------------------------- // Generate literals test for lexer rules so marked // --------------------------------------------------------------- if rblk.TestLiterals then begin if pRuleSymbol.Access = 'protected' then genLiteralsTestForPartialToken else genLiteralsTest; end; // --------------------------------------------------------------- // If doing a lexer rule, dump code to create token if necessary. // --------------------------------------------------------------- if fIsLexer then begin println(''); println('if (_ttype <> TT_SKIP) and (pCreate = true) then'); println('begin'); INC(fTabs); println('_token := makeToken( _ttype);'); println('_token.TokenText := Copy( TokenText, _begin, Length(TokenText)-_begin+1);'); DEC(fTabs); println('end;'); println(''); println('ReturnToken := _token;'); end; DEC( fTabs); println('end;'); println(''); end; // ============================================================================ // genRuleInvocation // ============================================================================ procedure TDelphiGenerator.genRuleInvocation( pRuleRefElem: IRuleRefElem); var rs: IRuleSymbol; begin // _print( pRuleRefElem.TargetRule + '( '); _print( pRuleRefElem.TargetRule); if fIsLexer or (pRuleRefElem.Args <> '') then _print('('); // --------------------------------------------------------------- // Lexers must tell rule if it should set _returnToken // --------------------------------------------------------------- if fIsLexer then begin // ------------------------------------------------------------ // If labeled, could access Token, so tell the rule to generate // ------------------------------------------------------------ if pRuleRefElem.Lbl <> '' then _print('true') else _print('false'); end; // --------------------------------------------------------------- // Process arguments to method, if any... // --------------------------------------------------------------- if pRuleRefElem.Args <> '' then begin if fIsLexer then _print(', '); _print(pRuleRefElem.Args); // ------------------------------------------------------------ // Warn if the rule accepts no arguments // ------------------------------------------------------------ rs := fGrammar.Symbol[pRuleRefElem.TargetRule] as IRuleSymbol; if rs.Block.Arguments = '' then begin fTool.Warning( Format( MSG_W_RULEACCEPTSNOARGS, [pRuleRefElem.TargetRule]), fGrammar.GrammarFile, pRuleRefElem.Line, pRuleRefElem.Column); end; end; // --------------------------------------------------------------- // Close the invocation // --------------------------------------------------------------- if fIsLexer or (pRuleRefElem.Args <> '') then _print(')'); _println(';'); end; // ============================================================================ // genSemPred // ============================================================================ procedure TDelphiGenerator.genSemPred(pSemPred: AnsiString); var semPred: AnsiString; begin semPred := Trim( Copy( pSemPred, 2, Length( pSemPred) -2)); println(''); println('if not (' + semPred + ') then'); INC(fTabs); println( 'Raise ESemantic.Create(''' + sempred +''', InputState.FileName, InputState.Line, InputState.Column);'); println(''); DEC(fTabs); end; // ============================================================================ // genSynPred // ============================================================================ procedure TDelphiGenerator.genSynPred( pBlock : ISynPredBlock; pLookaheadExpr : AnsiString); var id : AnsiString; begin id := IntToStr( pBlock.ID); // --------------------------------------------------------------- // Save input state // --------------------------------------------------------------- println('_mkMatch := mark;'); println('_spMatch := true;'); println(''); println('InputState.Guessing := InputState.Guessing + 1;'); // --------------------------------------------------------------- // Once inside the try, assume synpred works unless exception caught. // --------------------------------------------------------------- INC(fSyntacticPredLevel); println(''); println('try'); INC(fTabs); gen( pBlock as IAlternativeBlock); DEC(fTabs); println('except'); INC(fTabs); println('_spMatch := false;'); DEC(fTabs); println('end;'); // --------------------------------------------------------------- // Restore input state. // --------------------------------------------------------------- println(''); println('rewind( _mkMatch);'); println('InputState.Guessing := InputState.Guessing - 1;'); DEC(fSyntacticPredLevel); // DEC(fTabs); // --------------------------------------------------------------- // Close lookahead test // --------------------------------------------------------------- // println('end;'); // --------------------------------------------------------------- // Test synpred result // --------------------------------------------------------------- println(''); println('if _spMatch then'); println('begin'); // INC(fTabs); end; // ============================================================================ // genBlockInitAction // ============================================================================ procedure TDelphiGenerator.genBlockInitAction( pBlock: IAlternativeBlock); begin if pBlock.InitAction <> '' then begin printAction( pBlock.InitAction); println(''); end; end; // ============================================================================ // genAlt // ============================================================================ procedure TDelphiGenerator.genAlt( pAlt : IAlternative; pBlk : IAlternativeBlock); var oldSaveText : boolean; elem : IAlternativeElem; be : IBlockEndElem; begin // --------------------------------------------------------------- // Save state // --------------------------------------------------------------- oldSaveText := fSaveText; fSaveText := fSaveText and pAlt.DoAutoGen; // --------------------------------------------------------------- // Generate try block around the alt for error handling // --------------------------------------------------------------- if pAlt.ExHandlerType <> '' then begin println('try'); INC(fTabs); end; // --------------------------------------------------------------- // Generate elems // --------------------------------------------------------------- elem := pAlt.Head; while elem.QueryInterface(IBlockEndElem, be) <> S_OK do begin elem.Generate; elem := elem.Next; end; // --------------------------------------------------------------- // Close try block // --------------------------------------------------------------- if pAlt.ExHandlerType <> '' then begin println(''); DEC(fTabs); println( pAlt.ExHandlerType); INC(fTabs); if pAlt.ExHandlerType = 'except' then begin println('on e:Exception do'); println('begin'); INC(fTabs); end; if fGrammar.HasSynPred then begin println('if InputState.Guessing = 0 then'); println('begin'); INC(fTabs); end; printAction( pAlt.ExHandlerCode); if fGrammar.HasSynPred then begin DEC(fTabs); println('end;'); end; if pAlt.ExHandlerType = 'except' then begin DEC(fTabs); println('end;'); end; DEC(fTabs); println('end'); end; // --------------------------------------------------------------- // Restore state // --------------------------------------------------------------- fSaveText := oldSaveText; end; // ============================================================================ // genLiteralsTest // ============================================================================ procedure TDelphiGenerator.genLiteralsTest; begin // println(''); // println('// --------------------------------------------------------------'); // println('// Consult literals table...'); // println('// --------------------------------------------------------------'); println('_ttype := TestLiteral( _ttype);'); println(''); end; // ============================================================================ // genLiteralsTestForPartialToken // ============================================================================ procedure TDelphiGenerator.genLiteralsTestForPartialToken; begin println('_ttype := TestLiteral( Copy( TokenText, _begin, Length(TokenText)-_begin+1), _ttype);'); println(''); end; // ============================================================================ // Gen(StringLiteral) // ============================================================================ procedure TDelphiGenerator.Gen(pAtom: IStringLiteralElem); var oldSaveText: boolean; begin if (pAtom.Lbl <> '') and (fSyntacticPredLevel = 0) then println(pAtom.Lbl + ' := ' + fLT1Value + ';'); oldSaveText := fSaveText; fSaveText := fSaveText and (pAtom.AutoGenType = AUTOGEN_NONE); if oldSaveText and not fSaveText then println('SaveConsumedInput := false;'); genMatch( pAtom); if oldSaveText and not fSaveText then println('SaveConsumedInput := true;'); fSaveText := oldSaveText; end; // ============================================================================ // genMatch // ============================================================================ procedure TDelphiGenerator.genMatch(pAtom: IGrammarAtom); var cle : ICharLiteralElem; sle : IStringLiteralElem; wce : IWildcardElem; tre : ITokenRefElem; begin pAtom.QueryInterface( ICharLiteralElem, cle); pAtom.QueryInterface( IStringLiteralElem, sle); pAtom.QueryInterface( IWildcardElem, wce); pAtom.QueryInterface( ITokenRefElem, tre); // --------------------------------------------------------------- // Generate match for char literal elem. // --------------------------------------------------------------- if cle <> nil then begin if fIsLexer then genMatchUsingAtomText( pAtom) else begin fTool.Error( Format( MSG_E_CHARLITINNONLEXER, [pAtom.AtomText])); // fTool.Error('Cannot reference character literals in non-lexer grammar: ' + // pAtom.AtomText); end; end // --------------------------------------------------------------- // Generate match for AnsiString literal elem. // --------------------------------------------------------------- else if sle <> nil then begin if fIsLexer then genMatchUsingAtomText( pAtom) else genMatchUsingAtomTokenType( pAtom); end // --------------------------------------------------------------- // Generate match for token ref elem. // --------------------------------------------------------------- else if tre <> nil then genMatchUsingAtomText( pAtom) // --------------------------------------------------------------- // Generate match for wildcard elem. // --------------------------------------------------------------- else if wce <> nil then gen( wce); end; // ============================================================================ // genMatchUsingAtomText // ============================================================================ procedure TDelphiGenerator.genMatchUsingAtomText( pAtom: IGrammarAtom); var cle : ICharLiteralElem; sle : IStringLiteralElem; begin pAtom.QueryInterface(ICharLiteralElem, cle); pAtom.QueryInterface(IStringLiteralElem, sle); if not pAtom.IsNot then print('match(') else print('matchNot('); if cle <> nil then _print( CharSetToStr([pAtom.AtomText[1]])) else if sle <> nil then _print( '''' + Copy( pAtom.AtomText, 2, Length( pAtom.AtomText)-2) + '''') else _print( TokenSetToStr( [pAtom.TokenType], fGrammar.TokenManager)); _println(');'); end; // ============================================================================ // genMatchUsingAtomTokenType // ============================================================================ procedure TDelphiGenerator.genMatchUsingAtomTokenType( pAtom: IGrammarAtom); begin if not pAtom.IsNot then println('match(' + getValueString( pAtom.TokenType) + ');') else println('matchNot(' + getValueString( pAtom.TokenType) + ');'); end; // ============================================================================ // getValueString // ============================================================================ function TDelphiGenerator.getValueString(pType : integer): AnsiString; var ts: ITokenSymbol; ss: IStringSymbol; cs: AnsiString; id: AnsiString; // lbl: AnsiString; begin if fIsLexer then begin println('//TODO:getValueString(lexer)'); end else begin result := TokenSetToStr( [pType], fGrammar.TokenManager); ts := fGrammar.TokenManager.TokenSymbolByType[pType]; if ts = nil then begin result := 'TT_' + IntToStr( pType); exit; end; id := ts.ID; ts.QueryInterface(IStringSymbol,ss); if ss <> nil then begin // --------------------------------------------------------- // In AnsiString literal, use predefined label if any. If no // predefined, try to mangle into LT_xxxx. // If can't mangle, use int as last resort. // --------------------------------------------------------- if ss.Lbl <> '' then result := ss.Lbl else begin // result := magleLiteral( tId); if result = '' then result := 'LT_' + IntToStr( pType); end; end else begin if id = 'EOF' then result := 'TT_EOF' else result := id; end; end; end; // ============================================================================ // Gen(WildCard) // ============================================================================ procedure TDelphiGenerator.Gen(pWc: IWildcardElem); begin if (pWc.Lbl <> '') and (fSyntacticPredLevel = 0) then println( pWc.Lbl + ' := ' + fLT1Value + ';'); if fIsLexer then begin if fSaveText and (pWc.AutoGenType = AUTOGEN_BANG) then println('SaveConsumedInput := false;'); println('matchNot( EOF_CHAR );'); if fSaveText and (pWc.AutoGenType = AUTOGEN_BANG) then println('SaveConsumedInput := true;'); end else if fIsParser then println('matchNot( ' + getValueString(0) + ');'); end; // ============================================================================ // addSemPred // ============================================================================ function TDelphiGenerator.addSemPred(pSemPred: AnsiString): integer; begin result := fSemPreds.Add( pSemPred); end; // ============================================================================ // exitIfError // ============================================================================ procedure TDelphiGenerator.exitIfError; begin { TODO : exitIfError } end; // ============================================================================ // genPredictExpr // ============================================================================ procedure TDelphiGenerator.genPredictExpr( pLaList : TInterfaceList; pLaDepth : integer); var i : integer; la : ILookahead; begin print('( '); for i:=0 to pLaDepth -1 do begin if i <> 1 then begin println(') and'); print('( '); end; pLaList.Items[i].QueryInterface(ILookahead, la); // ------------------------------------------------------------ // Syntactic predicates can yield (epsilon) // lookahead- There is no way to predic what that token would // be. Allow anything instead. // ------------------------------------------------------------ if la.HasEpsilon then _print('true') else _print(getLookaheadTestTerm(i,la)); end; _println(')'); end; // ============================================================================ // getLookaheadTestExpr // ============================================================================ function TDelphiGenerator.getLookaheadTestExpr( pLaList : TInterfaceList; pLaDepth : integer): AnsiString; var i : integer; la : ILookahead; begin result := '( '; for i:=0 to pLaDepth -1 do begin pLaList.Items[i].QueryInterface(ILookahead, la); // ------------------------------------------------------------ // Syntactic predicates can yield (epsilon) // lookahead. There is no way to predic what that token would // be. Allow anything instead. // ------------------------------------------------------------ if la.HasEpsilon then // result := result + 'true' else begin if i <> 0 then result := result + ') and ('; result := result + getLookaheadTestTerm(i+1,la); end; end; result := result + ')'; end; // ============================================================================ // getLookaheadTestExpr // ============================================================================ function TDelphiGenerator.getLookaheadTestExpr( pAlt : IAlternative; pMaxDepth: integer): AnsiString; var i : integer; depth : integer; laList : TInterfaceList; begin if pAlt.LookaheadDepth <> NONDETERMINISTIC then depth := pAlt.LookaheadDepth else depth := fGrammar.MaxK; // --------------------------------------------------------------- // Empty lookahead can result from alt with semantic pred that can // see end-of-token. E.g. A: {pred}? ('a')? ; // --------------------------------------------------------------- if pMaxDepth = 0 then result := 'true' else begin laList := TInterfaceList.Create; for i:=1 to depth do begin if pAlt.Cache[i].LaSet <> [1..255] then laList.Add( pAlt.Cache[i]) else break; end; result := '(' + getLookaheadTestExpr( laList, i-1) + ')'; end; end; // ============================================================================ // getLookaheadTestTerm // ============================================================================ function TDelphiGenerator.getLookaheadTestTerm( pK : integer; pLA : ILookahead): AnsiString; begin result := getLookaheadString( pK) + ' in '; if fIsLexer then result := result + '[' + CharSetToStr( pLa.LaSet) + ']' else if fIsParser then result := result + '[' + TokenSetToStr( pLa.LaSet, fGrammar.TokenManager) + ']'; end; // ============================================================================ // getLookaheadString // ============================================================================ function TDelphiGenerator.getLookaheadString(pK: integer): AnsiString; begin result := 'LA(' + IntToStr( pK) + ')'; end; // ============================================================================ // genRuleLocals // ============================================================================ procedure TDelphiGenerator.genRuleLocals(pRuleBlock: IRuleBlock); var i : integer; vars : TStringList; vName : AnsiString; vType : AnsiString; lElems : TInterfaceList; lOom : TInterfaceList; lM2N : TInterfaceList; // lSyn : TInterfaceList; elem : IAlternativeElem; oom : IOneOrMoreBlock; m2n : INMBlock; // syn : ISynPredBlock; begin vars := TStringList.Create; vars.Sorted := true; vars.Duplicates := dupIgnore; // --------------------------------------------------------------- // Add mandatory local variables for lexer grammar. // --------------------------------------------------------------- if fIsLexer then begin vars.Add('_begin=integer'); vars.Add('_ttype=integer'); vars.Add('_save=integer'); vars.Add('_token=IToken'); end; // --------------------------------------------------------------- // Collect labeled elems // --------------------------------------------------------------- lElems := pRuleBlock.LabeledElems; for i:=0 to lElems.Count -1 do begin lElems[i].QueryInterface( IAlternativeElem, elem); if LowerCase(elem.Lbl) <> 'result' then vars.Add( elem.Lbl + '=IToken'); end; // --------------------------------------------------------------- // Collect labels for (...)+ subrules // --------------------------------------------------------------- lOom := pRuleBlock.OneOrMoreBlocks; for i:=0 to lOom.Count -1 do begin lOom.Items[i].QueryInterface(IOneOrMoreBlock, oom); if oom <> nil then begin if oom.Lbl <> '' then vName := '_cnt_' + oom.Lbl + '=integer' else vName := '_cnt_' + IntToStr( oom.ID) + '=integer'; vars.Add(vName); end; end; // --------------------------------------------------------------- // Collect labels for (...)@ subrules // --------------------------------------------------------------- lM2N := pRuleBlock.NMBlocks; for i:=0 to lM2N.Count -1 do begin lM2N.Items[i].QueryInterface(INMBlock, m2n); if m2n <> nil then begin if m2n.Lbl <> '' then vName := '_cnt_' + m2n.Lbl + '=integer' else vName := '_cnt_' + IntToStr( m2n.ID) + '=integer'; vars.Add(vName); end; end; // --------------------------------------------------------------- // Collect labels for SynPred subrules // --------------------------------------------------------------- if pRuleBlock.HasASynPred then begin vars.Add('_spMatch=boolean'); vars.Add('_mkMatch=integer'); end; (* lSyn := pRuleBlock.SynPredBlocks; for i:=0 to lSyn.Count -1 do begin lSyn.Items[i].QueryInterface(ISynPredBlock, syn); if syn <> nil then begin vName := '_sp' + IntToStr( syn.ID) + '=boolean'; vars.Add(vName); vName := '_mk' + IntToStr( syn.ID) + '=integer'; vars.Add(vName); end; end; *) // --------------------------------------------------------------- // Now generate .... // --------------------------------------------------------------- if (vars.Count > 0) or (pRuleBlock.Locals <> '')then begin println('var'); INC(fTabs); // ------------------------------------------------------------ // Generate labeled elems // ------------------------------------------------------------ for i:=0 to vars.Count -1 do begin vName := vars.Names [i]; vType := vars.Values[vName]; println( vName + ': ' + vType + ';'); end; // ------------------------------------------------------------ // Generate locals{...} // ------------------------------------------------------------ if pRuleBlock.Locals <> '' then printAction( pRuleBlock.Locals); DEC(fTabs); println(''); end; end; // ============================================================================ // Gen(TokenRef) // ============================================================================ procedure TDelphiGenerator.Gen(pTokenRef: ITokenRefElem); begin if not fIsLexer then begin if (pTokenRef.Lbl <> '') and (fSyntacticPredLevel = 0) then println(pTokenRef.Lbl + ' := ' + fLT1Value + ';'); genMatch( pTokenRef); end else fTool.Panic('Token reference found in lexer...'); end; // ============================================================================ // Gen(TokenRange) // ============================================================================ procedure TDelphiGenerator.Gen(pElem: ITokenRangeElem); begin if not fIsLexer then begin if (pElem.Lbl <> '') and (fSyntacticPredLevel = 0) then println( pElem.Lbl + ' := ' + fLT1Value + ';'); if pElem.BeginToken < pElem.EndToken then println('match( [' + TokenSetToStr( [pElem.BeginToken..pElem.EndToken], fGrammar.TokenManager) + ']);') else println('match( [' + TokenSetToStr( [pElem.EndToken..pElem.BeginToken], fGrammar.TokenManager) + ']);'); end; end; // ============================================================================ // Gen(GrammarAtom) // ============================================================================ procedure TDelphiGenerator.Gen(pAtom: IGrammarAtom); var tr : ITokenRefElem; begin if pAtom.QueryInterface(ITokenRefElem, tr) = S_OK then Gen(tr) else println('***InternalError:GrammarAtom generation***'); end; // ============================================================================ // Gen(BlockEnd) // ============================================================================ procedure TDelphiGenerator.Gen(pEnd: IBlockEndElem); begin println('***InternalError:BlockEndElem generation***'); end; // ============================================================================ // Gen(RuleEndElem) // ============================================================================ procedure TDelphiGenerator.Gen(pElem: IRuleEndElem); begin println('***InternalError:RuleEndElem generation***'); end; // ============================================================================ // Gen(SynPredBlock) // ============================================================================ procedure TDelphiGenerator.Gen(pBlk: ISynPredBlock); begin println('***InternalError:SynPredBlock generation***'); end; // ============================================================================ // Gen(RuleBlock) // ============================================================================ procedure TDelphiGenerator.Gen(pBlk: IRuleBlock); begin println('***InternalError:RuleBlock generation***'); end; function TDelphiGenerator.altIsEmpty(pAlt: IAlternative): boolean; var elem : IAlternativeElem; be : IBlockEndElem; begin elem := pAlt.Head; if elem.QueryInterface(IBlockEndElem, be) = S_OK then result := true else result := false; end; // ============================================================================ // ============================================================================ // throw // ============================================================================ function TDelphiGenerator.throw(pLA1: ILookahead): AnsiString; begin if fIsLexer then result := 'Raise EMismatchedChar.Create( LA(1), [' + CharSetToStr( pLA1.LaSet) + '], InputState.FileName, InputState.Line, InputState.Column);' else result := 'Raise EMismatchedToken.Create( LT(1), [' + TokenSetToStr( pLA1.LaSet, fGrammar.TokenManager) + '], InputState.FileName);'; end; // ============================================================================ // needsLexerInit // ============================================================================ function TDelphiGenerator.needsLexerInit: boolean; var i : integer; name : AnsiString; begin if fIsLexer then begin for name in fGrammar.TokenManager.Vocabulary.Keys do begin if name[1] = '"' then begin result := true; break; end; end; // for i:=0 to fGrammar.TokenManager.Vocabulary.Count -1 do // begin // name := fGrammar.TokenManager.Vocabulary.Names[i]; // // if name[1] = '"' then // begin // result := true; // break; // end; // end; if not fLexerGrammar.CaseSensitive then result := true; end else result := false; end; end.