* First version as part of FCL

fcl/passrc/Makefile.fpc

@@ -0,0 +1,15 @@
+#
+#   Makefile.fpc for FCL Pascal source file parsing and writing units
+#
+
+[package]
+main=fcl
+
+[target]
+units=pastree pscanner pparser paswrite
+
+[compiler]
+options=-S2h
+
+[install]
+fpcpackage=y

fcl/passrc/paswrite.pp

@@ -0,0 +1,622 @@
+{
+    $Id$
+    This file is part of the Free Component Library
+
+    Pascal tree source file writer
+    Copyright (c) 2003 by
+      Areca Systems GmbH / Sebastian Guenther, sg@freepascal.org
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+
+
+unit PasWrite;
+
+interface
+
+uses Classes, PasTree;
+
+type
+  TPasWriter = class
+  private
+    FStream: TStream;
+    IsStartOfLine: Boolean;
+    Indent, CurDeclSection: String;
+    DeclSectionStack: TList;
+    procedure IncIndent;
+    procedure DecIndent;
+    procedure IncDeclSectionLevel;
+    procedure DecDeclSectionLevel;
+    procedure PrepareDeclSection(const ADeclSection: String);
+  public
+    constructor Create(AStream: TStream);
+    destructor Destroy; override;
+    procedure wrt(const s: String);
+    procedure wrtln(const s: String);
+    procedure wrtln;
+
+    procedure WriteElement(AElement: TPasElement);
+    procedure WriteType(AType: TPasType);
+    procedure WriteModule(AModule: TPasModule);
+    procedure WriteSection(ASection: TPasSection);
+    procedure WriteClass(AClass: TPasClassType);
+    procedure WriteVariable(AVar: TPasVariable);
+    procedure WriteProcDecl(AProc: TPasProcedure);
+    procedure WriteProcImpl(AProc: TPasProcedureImpl);
+    procedure WriteProperty(AProp: TPasProperty);
+    procedure WriteImplBlock(ABlock: TPasImplBlock);
+    procedure WriteImplElement(AElement: TPasImplElement;
+      AAutoInsertBeginEnd: Boolean);
+    procedure WriteImplCommand(ACommand: TPasImplCommand);
+    procedure WriteImplCommands(ACommands: TPasImplCommands);
+    procedure WriteImplIfElse(AIfElse: TPasImplIfElse);
+    procedure WriteImplForLoop(AForLoop: TPasImplForLoop);
+    property Stream: TStream read FStream;
+  end;
+
+
+procedure WritePasFile(AElement: TPasElement; const AFilename: String);
+procedure WritePasFile(AElement: TPasElement; AStream: TStream);
+
+
+
+implementation
+
+uses SysUtils;
+
+type
+  PDeclSectionStackElement = ^TDeclSectionStackElement;
+  TDeclSectionStackElement = record
+    LastDeclSection, LastIndent: String;
+  end;
+
+constructor TPasWriter.Create(AStream: TStream);
+begin
+  FStream := AStream;
+  IsStartOfLine := True;
+  DeclSectionStack := TList.Create;
+end;
+
+destructor TPasWriter.Destroy;
+var
+  i: Integer;
+  El: PDeclSectionStackElement;
+begin
+  for i := 0 to DeclSectionStack.Count - 1 do
+  begin
+    El := PDeclSectionStackElement(DeclSectionStack[i]);
+    Dispose(El);
+  end;
+  DeclSectionStack.Free;
+  inherited Destroy;
+end;
+
+procedure TPasWriter.wrt(const s: String);
+begin
+  if IsStartOfLine then
+  begin
+    if Length(Indent) > 0 then
+      Stream.Write(Indent[1], Length(Indent));
+    IsStartOfLine := False;
+  end;
+  Stream.Write(s[1], Length(s));
+end;
+
+const
+  LF: String = #10;
+
+procedure TPasWriter.wrtln(const s: String);
+begin
+  wrt(s);
+  Stream.Write(LF[1], 1);
+  IsStartOfLine := True;
+end;
+
+procedure TPasWriter.wrtln;
+begin
+  Stream.Write(LF[1], 1);
+  IsStartOfLine := True;
+end;
+
+procedure TPasWriter.WriteElement(AElement: TPasElement);
+begin
+  if AElement.ClassType = TPasModule then
+    WriteModule(TPasModule(AElement))
+  else if AElement.ClassType = TPasSection then
+    WriteSection(TPasSection(AElement))
+  else if AElement.ClassType = TPasVariable then
+    WriteVariable(TPasVariable(AElement))
+  else if AElement.InheritsFrom(TPasType) then
+    WriteType(TPasType(AElement))
+  else if AElement.InheritsFrom(TPasProcedure) then
+    WriteProcDecl(TPasProcedure(AElement))
+  else if AElement.InheritsFrom(TPasProcedureImpl) then
+    WriteProcImpl(TPasProcedureImpl(AElement))
+  else if AElement.ClassType = TPasProperty then
+    WriteProperty(TPasProperty(AElement))
+  else
+    raise Exception.Create('Writing not implemented for ' +
+      AElement.ElementTypeName + ' nodes');
+end;
+
+procedure TPasWriter.WriteType(AType: TPasType);
+begin
+  if AType.ClassType = TPasUnresolvedTypeRef then
+    wrt(AType.Name)
+  else if AType.ClassType = TPasClassType then
+    WriteClass(TPasClassType(AType))
+  else
+    raise Exception.Create('Writing not implemented for ' +
+      AType.ElementTypeName + ' nodes');
+end;
+
+
+procedure TPasWriter.WriteModule(AModule: TPasModule);
+begin
+  wrtln('unit ' + AModule.Name + ';');
+  wrtln;
+  wrtln('interface');
+  wrtln;
+  WriteSection(AModule.InterfaceSection);
+  Indent := '';
+  wrtln;
+  wrtln;
+  wrtln('implementation');
+  if Assigned(AModule.ImplementationSection) then
+  begin
+    wrtln;
+    WriteSection(AModule.ImplementationSection);
+  end;
+  wrtln;
+  wrtln('end.');
+end;
+
+procedure TPasWriter.WriteSection(ASection: TPasSection);
+var
+  i: Integer;
+begin
+  if ASection.UsesList.Count > 0 then
+  begin
+    wrt('uses ');
+    for i := 0 to ASection.UsesList.Count - 1 do
+    begin
+      if i > 0 then
+        wrt(', ');
+      wrt(TPasElement(ASection.UsesList[i]).Name);
+    end;
+    wrtln(';');
+    wrtln;
+  end;
+
+  CurDeclSection := '';
+
+  for i := 0 to ASection.Declarations.Count - 1 do
+    WriteElement(TPasElement(ASection.Declarations[i]));
+end;
+
+procedure TPasWriter.WriteClass(AClass: TPasClassType);
+var
+  i: Integer;
+  Member: TPasElement;
+  LastVisibility, CurVisibility: TPasMemberVisibility;
+begin
+  PrepareDeclSection('type');
+  wrt(AClass.Name + ' = ');
+  case AClass.ObjKind of
+    okObject: wrt('object');
+    okClass: wrt('class');
+    okInterface: wrt('interface');
+  end;
+  if Assigned(AClass.AncestorType) then
+    wrtln('(' + AClass.AncestorType.Name + ')')
+  else
+    wrtln;
+  IncIndent;
+  LastVisibility := visDefault;
+  for i := 0 to AClass.Members.Count - 1 do
+  begin
+    Member := TPasElement(AClass.Members[i]);
+    CurVisibility := Member.Visibility;
+    if CurVisibility <> LastVisibility then
+    begin
+      DecIndent;
+      case CurVisibility of
+        visPrivate: wrtln('private');
+	visProtected: wrtln('protected');
+	visPublic: wrtln('public');
+	visPublished: wrtln('published');
+	visAutomated: wrtln('automated');
+      end;
+      IncIndent;
+      LastVisibility := CurVisibility;
+    end;
+    WriteElement(Member);
+  end;
+  DecIndent;
+  wrtln('end;');
+  wrtln;
+end;
+
+procedure TPasWriter.WriteVariable(AVar: TPasVariable);
+begin
+  if (AVar.Parent.ClassType <> TPasClassType) and
+    (AVar.Parent.ClassType <> TPasRecordType) then
+    PrepareDeclSection('var');
+  wrt(AVar.Name + ': ');
+  WriteType(AVar.VarType);
+  wrtln(';');
+end;
+
+procedure TPasWriter.WriteProcDecl(AProc: TPasProcedure);
+var
+  i: Integer;
+begin
+  wrt(AProc.TypeName + ' ' + AProc.Name);
+
+  if Assigned(AProc.ProcType) and (AProc.ProcType.Args.Count > 0) then
+  begin
+    wrt('(');
+    for i := 0 to AProc.ProcType.Args.Count - 1 do
+      with TPasArgument(AProc.ProcType.Args[i]) do
+      begin
+        if i > 0 then
+	  wrt('; ');
+        case Access of
+	  argConst: wrt('const ');
+	  argVar: wrt('var ');
+	end;
+	wrt(Name);
+	if Assigned(ArgType) then
+	begin
+	  wrt(': ');
+	  WriteElement(ArgType);
+	end;
+	if Value <> '' then
+	  wrt(' = ' + Value);
+      end;
+    wrt(')');
+  end;
+
+  if Assigned(AProc.ProcType) and
+    (AProc.ProcType.ClassType = TPasFunctionType) then
+  begin
+    wrt(': ');
+    WriteElement(TPasFunctionType(AProc.ProcType).ResultEl.ResultType);
+  end;
+
+  wrt(';');
+
+  if AProc.IsVirtual then
+    wrt(' virtual;');
+  if AProc.IsDynamic then
+    wrt(' dynamic;');
+  if AProc.IsAbstract then
+    wrt(' abstract;');
+  if AProc.IsOverride then
+    wrt(' override;');
+  if AProc.IsOverload then
+    wrt(' overload;');
+
+  // !!!: Not handled: Message, calling conventions
+
+  wrtln;
+end;
+
+procedure TPasWriter.WriteProcImpl(AProc: TPasProcedureImpl);
+var
+  i: Integer;
+begin
+  PrepareDeclSection('');
+  wrt(AProc.TypeName + ' ');
+
+  if AProc.Parent.ClassType = TPasClassType then
+    wrt(AProc.Parent.Name + '.');
+
+  wrt(AProc.Name);
+
+  if Assigned(AProc.ProcType) and (AProc.ProcType.Args.Count > 0) then
+  begin
+    wrt('(');
+    for i := 0 to AProc.ProcType.Args.Count - 1 do
+      with TPasArgument(AProc.ProcType.Args[i]) do
+      begin
+        if i > 0 then
+	  wrt('; ');
+        case Access of
+	  argConst: wrt('const ');
+	  argVar: wrt('var ');
+	end;
+	wrt(Name);
+	if Assigned(ArgType) then
+	begin
+	  wrt(': ');
+	  WriteElement(ArgType);
+	end;
+	if Value <> '' then
+	  wrt(' = ' + Value);
+      end;
+    wrt(')');
+  end;
+
+  if Assigned(AProc.ProcType) and
+    (AProc.ProcType.ClassType = TPasFunctionType) then
+  begin
+    wrt(': ');
+    WriteElement(TPasFunctionType(AProc.ProcType).ResultEl.ResultType);
+  end;
+
+  wrtln(';');
+  IncDeclSectionLevel;
+  for i := 0 to AProc.Locals.Count - 1 do
+  begin
+    if TPasElement(AProc.Locals[i]).InheritsFrom(TPasProcedureImpl) then
+    begin
+      IncIndent;
+      if (i = 0) or not
+        TPasElement(AProc.Locals[i - 1]).InheritsFrom(TPasProcedureImpl) then
+        wrtln;
+    end;
+
+    WriteElement(TPasElement(AProc.Locals[i]));
+
+    if TPasElement(AProc.Locals[i]).InheritsFrom(TPasProcedureImpl) then
+      DecIndent;
+  end;
+  DecDeclSectionLevel;
+
+  wrtln('begin');
+  IncIndent;
+  if Assigned(AProc.Body) then
+    WriteImplBlock(AProc.Body);
+  DecIndent;
+  wrtln('end;');
+  wrtln;
+end;
+
+procedure TPasWriter.WriteProperty(AProp: TPasProperty);
+var
+  i: Integer;
+begin
+  wrt('property ' + AProp.Name);
+  if AProp.Args.Count > 0 then
+  begin
+    wrt('[');
+    for i := 0 to AProp.Args.Count - 1 do;
+      // !!!: Create WriteArgument method and call it here
+    wrt(']');
+  end;
+  if Assigned(AProp.VarType) then
+  begin
+    wrt(': ');
+    WriteType(AProp.VarType);
+  end;
+  if AProp.ReadAccessorName <> '' then
+    wrt(' read ' + AProp.ReadAccessorName);
+  if AProp.WriteAccessorName <> '' then
+    wrt(' write ' + AProp.WriteAccessorName);
+  if AProp.StoredAccessorName <> '' then
+    wrt(' stored ' + AProp.StoredAccessorName);
+  if AProp.DefaultValue <> '' then
+    wrt(' default ' + AProp.DefaultValue);
+  if AProp.IsNodefault then
+    wrt(' nodefault');
+  if AProp.IsDefault then
+    wrt('; default');
+  wrtln(';');
+end;
+
+procedure TPasWriter.WriteImplBlock(ABlock: TPasImplBlock);
+var
+  i: Integer;
+begin
+  for i := 0 to ABlock.Elements.Count - 1 do
+  begin
+    WriteImplElement(TPasImplElement(ABlock.Elements[i]), False);
+    if TPasImplElement(ABlock.Elements[i]).ClassType = TPasImplCommand then
+      wrtln(';');
+  end;
+end;
+
+procedure TPasWriter.WriteImplElement(AElement: TPasImplElement;
+  AAutoInsertBeginEnd: Boolean);
+begin
+  if AElement.ClassType = TPasImplCommand then
+    WriteImplCommand(TPasImplCommand(AElement))
+  else if AElement.ClassType = TPasImplCommands then
+  begin
+    DecIndent;
+    if AAutoInsertBeginEnd then
+      wrtln('begin');
+    IncIndent;
+    WriteImplCommands(TPasImplCommands(AElement));
+    DecIndent;
+    if AAutoInsertBeginEnd then
+      wrtln('end;');
+    IncIndent;
+  end else if AElement.ClassType = TPasImplBlock then
+  begin
+    DecIndent;
+    if AAutoInsertBeginEnd then
+      wrtln('begin');
+    IncIndent;
+    WriteImplBlock(TPasImplBlock(AElement));
+    DecIndent;
+    if AAutoInsertBeginEnd then
+      wrtln('end;');
+    IncIndent;
+  end else if AElement.ClassType = TPasImplIfElse then
+    WriteImplIfElse(TPasImplIfElse(AElement))
+  else if AElement.ClassType = TPasImplForLoop then
+    WriteImplForLoop(TPasImplForLoop(AElement))
+  else
+    raise Exception.Create('Writing not yet implemented for ' +
+      AElement.ClassName + ' implementation elements');
+end;
+
+procedure TPasWriter.WriteImplCommand(ACommand: TPasImplCommand);
+begin
+  wrt(ACommand.Command);
+end;
+
+procedure TPasWriter.WriteImplCommands(ACommands: TPasImplCommands);
+var
+  i: Integer;
+  s: String;
+begin
+  for i := 0 to ACommands.Commands.Count - 1 do
+  begin
+    s := ACommands.Commands[i];
+    if Length(s) > 0 then
+      if (Length(s) >= 2) and (s[1] = '/') and (s[2] = '/') then
+        wrtln(s)
+      else
+	wrtln(s + ';');
+  end;
+end;
+
+procedure TPasWriter.WriteImplIfElse(AIfElse: TPasImplIfElse);
+begin
+  wrt('if ' + AIfElse.Condition + ' then');
+  if Assigned(AIfElse.IfBranch) then
+  begin
+    wrtln;
+    if (AIfElse.IfBranch.ClassType = TPasImplCommands) or
+      (AIfElse.IfBranch.ClassType = TPasImplBlock) then
+      wrtln('begin');
+    IncIndent;
+    WriteImplElement(AIfElse.IfBranch, False);
+    DecIndent;
+    if (AIfElse.IfBranch.ClassType = TPasImplCommands) or
+      (AIfElse.IfBranch.ClassType = TPasImplBlock) then
+      if Assigned(AIfElse.ElseBranch) then
+	wrt('end ')
+      else
+        wrtln('end;')
+    else
+      if Assigned(AIfElse.ElseBranch) then
+        wrtln;
+  end else
+    if not Assigned(AIfElse.ElseBranch) then
+      wrtln(';')
+    else
+      wrtln;
+
+  if Assigned(AIfElse.ElseBranch) then
+    if AIfElse.ElseBranch.ClassType = TPasImplIfElse then
+    begin
+      wrt('else ');
+      WriteImplElement(AIfElse.ElseBranch, True);
+    end else
+    begin
+      wrtln('else');
+      IncIndent;
+      WriteImplElement(AIfElse.ElseBranch, True);
+      if (not Assigned(AIfElse.Parent)) or
+        (AIfElse.Parent.ClassType <> TPasImplIfElse) or
+	(TPasImplIfElse(AIfElse.Parent).IfBranch <> AIfElse) then
+        wrtln(';');
+      DecIndent;
+    end;
+end;
+
+procedure TPasWriter.WriteImplForLoop(AForLoop: TPasImplForLoop);
+begin
+  wrtln('for ' + AForLoop.Variable.Name + ' := ' + AForLoop.StartValue +
+    ' to ' + AForLoop.EndValue + ' do');
+  IncIndent;
+  WriteImplElement(AForLoop.Body, True);
+  DecIndent;
+  if (AForLoop.Body.ClassType <> TPasImplBlock) and
+    (AForLoop.Body.ClassType <> TPasImplCommands) then
+      wrtln(';');
+end;
+
+procedure TPasWriter.IncIndent;
+begin
+  Indent := Indent + '  ';
+end;
+
+procedure TPasWriter.DecIndent;
+begin
+  if Indent = '' then
+    raise Exception.Create('Internal indent error');
+  SetLength(Indent, Length(Indent) - 2);
+end;
+
+procedure TPasWriter.IncDeclSectionLevel;
+var
+  El: PDeclSectionStackElement;
+begin
+  New(El);
+  DeclSectionStack.Add(El);
+  El^.LastDeclSection := CurDeclSection;
+  El^.LastIndent := Indent;
+  CurDeclSection := '';
+end;
+
+procedure TPasWriter.DecDeclSectionLevel;
+var
+  El: PDeclSectionStackElement;
+begin
+  El := PDeclSectionStackElement(DeclSectionStack[DeclSectionStack.Count - 1]);
+  DeclSectionStack.Delete(DeclSectionStack.Count - 1);
+  CurDeclSection := El^.LastDeclSection;
+  Indent := El^.LastIndent;
+  Dispose(El);
+end;
+
+procedure TPasWriter.PrepareDeclSection(const ADeclSection: String);
+begin
+  if ADeclSection <> CurDeclSection then
+  begin
+    if CurDeclsection <> '' then
+      DecIndent;
+    if ADeclSection <> '' then
+    begin
+      wrtln(ADeclSection);
+      IncIndent;
+    end;
+    CurDeclSection := ADeclSection;
+  end;
+end;
+
+
+procedure WritePasFile(AElement: TPasElement; const AFilename: String);
+var
+  Stream: TFileStream;
+begin
+  Stream := TFileStream.Create(AFilename, fmCreate);
+  try
+    WritePasFile(AElement, Stream);
+  finally
+    Stream.Free;
+  end;
+end;
+
+procedure WritePasFile(AElement: TPasElement; AStream: TStream);
+var
+  Writer: TPasWriter;
+begin
+  Writer := TPasWriter.Create(AStream);
+  try
+    Writer.WriteElement(AElement);
+  finally
+    Writer.Free;
+  end;
+end;
+
+end.
+
+
+{
+  $Log$
+  Revision 1.1  2003-03-13 21:47:42  sg
+  * First version as part of FCL
+
+}

fcl/passrc/pscanner.pp

@@ -0,0 +1,821 @@
+{
+    $Id$
+    This file is part of the Free Component Library
+
+    Pascal source lexical scanner
+    Copyright (c) 2003 by
+      Areca Systems GmbH / Sebastian Guenther, sg@freepascal.org
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+
+
+unit PScanner;
+
+interface
+
+uses SysUtils, Classes;
+
+resourcestring
+  SErrInvalidCharacter = 'Invalid character ''%s''';
+  SErrOpenString = 'String exceeds end of line';
+  SErrIncludeFileNotFound = 'Could not find include file ''%s''';
+
+type
+
+  TToken = (
+    tkEOF,
+    tkWhitespace,
+    tkComment,
+    tkIdentifier,
+    tkString,
+    tkNumber,
+    tkChar,
+    // Simple (one-character) tokens
+    tkBraceOpen,	// '('
+    tkBraceClose,	// ')'
+    tkMul,		// '*'
+    tkPlus,		// '+'
+    tkComma,		// ','
+    tkMinus,		// '-'
+    tkDot,		// '.'
+    tkDivision,		// '/'
+    tkColon,		// ':'
+    tkSemicolon,	// ';'
+    tkEqual,		// '='
+    tkSquaredBraceOpen,	// '['
+    tkSquaredBraceClose,// ']'
+    tkCaret,		// '^'
+    // Two-character tokens
+    tkDotDot,		// '..'
+    tkAssign,		// ':='
+    // Reserved words
+    tkabsolute,
+    tkand,
+    tkarray,
+    tkas,
+    tkasm,
+    tkbegin,
+    tkbreak,
+    tkcase,
+    tkclass,
+    tkconst,
+    tkconstructor,
+    tkcontinue,
+    tkdestructor,
+    tkdispose,
+    tkdiv,
+    tkdo,
+    tkdownto,
+    tkelse,
+    tkend,
+    tkexcept,
+    tkexit,
+    tkexports,
+    tkfalse,
+    tkfinalization,
+    tkfinally,
+    tkfor,
+    tkfunction,
+    tkgoto,
+    tkif,
+    tkimplementation,
+    tkin,
+    tkinherited,
+    tkinitialization,
+    tkinline,
+    tkinterface,
+    tkis,
+    tklabel,
+    tklibrary,
+    tkmod,
+    tknew,
+    tknil,
+    tknot,
+    tkobject,
+    tkof,
+    tkon,
+    tkoperator,
+    tkor,
+    tkpacked,
+    tkprocedure,
+    tkprogram,
+    tkproperty,
+    tkraise,
+    tkrecord,
+    tkrepeat,
+    tkResourceString,
+    tkself,
+    tkset,
+    tkshl,
+    tkshr,
+//    tkstring,
+    tkthen,
+    tkto,
+    tktrue,
+    tktry,
+    tktype,
+    tkunit,
+    tkuntil,
+    tkuses,
+    tkvar,
+    tkwhile,
+    tkwith,
+    tkxor);
+
+  TLineReader = class
+  public
+    function IsEOF: Boolean; virtual; abstract;
+    function ReadLine: String; virtual; abstract;
+  end;
+
+  TFileLineReader = class(TLineReader)
+  private
+    FTextFile: Text;
+    FileOpened: Boolean;
+  public
+    constructor Create(const AFilename: String);
+    destructor Destroy; override;
+    function IsEOF: Boolean; override;
+    function ReadLine: String; override;
+  end;
+
+  TFileResolver = class
+  private
+    FIncludePaths: TStringList;
+  public
+    constructor Create;
+    destructor Destroy; override;
+    procedure AddIncludePath(const APath: String);
+    function FindSourceFile(const AName: String): TLineReader;
+    function FindIncludeFile(const AName: String): TLineReader;
+  end;
+
+  EScannerError = class(Exception);
+
+  TPascalScanner = class
+  private
+    FFileResolver: TFileResolver;
+    FCurSourceFile: TLineReader;
+    FCurFilename: String;
+    FCurRow: Integer;
+    FCurToken: TToken;
+    FCurTokenString: String;
+    FCurLine: String;
+    TokenStr: PChar;
+    FIncludeStack: TList;
+    function GetCurColumn: Integer;
+  protected
+    procedure Error(const Msg: String);
+    procedure Error(const Msg: String; Args: array of Const);
+    function DoFetchToken: TToken;
+  public
+    constructor Create(AFileResolver: TFileResolver; const AFilename: String);
+    destructor Destroy; override;
+    function FetchToken: TToken;
+
+    property FileResolver: TFileResolver read FFileResolver;
+    property CurSourceFile: TLineReader read FCurSourceFile;
+    property CurFilename: String read FCurFilename;
+
+    property CurLine: String read FCurLine;
+    property CurRow: Integer read FCurRow;
+    property CurColumn: Integer read GetCurColumn;
+
+    property CurToken: TToken read FCurToken;
+    property CurTokenString: String read FCurTokenString;
+  end;
+
+const
+  TokenInfos: array[TToken] of String = (
+    'EOF',
+    'Whitespace',
+    'Comment',
+    'Identifier',
+    'String',
+    'Number',
+    'Character',
+    '(',
+    ')',
+    '*',
+    '+',
+    ',',
+    '-',
+    '.',
+    '/',
+    ':',
+    ';',
+    '=',
+    '[',
+    ']',
+    '^',
+    '..',
+    ':=',
+    // Reserved words
+    'absolute',
+    'and',
+    'array',
+    'as',
+    'asm',
+    'begin',
+    'break',
+    'case',
+    'class',
+    'const',
+    'constructor',
+    'continue',
+    'destructor',
+    'dispose',
+    'div',
+    'do',
+    'downto',
+    'else',
+    'end',
+    'except',
+    'exit',
+    'exports',
+    'false',
+    'finalization',
+    'finally',
+    'for',
+    'function',
+    'goto',
+    'if',
+    'implementation',
+    'in',
+    'inherited',
+    'initialization',
+    'inline',
+    'interface',
+    'is',
+    'label',
+    'library',
+    'mod',
+    'new',
+    'nil',
+    'not',
+    'object',
+    'of',
+    'on',
+    'operator',
+    'or',
+    'packed',
+    'procedure',
+    'program',
+    'property',
+    'raise',
+    'record',
+    'repeat',
+    'resourcestring',
+    'self',
+    'set',
+    'shl',
+    'shr',
+//    'string',
+    'then',
+    'to',
+    'true',
+    'try',
+    'type',
+    'unit',
+    'until',
+    'uses',
+    'var',
+    'while',
+    'with',
+    'xor'
+  );
+
+
+implementation
+
+type
+  TIncludeStackItem = class
+    SourceFile: TLineReader;
+    Filename: String;
+    Token: TToken;
+    TokenString: String;
+    Line: String;
+    Row: Integer;
+    TokenStr: PChar;
+  end;
+
+
+constructor TFileLineReader.Create(const AFilename: String);
+begin
+  inherited Create;
+  Assign(FTextFile, AFilename);
+  Reset(FTextFile);
+  FileOpened := True;
+end;
+
+destructor TFileLineReader.Destroy;
+begin
+  if FileOpened then
+    Close(FTextFile);
+  inherited Destroy;
+end;
+
+function TFileLineReader.IsEOF: Boolean;
+begin
+  Result := EOF(FTextFile);
+end;
+
+function TFileLineReader.ReadLine: String;
+begin
+  ReadLn(FTextFile, Result);
+end;
+
+
+constructor TFileResolver.Create;
+begin
+  inherited Create;
+  FIncludePaths := TStringList.Create;
+end;
+
+destructor TFileResolver.Destroy;
+begin
+  FIncludePaths.Free;
+  inherited Destroy;
+end;
+
+procedure TFileResolver.AddIncludePath(const APath: String);
+begin
+  FIncludePaths.Add(IncludeTrailingPathDelimiter(APath));
+end;
+
+function TFileResolver.FindSourceFile(const AName: String): TLineReader;
+begin
+  try
+    Result := TFileLineReader.Create(AName);
+  except
+    Result := nil;
+  end;
+end;
+
+function TFileResolver.FindIncludeFile(const AName: String): TLineReader;
+var
+  i: Integer;
+begin
+  Result := nil;
+  try
+    Result := TFileLineReader.Create(AName);
+  except
+    for i := 0 to FIncludePaths.Count - 1 do
+      try
+        Result := TFileLineReader.Create(FIncludePaths[i] + AName);
+	break;
+      except
+      end;
+  end;
+end;
+
+
+constructor TPascalScanner.Create(AFileResolver: TFileResolver;
+  const AFilename: String);
+begin
+  inherited Create;
+  FFileResolver := AFileResolver;
+  FCurSourceFile := FileResolver.FindSourceFile(AFilename);
+  FCurFilename := AFilename;
+  FIncludeStack := TList.Create;
+end;
+
+destructor TPascalScanner.Destroy;
+begin
+  // Dont' free the first element, because it is CurSourceFile
+  while FIncludeStack.Count > 1 do
+    TFileResolver(FIncludeStack[1]).Free;
+  FIncludeStack.Free;
+
+  CurSourceFile.Free;
+  inherited Destroy;
+end;
+
+function TPascalScanner.FetchToken: TToken;
+var
+  IncludeStackItem: TIncludeStackItem;
+begin
+  while True do
+  begin
+    Result := DoFetchToken;
+    if FCurToken = tkEOF then
+      if FIncludeStack.Count > 0 then
+      begin
+        CurSourceFile.Free;
+	IncludeStackItem :=
+	  TIncludeStackItem(FIncludeStack[FIncludeStack.Count - 1]);
+	FIncludeStack.Delete(FIncludeStack.Count - 1);
+	FCurSourceFile := IncludeStackItem.SourceFile;
+	FCurFilename := IncludeStackItem.Filename;
+	FCurToken := IncludeStackItem.Token;
+	FCurTokenString := IncludeStackItem.TokenString;
+	FCurLine := IncludeStackItem.Line;
+	FCurRow := IncludeStackItem.Row;
+	TokenStr := IncludeStackItem.TokenStr;
+	IncludeStackItem.Free;
+	Result := FCurToken;
+      end else
+        break
+    else
+      break;
+  end;
+end;
+
+procedure TPascalScanner.Error(const Msg: String);
+begin
+  raise EScannerError.Create(Msg);
+end;
+
+procedure TPascalScanner.Error(const Msg: String; Args: array of Const);
+begin
+  raise EScannerError.CreateFmt(Msg, Args);
+end;
+
+function TPascalScanner.DoFetchToken: TToken;
+
+  function FetchLine: Boolean;
+  begin
+    if CurSourceFile.IsEOF then
+    begin
+      FCurLine := '';
+      TokenStr := nil;
+      Result := False;
+    end else
+    begin
+      FCurLine := CurSourceFile.ReadLine;
+      TokenStr := PChar(CurLine);
+      Result := True;
+      Inc(FCurRow);
+    end;
+  end;
+
+var
+  TokenStart, CurPos: PChar;
+  i: TToken;
+  OldLength, SectionLength, NestingLevel: Integer;
+  Directive, Param: String;
+  IncludeStackItem: TIncludeStackItem;
+begin
+  if TokenStr = nil then
+    if not FetchLine then
+    begin
+      Result := tkEOF;
+      FCurToken := Result;
+      exit;
+    end;
+
+  FCurTokenString := '';
+
+  case TokenStr[0] of
+    #0:		// Empty line
+      begin
+        FetchLine;
+        Result := tkWhitespace;
+      end;
+    #9, ' ':
+      begin
+	Result := tkWhitespace;
+        repeat
+	  Inc(TokenStr);
+	  if TokenStr[0] = #0 then
+	    if not FetchLine then
+	    begin
+	      FCurToken := Result;
+	      exit;
+	    end;
+	until not (TokenStr[0] in [#9, ' ']);
+      end;
+    '#':
+      begin
+        TokenStart := TokenStr;
+	Inc(TokenStr);
+	if TokenStr[0] = '$' then
+	begin
+	  Inc(TokenStr);
+	  repeat
+	    Inc(TokenStr);
+	  until not (TokenStr[0] in ['0'..'9', 'A'..'F', 'a'..'F']);
+	end else
+	  repeat
+	    Inc(TokenStr);
+	  until not (TokenStr[0] in ['0'..'9']);
+
+	SectionLength := TokenStr - TokenStart;
+	SetLength(FCurTokenString, SectionLength);
+	if SectionLength > 0 then
+	  Move(TokenStart^, FCurTokenString[1], SectionLength);
+	Result := tkChar;
+      end;
+    '$':
+      begin
+        TokenStart := TokenStr;
+	repeat
+	  Inc(TokenStr);
+	until not (TokenStr[0] in ['0'..'9', 'A'..'F', 'a'..'F']);
+	SectionLength := TokenStr - TokenStart;
+	SetLength(FCurTokenString, SectionLength);
+	if SectionLength > 0 then
+	  Move(TokenStart^, FCurTokenString[1], SectionLength);
+	Result := tkNumber;
+      end;
+    '''':
+      begin
+        Inc(TokenStr);
+        TokenStart := TokenStr;
+	OldLength := 0;
+	FCurTokenString := '';
+
+	while True do
+	begin
+	  if TokenStr[0] = '''' then
+	    if TokenStr[1] = '''' then
+	    begin
+	      SectionLength := TokenStr - TokenStart + 1;
+	      SetLength(FCurTokenString, OldLength + SectionLength);
+	      if SectionLength > 1 then
+	        Move(TokenStart^, FCurTokenString[OldLength + 1],
+		  SectionLength);
+	      Inc(OldLength, SectionLength);
+	      Inc(TokenStr);
+	      TokenStart := TokenStr;
+	    end else
+	      break;
+
+	  if TokenStr[0] = #0 then
+	    Error(SErrOpenString);
+
+	  Inc(TokenStr);
+	end;
+
+	SectionLength := TokenStr - TokenStart;
+	SetLength(FCurTokenString, OldLength + SectionLength);
+	if SectionLength > 0 then
+	  Move(TokenStart^, FCurTokenString[OldLength + 1], SectionLength);
+
+	Inc(TokenStr);
+	Result := tkString;
+      end;
+    '(':
+      begin
+        Inc(TokenStr);
+	if TokenStr[0] = '*' then
+	begin
+	  // Old-style multi-line comment
+	  Inc(TokenStr);
+          while (TokenStr[0] <> '*') or (TokenStr[1] <> ')') do
+	  begin
+	    if TokenStr[0] = #0 then
+	    begin
+	      if not FetchLine then
+	      begin
+	        Result := tkEOF;
+	        FCurToken := Result;
+	        exit;
+	      end;
+	    end else
+	      Inc(TokenStr);
+	  end;
+	  Inc(TokenStr, 2);
+	  Result := tkComment;
+        end else
+	  Result := tkBraceOpen;
+      end;
+    ')':
+      begin
+        Inc(TokenStr);
+	Result := tkBraceClose;
+      end;
+    '*':
+      begin
+        Inc(TokenStr);
+	Result := tkMul;
+      end;
+    '+':
+      begin
+        Inc(TokenStr);
+	Result := tkPlus;
+      end;
+    ',':
+      begin
+        Inc(TokenStr);
+	Result := tkComma;
+      end;
+    '-':
+      begin
+        Inc(TokenStr);
+	Result := tkMinus;
+      end;
+    '.':
+      begin
+        Inc(TokenStr);
+	if TokenStr[0] = '.' then
+	begin
+	  Inc(TokenStr);
+	  Result := tkDotDot;
+	end else
+	  Result := tkDot;
+      end;
+    '/':
+      begin
+        Inc(TokenStr);
+	if TokenStr[0] = '/' then	// Single-line comment
+	begin
+	  Inc(TokenStr);
+	  TokenStart := TokenStr;
+	  FCurTokenString := '';
+          while TokenStr[0] <> #0 do
+	    Inc(TokenStr);
+	  SectionLength := TokenStr - TokenStart;
+	  SetLength(FCurTokenString, SectionLength);
+	  if SectionLength > 0 then
+	    Move(TokenStart^, FCurTokenString[1], SectionLength);
+	  Result := tkComment;
+	  //WriteLn('Einzeiliger Kommentar: "', CurTokenString, '"');
+	end else
+	  Result := tkDivision;
+      end;
+    '0'..'9':
+      begin
+        TokenStart := TokenStr;
+	repeat
+	  Inc(TokenStr);
+	until not (TokenStr[0] in ['0'..'9', '.', 'e', 'E']);
+	SectionLength := TokenStr - TokenStart;
+	SetLength(FCurTokenString, SectionLength);
+	if SectionLength > 0 then
+	  Move(TokenStart^, FCurTokenString[1], SectionLength);
+	Result := tkNumber;
+      end;
+    ':':
+      begin
+        Inc(TokenStr);
+	if TokenStr[0] = '=' then
+	begin
+	  Inc(TokenStr);
+	  Result := tkAssign;
+	end else
+          Result := tkColon;
+      end;
+    ';':
+      begin
+        Inc(TokenStr);
+        Result := tkSemicolon;
+      end;
+    '=':
+      begin
+        Inc(TokenStr);
+        Result := tkEqual;
+      end;
+    '[':
+      begin
+        Inc(TokenStr);
+	Result := tkSquaredBraceOpen;
+      end;
+    ']':
+      begin
+        Inc(TokenStr);
+	Result := tkSquaredBraceClose;
+      end;
+    '^':
+      begin
+        Inc(TokenStr);
+	Result := tkCaret;
+      end;
+    '{':	// Multi-line comment
+      begin
+        Inc(TokenStr);
+	TokenStart := TokenStr;
+	FCurTokenString := '';
+	OldLength := 0;
+	NestingLevel := 0;
+        while (TokenStr[0] <> '}') or (NestingLevel > 0) do
+	begin
+	  if TokenStr[0] = #0 then
+	  begin
+	    SectionLength := TokenStr - TokenStart + 1;
+	    SetLength(FCurTokenString, OldLength + SectionLength);
+	    if SectionLength > 1 then
+	      Move(TokenStart^, FCurTokenString[OldLength + 1],
+	        SectionLength - 1);
+	    Inc(OldLength, SectionLength);
+	    FCurTokenString[OldLength] := #10;
+	    if not FetchLine then
+	    begin
+	      Result := tkEOF;
+	      FCurToken := Result;
+	      exit;
+	    end;
+	    TokenStart := TokenStr;
+	  end else
+	  begin
+	    if TokenStr[0] = '{' then
+	      Inc(NestingLevel)
+	    else if TokenStr[0] = '}' then
+	      Dec(NestingLevel);
+	    Inc(TokenStr);
+	  end;
+	end;
+	SectionLength := TokenStr - TokenStart;
+	SetLength(FCurTokenString, OldLength + SectionLength);
+	if SectionLength > 0 then
+	  Move(TokenStart^, FCurTokenString[OldLength + 1], SectionLength);
+	Inc(TokenStr);
+	Result := tkComment;
+	//WriteLn('Kommentar: "', CurTokenString, '"');
+	if (Length(CurTokenString) > 0) and (CurTokenString[1] = '$') then
+	begin
+	  TokenStart := @CurTokenString[2];
+	  CurPos := TokenStart;
+	  while (CurPos[0] <> ' ') and (CurPos[0] <> #0) do
+	    Inc(CurPos);
+	  SectionLength := CurPos - TokenStart;
+	  SetLength(Directive, SectionLength);
+	  if SectionLength > 0 then
+	  begin
+	    Move(TokenStart^, Directive[1], SectionLength);
+	    Directive := UpperCase(Directive);
+	    if CurPos[0] <> #0 then
+	    begin
+	      TokenStart := CurPos + 1;
+	      CurPos := TokenStart;
+	      while CurPos[0] <> #0 do
+	        Inc(CurPos);
+	      SectionLength := CurPos - TokenStart;
+	      SetLength(Param, SectionLength);
+	      if SectionLength > 0 then
+	        Move(TokenStart^, Param[1], SectionLength);
+	    end else
+	      Param := '';
+  	    // WriteLn('Direktive: "', Directive, '", Param: "', Param, '"');
+	    if (Directive = 'I') or (Directive = 'INCLUDE') then
+	    begin
+	      IncludeStackItem := TIncludeStackItem.Create;
+	      IncludeStackItem.SourceFile := CurSourceFile;
+	      IncludeStackItem.Filename := CurFilename;
+	      IncludeStackItem.Token := CurToken;
+	      IncludeStackItem.TokenString := CurTokenString;
+	      IncludeStackItem.Line := CurLine;
+	      IncludeStackItem.Row := CurRow;
+	      IncludeStackItem.TokenStr := TokenStr;
+	      FIncludeStack.Add(IncludeStackItem);
+	      FCurSourceFile := FileResolver.FindIncludeFile(Param);
+	      if not Assigned(CurSourceFile) then
+	        Error(SErrIncludeFileNotFound, [Param]);
+	      FCurFilename := Param;
+	      FCurRow := 0;
+	    end;
+	  end else
+	    Directive := '';
+	end;
+      end;
+    'A'..'Z', 'a'..'z', '_':
+      begin
+        TokenStart := TokenStr;
+	repeat
+	  Inc(TokenStr);
+	until not (TokenStr[0] in ['A'..'Z', 'a'..'z', '0'..'9', '_']);
+	SectionLength := TokenStr - TokenStart;
+	SetLength(FCurTokenString, SectionLength);
+	if SectionLength > 0 then
+	  Move(TokenStart^, FCurTokenString[1], SectionLength);
+
+	// Check if this is a keyword or identifier
+	// !!!: Optimize this!
+	for i := tkAbsolute to tkXOR do
+	  if CompareText(CurTokenString, TokenInfos[i]) = 0 then
+	  begin
+	    Result := i;
+	    FCurToken := Result;
+	    exit;
+	  end;
+
+	Result := tkIdentifier;
+      end;
+  else
+    Error(SErrInvalidCharacter, [TokenStr[0]]);
+  end;
+
+  FCurToken := Result;
+end;
+
+function TPascalScanner.GetCurColumn: Integer;
+begin
+  Result := TokenStr - PChar(CurLine);
+end;
+
+end.
+
+
+{
+  $Log$
+  Revision 1.1  2003-03-13 21:47:42  sg
+  * First version as part of FCL
+
+}