unit ParserU;
{
}
interface
uses ifps3utl, SysUtils, ParserUtils, BigIni, Classes;

Type
  TProcAttr = set of (PublicProc,IsDone,IsHelper);
  TProcList = class(TStringList)
  public
   ProcAttr : TProcAttr;
   name : string;
   end;
          
  TWriteln = Procedure (const s : string) of object;
  TReadln = Procedure (var s : string;const Promote,Caption : string) of object ;

  TPasToken = record
    ID : TIfPasToken;
    Data : string;
    row, col: integer;
    end;
  TProcDeclOptions = set of (IsMethod,IsPointer);
  TProcDeclInfo = set of (IsVirtual,IsAbstract,IsConstructor,IsDestructor,IsFunction);
  // CompileTime RunTime
  TTimeMode = (CompileTime,RunTime);

  TUnitParser = class
  Private
    fWriteln : TWriteln;
    fReadln : TReadln;
    Procedure SetWriteln(aWriteln : TWriteln);
    Procedure SetReadln(aReadln : TReadln);
  Private
    fParser : TIfPascalParser;
    fToken,fPrevToken : TPasToken;
    fprevOrgToken: string;
    Ini : TBigIniFile;
  Private
    LastTokens : Array of TPasToken;
    FTail,FHead,TokenHistoryCount,TokenHistoryLength : integer;
    Procedure AddToTokenHistory(const aToken : TPasToken);
    function RemoveFromTokenHistory(var aToken : TPasToken) : boolean;
  Private
    Property TokenID : TIfPasToken read fToken.ID;
    Property PrevTokenID : TIfPasToken read fPrevToken.ID;
    Property TokenRow: integer read fToken.Row;
    Property TokenCol : integer read fToken.Col;
   // Property PrevTokenPos : integer read fPrevToken.Pos;
    Property Token : string read fToken.data;
    Property PrevToken : string read fPrevToken.data;

    Procedure SetToken(aTokenID : TIfPasToken;aToken : string;
                       aTokenRow, aTokenCol : integer);
    Procedure NextToken;

    Function  IfMatch(atoken : TIfPasToken) : boolean;
    Procedure Match(atoken : TIfPasToken; err : string = '');
  Private
    fRunTimeProcList : Tstringlist;
    fCompileTimeProcList : Tstringlist;
    fCurrentDTProc : TProcList;
    fCurrentRTProc : TProcList;

    fRunTimeUnitList : Tstringlist;
    fRunTimeUnitListImp : Tstringlist;
    fCompileTimeUnitList : Tstringlist;
    fCompileTimeUnitListImp : Tstringlist;

    RunTimeProcType : set of (ClassImporter,RoutineImporter);
    Procedure AddRequiredUnit(Const UnitName : string;
                              TimeMode : TTimeMode;
                              InterfaceSection : boolean);
    function RegisterProc(const ProcName : string;
                          TimeMode : TTimeMode;
                          Attr : TProcAttr) : TProcList;
  //  Procedure AddVarToProc(const ProcName : string;CompileTime : TCompileTime;
  //                         const VarString : string);
    Procedure FinishProcs;
  Private
    Procedure StartParse;
    Procedure FinishParse;

    Procedure ParseUnitHeader;
    Procedure ParseGlobalDeclarations;

    function ParseConstantExpression(var ExpType : string) : string;
    Function GetConstantType : string;
    function GetAsString(const ConstType,ConstValue : string) : string;
    Procedure ParseConstants;
    Procedure ParseVariables;

    Procedure ParseRoutines;
    Procedure ParseTypes;
    // parses a type delcaration
    Procedure ParseType(aTokenID : TIfPasToken; const TypeName : string;
                        var TypeDescriptor : string; var CheckSemiColon : boolean);
    // helper method which parses a interface definition
    Procedure ParseInterfaceDef(const aInterfaceName : string);
    // helper method which parses a class definition
    Procedure ParseClassDef(const aClassName : string);
    // helper method which parses a routine decl (after the procedure name)
    Function ParseProcDecl(var ProcName,decl,CallingConvention : string;
                            Options : TProcDeclOptions) : TProcDeclInfo;
  Public
    Constructor Create(const IniFilename : string;aTokenHistoryLength : Integer = 5);
    Destructor Destroy; override;
  Public
    // output
    Unitname, OutputRT,OutputDT : string;
    // Controls went registering classes, at design time
    // the actual class type is used
    WriteDefines, UseUnitAtDT : boolean;
    // Class this to parse a unit
    Procedure ParseUnit(const Input : string);
    procedure ParserError(Parser: TObject; Kind: TIFParserErrorKind);

    Property Writeln : TWriteln read fWriteln write SetWriteln;
    Property Readln : TReadln read fReadln write setReadln;
  end; {TUnitParser}

const
  MaxSearchCount  = 100;
    
implementation

Procedure DefReadln(var s : string;const Promote,Caption : string);
begin
s := '';
end; {DefReadln}

Procedure DefWriteln(const s : string);
begin
end; {DefWriteln}

Constructor TUnitParser.Create(const IniFilename : string;aTokenHistoryLength : Integer = 5);
begin
  inherited create;
  Writeln := nil;
  Readln := nil;
  Ini := TBigIniFile.Create(IniFilename);
  Ini.FlagDropApostrophes := True;
  ini.FlagDropCommentLines := True;
  Ini.FlagTrimRight := True;
  Ini.FlagFilterOutInvalid := True;

  fParser := TIfPascalParser.create;
  TokenHistoryLength := aTokenHistoryLength;
  if TokenHistoryLength > 0 then
    Setlength(LastTokens,TokenHistoryLength);
end; {Create}

Destructor TUnitParser.Destroy;
begin
  fParser.free;
  ini.free;
  Inherited;
end; {Destroy}

Procedure TUnitParser.SetWriteln(aWriteln : TWriteln);
begin
if assigned(aWriteln) then
  fWriteln := aWriteln
//else
//  fWriteln := DefWriteln;
end; {SetWriteln}

Procedure TUnitParser.SetReadln(aReadln : TReadln);
begin
if assigned(aReadln) then
  fReadln := aReadln
//else
//  fReadln := DefReadln;
end; {SetWriteln}

Procedure TUnitParser.AddToTokenHistory(const aToken : TPasToken);
begin
if TokenHistoryLength <= 0 then exit;
LastTokens[FTail] := aToken;
FTail := (FTail + 1) mod TokenHistoryLength;
if FTail = FHead then
  FHead := (FHead + 1) mod TokenHistoryLength
else
  inc(TokenHistoryCount);
end; {AddToTokenHistory}

function TUnitParser.RemoveFromTokenHistory(var aToken : TPasToken) : boolean;
begin
Result := (TokenHistoryLength > 0) and (TokenHistoryCount <> 0);
if result then
  begin
  aToken := LastTokens[FHead];
  FHead := (FHead + 1) mod TokenHistoryLength;
  dec(TokenHistoryCount);
  end;
end; {RemoveFromTokenHistory}

Procedure TUnitParser.SetToken(aTokenID : TIfPasToken;
                               aToken : string;
                               aTokenRow, aTokenCol : integer);
begin
fToken.ID := aTokenID;
fToken.data := aToken;
fToken.row := aTokenRow;
fToken.col := aTokenCol;
AddToTokenHistory(fToken);
end; {InsertToken}

Procedure TUnitParser.NextToken;
begin
fPrevToken := fToken;
fprevOrgToken := fparser.OriginalToken;
fParser.next;
fToken.ID := fParser.CurrTokenID;
fToken.data := fParser.GetToken;
fToken.row := fParser.Row;
fToken.col := fParser.Col;
AddToTokenHistory(fToken);
end; {NextToken}

// -----------------------------------------------------------------------------

Function TUnitParser.Ifmatch(atoken : TIfPasToken) : boolean;
begin
Result := TokenID = atoken;
if result then
  NextToken;
end; {Ifmatch}

Procedure TUnitParser.Match(atoken : TIfPasToken; err : string = '');
var
  Errormsg : string;
  TokenList : string;
  OldToken : TPasToken;
begin
if not Ifmatch(atoken) then
  begin
  if err = '' then
    err := GetTokenName(atoken);
  Errormsg := 'Expecting Token ''' +err +''' but ';
  case TokenID of
  CSTI_Identifier : Errormsg := Errormsg +'Identifier '''+Token;
  CSTI_Integer : Errormsg := Errormsg +'Integer number '''+Token;
  CSTI_Real : Errormsg := Errormsg +'Floatpoint number '''+Token;
  CSTI_String : Errormsg := Errormsg +'String '''+Token;
  CSTI_Char : Errormsg := Errormsg +'Character '''+Token;
  CSTI_HexInt : Errormsg := Errormsg +'Hexadecimal number '''+Token;
  else  Errormsg := Errormsg +'token '''+GetTokenName(TokenID);
  end;
  // biuld the list of tokens
  TokenList := '';
  while RemoveFromTokenHistory(OldToken) do
    begin
    if OldToken.ID in [CSTI_Identifier, CSTI_Integer,CSTI_Real,
                   CSTI_String, CSTI_Char, CSTI_HexInt] then
      TokenList := TokenList +OldToken.Data+' '
    else
      TokenList := TokenList +GetTokenName(OldToken.ID)+' ';
    end;
  RaiseError(Errormsg+''' found'+NewLine+'Previous tokens : '''+TokenList+'''',TokenRow, TokenCol);
  end;
end; {Match}

// -----------------------------------------------------------------------------

Procedure TUnitParser.ParseUnit(const Input : string);
begin
Unitname := '';
fparser.OnParserError := ParserError;
fParser.SetText(Input);
  try
    StartParse;
    ParseUnitHeader;
    ParseGlobalDeclarations;
  finally
    FinishParse;
  end;
end; {ParseUnit}

Procedure TUnitParser.AddRequiredUnit(Const UnitName : string;
                                      TimeMode : TTimeMode;
                                      InterfaceSection : boolean);
var
  Unitlist : Tstringlist;
  index : integer;
begin
// choice the correct list to add it to
Unitlist := nil;
Case TimeMode of
 CompileTime:
   if InterfaceSection then
     Unitlist := fCompileTimeUnitList
   else
     Unitlist := fCompileTimeUnitListImp;
 RunTime:
    if InterfaceSection then
     Unitlist := fRunTimeUnitList
   else
     Unitlist := fRunTimeUnitListImp;
else
  RaiseError('Unable to deterimine which used unit list'+
             ' to add the unit '''+UnitName+''' to',TokenRow, TokenCol);
end;
index := Unitlist.Indexof(UnitName);
if index = -1 then
  Unitlist.add(UnitName)
end; {AddRequiredUnit}

function TUnitParser.RegisterProc(const ProcName : string;
                                  TimeMode : TTimeMode;
                                  Attr : TProcAttr ): TProcList;
var
  proclist : Tstringlist;
  index : integer;
begin
if ProcName = '' then
  RaiseError('Invalid procedure name',TokenRow, TokenCol);
if TimeMode = CompileTime then
  proclist := fCompileTimeproclist
else
  proclist := fRunTimeProclist;
assert(proclist <> nil);
index := proclist.IndexOf(ProcName);
if index = -1 then
  begin
  Result := TProcList.create;
  try
    Result.Add(ProcName);
    if not (IsHelper in Attr) then
      Result.Add('begin');
    Result.ProcAttr := Attr;
    proclist.AddObject(ProcName,Result);
  except
    Result.free;
    raise
  end;
  end
else
  Result := proclist.Objects[index] as TProcList;
end; {RegisterProc}

Procedure TUnitParser.FinishProcs;
var
  index : integer;
  obj : Tobject;
begin
if fRunTimeProcList <> nil then
for index := fRunTimeProcList.count -1 downto 0 do
  begin
  obj := fRunTimeProcList.Objects[index];
  if (obj is TProcList) and
     not(IsHelper in TProcList(obj).ProcAttr) then
    TProcList(obj).add('end;');
  end;
if fCompileTimeProcList <> nil then
for index := fCompileTimeProcList.count -1 downto 0 do
  begin
  obj := fCompileTimeProcList.Objects[index];
  if (obj is TProcList) and
     not(IsHelper in TProcList(obj).ProcAttr) then
    TProcList(obj).add('end;');
  end;
end; {FinishProcs}

(*
Procedure TUnitParser.AddVarToProc(const ProcName : string;
                                   CompileTime : TCompileTime;
                                   const VarString : string);
var
  proc : Tstringlist;
begin
proc := RegisterProc(ProcName,CompileTime,false);
If Proc = nil then
  RaiseError('Procedure :"'+ProcName+'" can not be found');
If fastUppercase(Proc[1]) = 'VAR' then
  Proc.Insert(2,VarString)
else
  Proc.Insert(1,'var'+newline+VarString)
end; {AddVarToProc}
*)

Procedure TUnitParser.StartParse;
begin
SetToken(fParser.CurrTokenID,fParser.GetToken,fParser.Row, FParser.Col);
OutputDT := '';
OutputRT := '';

fRunTimeProcList := TStringlist.create;
fCompileTimeProcList := TStringlist.create;

fRunTimeUnitList := Tstringlist.create;
fRunTimeUnitListImp := Tstringlist.create;
fCompileTimeUnitList := Tstringlist.create;
fCompileTimeUnitListImp := Tstringlist.create;
end; {StartParse}

Procedure TUnitParser.FinishParse;
var
  output : Tstringlist;
  obj : Tobject;
  index : integer;
  s : string;
begin
try
FinishProcs;
// write out the design time unit
if fCompileTimeProcList <> nil then
  begin
  output := Tstringlist.create;
  try
    // insert the front of the text body
    output.add('Unit ifpii_'+UnitName+';');
    output.add(GetLicence);
    output.add('{$I ifps3_def.inc}');
    output.add('Interface');
    output.add(GetUsedUnitList(fCompileTimeUnitList)+Newline);
    for index := fCompileTimeProcList.count -1 downto 0 do
      begin
      obj := fCompileTimeProcList.objects[index];
      if (obj is TProcList) and
         (PublicProc in TProcList(obj).ProcAttr) then
        output.add(fCompileTimeProcList[index]);
      end;
    output.add('');
    output.add('implementation');
    // insert the Designtime unit importer into the used unit list
    s := GetUsedUnitList(fCompileTimeUnitListImp);
    if s <> '' then
      begin
      Delete(s,length(s),1);
      output.add(s);
      if WriteDefines then
      begin
        output.add('{$IFDEF USEIMPORTER}');
        output.add('  ,CIImporterU');
        output.add('{$ENDIF};');
      end;
      output.add(';');
      end
    else
      begin
      if WriteDefines then
      begin
        output.add('{$IFDEF USEIMPORTER}');
        output.add('  uses CIImporterU;');
        output.add('{$ENDIF}');
      end;
      end;
    // reinsert the main text body
    for index := fCompileTimeProcList.count -1 downto 0 do
      begin
      obj := fCompileTimeProcList.objects[index];
      if (obj is TProcList) and
         (IsHelper in TProcList(obj).ProcAttr) then
        output.add(Tstringlist(obj).text);
      end;
    for index := fCompileTimeProcList.count -1 downto 0 do
      begin
      obj := fCompileTimeProcList.objects[index];
      if (obj is TProcList) and
         (PublicProc in TProcList(obj).ProcAttr) then
        output.add(Tstringlist(obj).text);
      end;
    // insert the Runtime unit importer code into the end of the unit
    if WriteDefines then
    begin
      output.add('{$IFDEF USEIMPORTER}');
      output.add('initialization');
      output.add('CIImporter.AddCallBack(@SIRegister_'+unitname+
               ',PT_ClassImport);');
      output.add('{$ENDIF}');
    end;
    output.add('end.');
  finally
    if output <> nil then
      OutputDT := output.text;
    output.free;
  end;
  end;
// write out the run time import unit
if fRunTimeProcList <> nil then
  begin
  output := Tstringlist.create;
  try
    output.add('Unit ifpiir_'+UnitName+';');
    output.add(GetLicence);
    output.add('{$I ifps3_def.inc}');
    output.add('Interface');
    output.add(GetUsedUnitList(fRunTimeUnitList)+Newline);
    for index := fRunTimeProcList.count -1 downto 0 do
      begin
      obj := fRunTimeProcList.objects[index];
      if (obj is TProcList) and
         (PublicProc in TProcList(obj).ProcAttr) then
        output.add(fRunTimeProcList[index]);
      end;
    output.add('');
    output.add('implementation');
    // insert the Runtime unit importer into the used unit list
    s := GetUsedUnitList(fRunTimeUnitListImp);
    if RunTimeProcType <> [] then
      begin
      if s <> '' then
        begin
        Delete(s,length(s),1);
        output.add(s);
        if WriteDefines then
        begin
          output.add('{$IFDEF USEIMPORTER}');
          output.add('  ,RIImporterU');
          output.add('{$ENDIF};');
        end;
        output.add(';');
        end
      else
        begin
        if WriteDefines then
        begin
          output.add('{$IFDEF USEIMPORTER}');
          output.add('  uses RIImporterU;');
          output.add('{$ENDIF}');
        end;
        end;
      end
    else output.add(s);
    // reinsert the main text body
    for index := fRunTimeProcList.count -1 downto 0 do
      begin
      obj := fRunTimeProcList.objects[index];
      if (obj is TProcList) and
         (IsHelper in TProcList(obj).ProcAttr) then
        output.add(TProcList(obj).text);
      end;
    // reinsert the main text body
    for index := fRunTimeProcList.count -1 downto 0 do
      begin
      obj := fRunTimeProcList.objects[index];
      if (obj is TProcList) and
         (PublicProc in TProcList(obj).ProcAttr) then
        output.add(TProcList(obj).text);
      end;
    // add the ending of the unit
    // insert the Runtime unit importer code into the end of the unit
    if RunTimeProcType <> [] then
      begin
        if WriteDefines then
        begin
          output.add('{$IFDEF USEIMPORTER}');
          output.add('initialization');
          if RoutineImporter in RunTimeProcType then
            output.add('RIImporter.AddCallBack(RIRegister_'+unitname+'_Routines);');
          if ClassImporter in RunTimeProcType then
          output.add('RIImporter.Invoke(RIRegister_'+unitname+');');
          output.add('{$ENDIF}');
        end;
      end;
    output.add('end.');
  finally
    if output <> nil then
      OutputRT := output.text;
    output.free;
  end;
  end;
finally
  for index := fRunTimeProcList.Count -1 downto 0 do
  begin
    fRunTimeProcList.Objects[index].Free;
  end;
  FreeAndNil(fRunTimeProcList);
  for index := fCompileTimeProcList.Count -1 downto 0 do
  begin
    fCompileTimeProcList.Objects[index].Free;
  end;
  FreeAndNil(fCompileTimeProcList);
  FreeAndNil(fRunTimeUnitList);
  FreeAndNil(fRunTimeUnitListImp);
  FreeAndNil(fCompileTimeUnitList);
  FreeAndNil(fCompileTimeUnitListImp);
end;
end; {FinishParse}

Procedure TUnitParser.ParseUnitHeader;
begin
// parser 'Unit <identifier>;'
Match(CSTII_Unit);
Match(CSTI_Identifier);
Unitname := fprevOrgToken;
Match(CSTI_SemiColon);
Match(CSTII_Interface);
// parser the units clause 'uses <identifier>[, <identifier>];'
If IfMatch(CSTII_uses) then
  begin
  repeat
    Match(CSTI_Identifier);
    AddRequiredUnit(PrevToken,RunTime,false);
//    AddRequiredUnit(PrevToken,CompileTime,false);
    if TokenID = CSTI_SemiColon then
      begin
      Match(CSTI_SemiColon);
      break;
      end
    else
      Match(CSTI_Comma,','' or '';');
  until false;
  end;
AddRequiredUnit(UnitName,RunTime,false);
fCurrentDTProc := RegisterProc('procedure SIRegister_'+unitname+
                              '(Cl: TIFPSPascalCompiler);',CompileTime,[PublicProc]);
AddRequiredUnit('ifpscomp',CompileTime,True);
RunTimeProcType := [];
fCurrentRTProc := nil;
end; {ParseUnitHeader}

procedure TUnitParser.ParseGlobalDeclarations;
begin
while not IfMatch(CSTII_Implementation) do
  case TokenID of
    CSTII_var : ParseVariables;
    CSTII_const : ParseConstants;
    CSTII_type : ParseTypes;
    CSTII_procedure,
    CSTII_function : ParseRoutines;
    CSTI_Identifier :
      RaiseError('Declaration expected but identifier '''+Token+''' found',TokenRow, TokenCol);
  else RaiseError('Unknown keyword '''+GetTokenName(TokenID)+'''',TokenRow, TokenCol);
  end;
end; {ParseGlobalDeclarations}

Function TUnitParser.GetConstantType : string;
var
  value : int64;
begin
Result := '';
// determine the constant type
case TokenID of
  CSTI_Integer :
    begin
    value := StrToInt64(Token);
    if (value < low(Longint)) then
      Result := 'INT64'
    else if value > High(Longint) then
      begin
      if value > High(longword) then
        Result := 'INT64'
      else
        Result := 'LONGWORD'
      end
    else
      Result := 'LONGINT';
    end;
  CSTI_HexInt  : Result := 'LONGWORD';
  CSTI_Real    : Result := 'EXTENDED';
  CSTI_String : Result := 'STRING';
  CSTI_Char : Result := 'CHAR';
  CSTI_Identifier :
    begin // unknown identifier
    If (Token = 'FALSE') or
       (Token = 'TRUE')  then
       Result := 'BOOLEAN';
    end;
  else RaiseError('Expected valid type, but found '''+GetTokenName(TokenID)+'''',TokenRow, TokenCol);
end; {case}
end; {GetConstantType}

function TUnitParser.ParseConstantExpression(var ExpType : string) : string;
var
  BracketCount : integer;
begin
result := '';
BracketCount := 0;
repeat
  // generate the actual string
  Case TokenID of
    CSTI_Integer, CSTI_HexInt, CSTI_Real,
    CSTI_String, CSTI_Char, CSTI_Identifier :
      begin
      ExpType := GetConstantType;
      // convert sveral consecutive characters into a string
      if (PrevTokenID = CSTI_Char) and
         (TokenID = CSTI_Char) then
         begin
         Result := Result+Token;
         ExpType := 'STRING';
         end
      else
        Result := Result+' '+Token;

      end;
    CSTI_Equal : Result := Result + ' =';
    CSTI_NotEqual : Result := Result + ' <>';
    CSTI_Greater : Result := Result + ' >';
    CSTI_GreaterEqual : Result := Result + ' >=';
    CSTI_Less : Result := Result + ' <';
    CSTI_LessEqual : Result := Result + ' <=';
    CSTI_Plus : Result := Result + ' +';
    CSTI_Minus : Result := Result + ' -';
    CSTI_Divide : begin Result := Result + ' /'; ExpType := 'EXTENDED'; end;
    CSTII_div : Result := Result + ' div';
    CSTI_Multiply : Result := Result + ' *';
    CSTI_AddressOf : Result := Result + ' @';
    CSTI_Dereference : Result := Result + ' ^';
    CSTII_and : Result := Result + ' and';
    CSTII_mod : Result := Result + ' mod';
    CSTII_not : Result := Result + ' not';
    CSTII_or : Result := Result + ' or';
    CSTII_shl : Result := Result + ' shl';
    CSTII_shr : Result := Result + ' shr';
    CSTII_xor : Result := Result + ' xor';
    CSTII_Chr : Result := Result + ' char('+ParseConstantExpression(ExpType)+')';
    CSTII_Ord : Result := Result + ' ord('+ParseConstantExpression(ExpType)+')';
    CSTI_OpenRound : begin Result := Result + ' (';inc(BracketCount); end;
    CSTI_CloseRound  :
      begin // prevent adding brakets when there should not be
      if BracketCount <> 0 then
        begin
        Result := Result + ' )';
        dec(BracketCount)
        end
      else break;
      end;
  end;
  NextToken;
until not (TokenID in [CSTI_Integer,CSTI_HexInt,CSTI_Real, CSTI_String,CSTI_Char,
                      CSTI_Equal,CSTI_NotEqual,CSTI_Greater,CSTI_GreaterEqual,
                      CSTI_Less,CSTI_LessEqual,CSTI_Plus,CSTI_Minus,CSTI_Divide,
                      CSTII_div,CSTI_Multiply,CSTI_AddressOf,CSTI_Dereference,
                      CSTII_and,CSTII_mod,CSTII_not,CSTII_or,CSTII_shl, CSTII_shr,
                      CSTII_xor,CSTII_Chr,CSTII_Ord,CSTI_OpenRound,CSTI_CloseRound]);
end; {ParseConstantExpression}

function TUnitParser.GetAsString(const ConstType,ConstValue : string) : string;
begin
If ConstType = 'BOOLEAN' then
  begin
  With RegisterProc('Function BoolToStr(value : boolean) : string;',CompileTime,[IsHelper]) do
    begin
    if IsDone in ProcAttr then exit;
    include(ProcAttr,IsDone);
    Add('Begin If value then Result := ''TRUE'' else Result := ''FALSE'' End;');
    end;
  Result := 'BoolToStr('+ConstValue+')';
  end
//else If ConstType = 'STRING' then
//  Result := ConstValue
//else If ConstType = 'CHAR' then
//  Result := ''
else
  begin
  AddRequiredUnit('Sysutils',CompileTime,false);
  If (ConstType = 'BOOLEAN') then
     Result := '.SetInt(Ord(' + Constvalue + '))'
  else if (ConstType = 'LONGINT') or (ConstType = 'INTEGER') then
     Result := '.SetInt('+ConstValue+')'
  else if (ConstType = 'INT64') then
     Result := '.SetInt64('+ConstValue+')'
  else If (ConstType = 'LONGWORD') or (ConstType = 'BYTE') or (ConstType = 'WORD') then
     Result := '.SetUInt('+ConstValue+')'
  else If (ConstType = 'EXTENDED') or (ConstType = 'DOUBLE') or (ConstType = 'SINGLE') then
     Result := '.setExtended('+ConstValue+')'
  else
    Result := '.SetString('+ConstValue+')';
  end;
end; {GetAsString}

Procedure TUnitParser.ParseConstants;
var
  ConstName,ConstType,ConstValue,Expression : string;
  l: Longint;
begin
Match(CSTII_const);
Repeat
  try
    Match(CSTI_Identifier);
    ConstName := PrevToken;
    If IfMatch(CSTI_Colon) then
      begin
      ConstType := Token;
      NextToken;
      Match(CSTI_Equal);
      Expression := ParseConstantExpression(Expression);
      end
    else
      begin
      Match(CSTI_Equal,':'' or ''=');
      Expression := ParseConstantExpression(ConstType);
      end;
    Match(CSTI_SemiColon);
    if UseUnitAtDT then
      ConstValue := ConstName
    else
      ConstValue := Expression;
    if ConstType = '' then
      ReadLn(ConstType,'Expression ('+Expression+') :','Unable to determine expression type');
    // now output the value
      fCurrentDTProc.Add('  String(Cl.AddConstantN('''+ConstName+''','+ ''''+ConstType+''')'+GetAsString(ConstType, ConstValue)+';');
  except
   // Hack: We cannot succesfully parse this, but that doesn't mean we should stop.
   on e: Exception do
   begin
     Writeln('Warning, could not parse const: '+e.Message);
     l := 0;
      while TokenId <>CSTI_Eof do
      begin
        NextToken;
        if TokenId = CSTI_OpenBlock then
          inc(l)
        else if TokenId = CSTI_CloseBlock then
          Dec(l)
        else if TokenId = CSTI_OpenRound then
          inc(l)
        else if TokenId = CSTI_CloseRound then
          Dec(l)
        else if (TokenId = CSTI_SemiColon) and (l <= 0) then
          break;
      end;
      Match(CSTI_Semicolon);
   end;
  end;
until (TokenID <> CSTI_Identifier);
end; {ParseConstants}

Procedure TUnitParser.ParseVariables;
begin
{todo 3-cWishList : generate wrapper code to allow a script to access a variable}
Match(CSTII_var);
repeat
  Match(CSTI_Identifier);
  Match(CSTI_Colon);
  NextToken;
  If IfMatch(CSTI_Equal) then
    NextToken;
  Match(CSTI_SemiColon);
until (TokenID <> CSTI_Identifier);
end; {ParseVariables}

function TUnitParser.ParseProcDecl(var ProcName,decl,CallingConvention : string;
                                   Options : TProcDeclOptions) : TProcDeclInfo;
var
  VarListFirst : boolean;
  FinishedProcDecl : boolean;
  ParamNames : TStringlist;
  Olddecl,OldProcName,ParamStr : string;
  index : integer;
  CheckSemiColon : boolean;
  Proc : TProcList;
begin
Result := [];
if IfMatch(CSTII_function) then
  begin
  Include(Result,IsFunction);
  decl := 'Function ';
  end
else if IfMatch(CSTII_Procedure) then
  decl := 'Procedure '
else if IfMatch(CSTII_Constructor) then
  begin
  if not (IsMethod in Options) then
    RaiseError('Constructor directive only applies to methods',TokenRow, TokenCol);
  Include(Result,IsConstructor);
  decl := 'Constructor '
  end
else if IfMatch(CSTII_Destructor) then
  begin
  if not (IsMethod in Options) then
    RaiseError('Destructor directive only applies to methods',TokenRow, TokenCol);
  Include(Result,IsDestructor);
  decl := 'Destructor '
  end
else
  Match(CSTII_Procedure,'Function'' Or ''Procedure');

if not (Ispointer in Options) then
  begin
  Match(CSTI_Identifier);
  ProcName := PrevToken;
  decl := decl + PrevToken;
  end
else
  ProcName := '';
ParamNames := TStringlist.create;
try
if IfMatch(CSTI_OpenRound) then
  begin
  decl := decl + '( ';
  while not IfMatch(CSTI_CloseRound) do
    begin
    If IfMatch(CSTII_var) then
      decl := decl + 'var '
    else if Ifmatch(CSTII_const) then
      decl := decl + 'const ';
    // get the list of variable names
    VarListFirst := true;
    Repeat
      Match(CSTI_Identifier);
      if VarListFirst then
        begin
        VarListFirst := false;
        decl := decl + PrevToken;
        end
      else
        decl := decl +', '+ PrevToken;
      ParamNames.add(PrevToken);
      if TokenID = CSTI_Colon then
        Break;
      IfMatch(CSTI_Comma);
    until false;
    Match(CSTI_Colon);
    // get the type
    decl := decl + ' : ';
    CheckSemiColon := true;
    ParseType(TokenID,ProcName,decl,CheckSemiColon);
    if TokenID = CSTI_Equal then
      begin // stip the default part of the varaible declaration
      NextToken;
      ParseConstantExpression(ParamStr);
      end;
    if CheckSemiColon and Ifmatch(CSTI_SemiColon) and
       (TokenID <> CSTI_CloseRound) then
      decl := decl + '; '
    end;
  decl := decl + ')';
  end;
// parse the ' : <typename>' part of a function
if IsFunction in Result then
  begin
  Match(CSTI_Colon);
  Match(CSTI_Identifier);
  decl := decl + ' : '+PrevToken;
  end;
// parse Calling Conventions & other misc bits that are taked to
// the end of a routine declaration
CallingConvention := 'cdRegister';
FinishedProcDecl := false;
// check if we are a method pointer
if IsPointer in Options then
  begin
  If Ifmatch(CSTII_of) then
    begin
    If (TokenID <> CSTI_Identifier) or
       (Token <> 'OBJECT') then
      RaiseError('Expecting Token ''Object'' but found '''+GetTokenName(TokenID)+'''',TokenRow, TokenCol)
    else NextToken;
    end
  else
    {todo 1 -cWishList : normal function pointers are not supported by the script, only method pointers}
    Decl := '';
  end;
Match(CSTI_Semicolon);
repeat
  case TokenID of
  CSTII_External :
    begin
    if (IsPointer in Options) or
       (IsMethod in Options) then
      RaiseError('External directive only applies to routines ('+ProcName+')',TokenRow, TokenCol);
    NextToken;
    Match(CSTI_Semicolon);
    end;
  CSTII_Export :
    begin
    if (IsPointer in Options) or
       (IsMethod in Options) then
      RaiseError('Export directive only applies to routines ('+ProcName+')',TokenRow, TokenCol);
    NextToken;
    Match(CSTI_Semicolon);
    end;
  CSTII_Forward :
    begin
    if (IsPointer in Options) or
       (IsMethod in Options) then
      RaiseError('Forward directive only applies to routines ('+ProcName+')',TokenRow, TokenCol);
    NextToken;
    Match(CSTI_Semicolon);
    end;
  CSTII_Override :
    begin
    if not (IsMethod in Options) then
      RaiseError('Override directive only applies to methods ('+ProcName+')',TokenRow, TokenCol);
    decl := '';
    NextToken;
    Match(CSTI_Semicolon);
    end;
  CSTII_Virtual :
    begin
    if not (IsMethod in Options) then
      RaiseError('Virtual directive only applies to methods ('+ProcName+')',TokenRow, TokenCol);
    NextToken;
    Match(CSTI_Semicolon);
    include(Result,IsVirtual);
    if Token = 'ABSTRACT' then
      begin
      NextToken;
      Match(CSTI_Semicolon);
      include(Result,IsAbstract);
      end;
    end;
  CSTI_Identifier :
    begin
    // check for calling conversion
    if Token = 'MESSAGE' then
    begin
      if not (IsMethod in Options) then
        RaiseError('Override directive only applies to methods ('+ProcName+')',TokenRow, TokenCol);
      NextToken;
      Match(CSTI_Identifier);
      Match(CSTI_Semicolon); 
    end else
    if Token = 'DYNAMIC' then
    begin
      if not (IsMethod in Options) then
        RaiseError('Method directive only applies to methods ('+ProcName+')',TokenRow, TokenCol);
      NextToken;
      Match(CSTI_Semicolon);
      include(Result,IsVirtual);
      if Token = 'ABSTRACT' then
        begin
        NextToken;
        Match(CSTI_Semicolon);
        include(Result,IsAbstract);
        end;
    end else if Token = 'PASCAL' then
    begin
      CallingConvention := 'cdPascal';
      NextToken;;
      Match(CSTI_Semicolon);
    end else if Token = 'REGISTER' then
    begin
      CallingConvention := 'cdRegister';
      NextToken;
      Match(CSTI_Semicolon);
    end else if Token = 'CDECL' then
    begin
      CallingConvention := 'CdCdecl';
      NextToken;
      Match(CSTI_Semicolon);
    end else if (Token = 'STDCALL') or
            (Token = 'SAFECALL') then
    begin
      // map a safecall to stdcall
      // (safecall cause special wrapper code to be implemented client side)
      CallingConvention := 'CdStdCall';
      NextToken;
      Match(CSTI_Semicolon);

    end else if not (Ispointer in Options) then
      begin
      if (token = 'OVERLOAD') then
        begin
        if (IsPointer in Options) or
           (IsMethod in Options) then
          RaiseError('overload directive does not applies to function/method pointers',TokenRow, TokenCol);
        Writeln('Overloading isnt supported. Remapping of name required');
        OldProcName := ProcName;
        Olddecl := decl;
        repeat
          Readln(ProcName,'Enter new name:','Current declaration :'+NewLine+''''+decl+'''');
          if ProcName = '' then
            ProcName := OldProcName
          else
            ProcName := fastUppercase(ProcName);
          // create a tmp procedure to handle the overload
          decl := StringReplace(decl,OldProcName,ProcName,[rfIgnoreCase])+';';
          Proc := RegisterProc(decl,RunTime,[IsHelper]);
          if not (IsDone in Proc.ProcAttr) then
            begin
            Writeln('Procedure name has been used, entre a new one');
            ProcName := OldProcName;
            decl := Olddecl;
            end
          else break;
        until true;
        Include(Proc.ProcAttr,IsDone);
        Writeln('New Name :'''+ProcName+'''');
        With Proc do
          begin
          if ParamNames.count <> 0 then
            begin
            ParamStr := ParamNames[0];
            For index := 1 to ParamNames.count -1 do
              ParamStr := ParamStr + ', ' + ParamNames[index];
            Add(unitname+'.'+OldProcName+'('+ParamStr+');');
            end
          else
            Add(unitname+'.'+OldProcName+';');
          end;
        end;
        NextToken;
            Match(CSTI_Semicolon);
      end
    else
      exit;
    // get the next token
    end;
  else FinishedProcDecl := true;
  end;
until FinishedProcDecl;
finally
  ParamNames.free;
end;
end; {ParseProcDecl}

Procedure TUnitParser.ParseRoutines;
var
  decl,ProcName,CallingConvention : string;
begin
AddRequiredUnit('ifpiDelphi',CompileTime,false);
AddRequiredUnit('ifpiDelphiRuntime',RunTime,false);
AddRequiredUnit('ifps3',RunTime,true);
include(RunTimeProcType,RoutineImporter);
fCurrentRTProc := RegisterProc('procedure RIRegister_'+unitname+
                               '_Routines(S: TIFPSExec);',RunTime,[PublicProc]);
// biuld the function declaration
ParseProcDecl(ProcName,Decl,CallingConvention,[]);
if decl <> '' then
  begin
  fCurrentDTProc.Add('  RegisterDelphiFunctionC(Cl.Se,'''+decl+''');');
  fCurrentRTProc.Add('  RegisterDelphiFunctionR(S, @'+ProcName+', '''+
                     ProcName+''', '+CallingConvention+');');
  end;
end; {ParseRoutines}

Procedure TUnitParser.ParseInterfaceDef(const aInterfaceName : string);
begin
  Writeln('Interface Declaration not suported at position: '+Inttostr(TokenRow)+':'+ Inttostr(TokenCol));
  while not (TokenId in [CSTI_EOF, CSTII_End]) do
   NextToken;
  NextToken; // skip the END
//todo 4 -cRequired : Allow parsing of interfaces
end; {ParseInterfaceDef}

Procedure TUnitParser.ParseClassDef(const aClassName : string);
var
  CurrPos : (cp_private, cp_Protected, cp_public, cp_published);
  aClassParent : string;

  Procedure ProcessProc;
  var
    decl, ProcName,s : string;
    ProcDeclInfo : TProcDeclInfo;
  begin
  ProcDeclInfo := ParseProcDecl(ProcName,decl,s,[IsMethod]);
  if (decl = '') or
     (CurrPos in [cp_private, cp_Protected]) or
     (IsDestructor in ProcDeclInfo) then
    Exit;
  fCurrentDTProc.Add('    RegisterMethod('''+decl+''');');
  if IsVirtual in ProcDeclInfo then
    begin
    if IsConstructor in ProcDeclInfo then
      fCurrentRTProc.Add('    RegisterVirtualConstructor(@'+
                         aClassname+'.'+ProcName+ ', '''+ProcName+''');')
    else
      begin
      if IsAbstract in ProcDeclInfo then
        fCurrentRTProc.Add('    RegisterVirtualAbstractMethod(@'+aClassname+
                           ', @!.'+ProcName+ ', '''+ProcName+''');')
      else
        fCurrentRTProc.Add('    RegisterVirtualMethod(@'+aClassname+'.'+ProcName+
                           ', '''+ProcName+''');')
      end;
    end
  else
    begin
    if IsConstructor in ProcDeclInfo then
      fCurrentRTProc.Add('    RegisterConstructor(@'+aClassname+'.'+ProcName+
                         ', '''+ProcName+''');')
    else
      fCurrentRTProc.Add('    RegisterMethod(@'+aClassname+'.'+ProcName+
                         ', '''+ProcName+''');')
    end;
  end; {ProcessProc}

  Procedure ProcessVar;
  var
    VarType: string;

  procedure CreateFieldReadFunc(const VarName : string);
  begin
  with RegisterProc('procedure '+aClassname+VarName+'_R(Self: '+aClassname+
                    '; var T: '+VarType+ ');',RunTime,[Ishelper]) do
    begin
    if IsDone in ProcAttr then RaiseError('Duplicate reader for field :'+aClassname+VarName,TokenRow, TokenCol);
    include(ProcAttr,IsDone);
    Add('Begin T := Self.'+VarName+ '; end;');
    end;
  end; {CreateFieldReadFunc}

  procedure CreateFieldWriteFunc(const VarName : string);
  begin
  with RegisterProc('procedure '+aClassname+VarName+'_W(Self: '+aClassname+
                    '; const T: '+VarType+');',RunTime,[Ishelper]) do
    begin
    if IsDone in ProcAttr then RaiseError('Duplicate writer for field :'+aClassname+VarName,TokenRow, TokenCol);
    include(ProcAttr,IsDone);
    Add('Begin Self.'+VarName+ ' := T; end;');
    end;
  end; {CreateFieldWriteFunc}
  var
    VarNames: TStringList;
    index : integer;
    CheckSemiColon : boolean;
  begin {ProcessVar}
  VarNames := TStringList.Create;
  try
    VarNames.Add(Token);
    NextToken;
    while TokenId = CSTI_Comma do
      begin
      NextToken;
      Match(CSTI_Identifier);
      VarNames.Add(PrevToken);
      end;
    Match(CSTI_Colon);
    CheckSemiColon := true;
    ParseType(TokenID,'',VarType,CheckSemiColon);
    if CheckSemiColon then
      Match(CSTI_SemiColon);
    if CurrPos in [cp_public, cp_published] then
      begin
      for index := 0 to Varnames.Count -1 do
        begin
        CreateFieldReadFunc(Varnames[index]);
        CreateFieldWriteFunc(Varnames[index]);
        fCurrentDTProc.Add('    RegisterProperty('''+varnames[index]+''', '''+
                           vartype+''', iptrw);');
        fCurrentRTProc.Add('    RegisterPropertyHelper('+
                           '@'+aClassname+varnames[index] +'_R,'+
                           '@'+aClassname+varnames[index]+'_W,'+
                           ''''+varnames[index]+''');');
        end;
      end;
    finally
      VarNames.Free;
    end;
  end; {ProcessVar}

  Procedure ProcessProp;
  var
    ParamTypes: TStringList;
    PropertyName : string;
    read, write: Boolean;

  function FindProperty: Boolean;
  var
    e, ReadString: string;
    SearchCount : integer;
  begin
  ReadString := aClassParent;
  Result := False;
  SearchCount := MaxSearchCount;
  while True do
    begin
    if SearchCount = 0 then RaiseError('While searching for property in property list, the maxium number of searchs allowed was reached',TokenRow, TokenCol);
    dec(SearchCount);
    e := Ini.ReadString(ReadString, PropertyName, '~');
    if e = '~' then
      begin
      ReadString := Ini.ReadString(ReadString, 'PARENT-CLASS', '');
      // check in the parent for the property
      if ReadString = '' then exit;
      end
    else
      begin
      if e = '' then
        begin
        PropertyName := '';
        Result := True;
        exit;
        end;
      if pos(' ', e) = 0 then exit;
      ReadString := copy(e,1 ,pos(' ', e)-1);
      Delete(e, 1, length(ReadString)+1);
      ParamTypes.Text := Stringreplace(e, ' ', #13#10, [rfReplaceAll]);
      if ReadString = 'READ' then
        Read := True
      else if ReadString = 'WRITE' then
        Write := True
      else if ReadString = 'READWRITE' then
        begin
        Read := True;
        Write := True;
        end
      else exit;
      Result := True;
      exit;
      end;
    end;
  end; {FindProperty}

  procedure CreateReadFunc(Fake: Boolean);
  var
    decl : string;
    index : Longint;
  begin
  decl := 'procedure '+aClassname+PropertyName+'_R(Self: '+aClassname+
                    '; var T: '+ParamTypes[0];
  for index := 1 to ParamTypes.Count -1 do
    decl := decl + '; const t'+inttostr(index)+': '+ParamTypes[index];
  decl := decl + ');';
  with RegisterProc(decl,RunTime,[Ishelper]) do
    begin
    if IsDone in ProcAttr then RaiseError('Duplicate property :'+aClassname+PropertyName+'_R',TokenRow, TokenCol);
    include(ProcAttr,IsDone);
    if Fake then Insert(1,'{');
    decl := 'begin T := Self.'+PropertyName;
    if ParamTypes.Count > 1 then
      begin
      decl := decl + '[t1';
      for Index := 2 to ParamTypes.Count -1 do
        decl := decl +', t'+inttostr(Index);
      decl := decl + ']';
      end;
    add(decl + '; end;');
    if Fake then Add('}');
    end;
  end; {CreateReadFunc}

  procedure CreateWriteFunc(Fake: Boolean);
  var
    decl : string;
    index : Longint;
  begin
  decl := 'procedure '+aClassname+PropertyName+'_W(Self: '+aClassname+
                    '; const T: '+ParamTypes[0];
  for index := 1 to ParamTypes.Count -1 do
    decl := decl + '; const t'+inttostr(index)+': '+ParamTypes[index];
  decl := decl + ');';
  with RegisterProc(decl,RunTime,[Ishelper]) do
    begin
    if IsDone in ProcAttr then RaiseError('Duplicate property :'+aClassname+PropertyName+'_W',TokenRow, TokenCol);
    include(ProcAttr,IsDone);
    if Fake then Insert(1,'{');
    decl := 'begin Self.'+PropertyName;
    if ParamTypes.Count > 1 then
      begin
      decl := decl + '[t1';
      for Index := 2 to ParamTypes.Count -1 do
        decl := decl +', t'+inttostr(Index);
      decl := decl + ']';
      end;
    add(decl + ' := T; end;');
    if Fake then Add('}');
    end;
  end; {CreateWriteFunc}

var
  Readstr,Writestr,decl : string;
  ParamCount : Longint;

  begin {ProcessProp}
  ParamTypes := TStringList.Create;
  try
    NextToken;
    Match(CSTI_Identifier);
    PropertyName := PrevToken;
    Case TokenId of
    CSTI_Semicolon :
      begin // A property is being introduced that is present in the parent object
      NextToken;
      if FindProperty then
        begin
        if (PropertyName = '') or
           not(CurrPos in [cp_public,cp_published]) then Exit;
        decl := trim(StringReplace(ParamTypes.Text, NewLine, ' ', [rfreplaceAll]));
        // biuld the design time declaration
        decl := '    RegisterProperty('''+PropertyName+''', '''+decl+''', ipt';
        if Read then decl := decl +'r';
        if Write then decl := decl +'w';
        fCurrentDTProc.Add(decl+');');
        if CurrPos <> cp_published then
          begin
          // write out the runtime version
          if Read then
            begin // create the helper function to read from the property
            CreateReadFunc(False);
            Readstr := '@'+aClassName+PropertyName+'_R';
            end
          else Readstr := 'nil';
          if Write then
            begin  // create the helper function to write to the property
            CreateWriteFunc(False);
            Writestr := '@'+aClassName+PropertyName+'_W';
            end
          else Writestr := 'nil';
          // select which Property helper to use (relys on events following the syntax (ON...))
          if copy(PropertyName, 1, 2) <> 'ON' then
            decl := '    RegisterPropertyHelper('
          else
            decl := '    RegisterEventPropertyHelper(';
          fCurrentRTProc.Add(decl+Readstr+','+Writestr+','''+PropertyName+''');')
          end;
        end
      else if PropertyName <> '' then
        Exit;
      end;
    CSTI_OpenBlock :
      begin // a psuedo array property
      NextToken;
      while TokenID <> CSTI_CloseBlock do
        begin
        ParamCount := 0;
        repeat
          if (TokenID = CSTII_Const) or
             (TokenID = CSTII_Var) then
            NextToken;
          Match(CSTI_Identifier);
          inc(ParamCount);
          if TokenID = CSTI_Comma then
            NextToken
          else Break;
        until False;
        Match(CSTI_Colon);
        Match(CSTI_Identifier);
        while ParamCount > 0 do
          begin
          ParamTypes.Add(PrevToken);
          Dec(ParamCount);
          end;
        if TokenId = CSTI_Semicolon then
          begin
          NextToken;
          Continue;
          end;
        end;
      NextToken;
      end;
    end;
    if Token = 'DEFAULT' then
    begin
      NextToken;
      while TokenID <> CSTI_Semicolon do
        NextToken;
      NextToken;
      if FindProperty then
        begin
        if (PropertyName = '') or
           not(CurrPos in [cp_public,cp_published]) then Exit;
        decl := trim(StringReplace(ParamTypes.Text, NewLine, ' ', [rfreplaceAll]));
        // biuld the design time declaration
        decl := '    RegisterProperty('''+PropertyName+''', '''+decl+''', ipt';
        if Read then decl := decl +'r';
        if Write then decl := decl +'w';
        fCurrentDTProc.Add(decl+');');
        if CurrPos <> cp_published then
          begin
          // write out the runtime version
          if Read then
            begin // create the helper function to read from the property
            CreateReadFunc(False);
            Readstr := '@'+aClassName+PropertyName+'_R';
            end
          else Readstr := 'nil';
          if Write then
            begin  // create the helper function to write to the property
            CreateWriteFunc(False);
            Writestr := '@'+aClassName+PropertyName+'_W';
            end
          else Writestr := 'nil';
          // select which Property helper to use (relys on events following the syntax (ON...))
          if copy(PropertyName, 1, 2) <> 'ON' then
            decl := '    RegisterPropertyHelper('
          else
            decl := '    RegisterEventPropertyHelper(';
          fCurrentRTProc.Add(decl+Readstr+','+Writestr+','''+PropertyName+''');')
          end;
        end
      else if PropertyName <> '' then
        Exit;
    end;
    Match(CSTI_Colon);
    Match(CSTI_Identifier);
    ParamTypes.Insert(0, PrevToken);
    // handle various property declarations
    read := false; write := false;

    if Token = 'READ' then
      begin
      repeat
        NextToken; Match(CSTI_Identifier);
      until TokenID <> CSTI_Period;
      read := true;
      end;
    if Token = 'WRITE' then
      begin
      repeat
        NextToken; Match(CSTI_Identifier);
      until TokenID <> CSTI_Period;
      Write := true;
      end;
    if TokenID = CSTI_SemiColon then
      NextToken
    else
    begin
      if (Token = 'STORED') then
      begin
        NextToken;
        NextToken; // skip this
        if TokenId = CSTI_Semicolon then
          Match(CSTI_Semicolon);
      end;
      if (Token = 'DEFAULT') then
      begin
        NextToken;
        while TokenID <> CSTI_Semicolon do
          NextToken;
        Match(CSTI_SemiColon);
      end;
    end;
    if Token = 'DEFAULT' then
    begin
      NextToken;
      Match(CSTI_Semicolon);
    end;
    if UseUnitAtDT and (CurrPos <> cp_public) or
       not(CurrPos in [cp_public,cp_published]) then
      exit;
    decl := trim(StringReplace(ParamTypes.Text, NewLine, ' ', [rfreplaceAll]));
    // biuld the design time declaration
    decl := '    RegisterProperty('''+PropertyName+''', '''+decl+''', ipt';
    if Read then decl := decl +'r';
    if Write then decl := decl +'w';
    fCurrentDTProc.Add(decl+');');
    // write out the runtime version
    if Read then
      begin // create the helper function to read from the property
      CreateReadFunc(False);
      Readstr := '@'+aClassName+PropertyName+'_R';
      end
    else Readstr := 'nil';
    if Write then
      begin  // create the helper function to write to the property
      CreateWriteFunc(False);
      Writestr := '@'+aClassName+PropertyName+'_W';
      end
    else Writestr := 'nil';
    // select which Property helper to use (relys on events following the syntax (ON...))
    if copy(PropertyName, 1, 2) <> 'ON' then
      decl := '    RegisterPropertyHelper('
    else
      decl := '    RegisterEventPropertyHelper(';
    fCurrentRTProc.Add(decl+Readstr+','+Writestr+','''+PropertyName+''');')
  finally
    ParamTypes.Free;
  end;
  end; {ProcessProp}

var
  OldDTProc,OldRTProc : TProcList;
begin {ParseClassDef}
Match(CSTII_class);
//CreateRegClasProc;
// check for a forward declarations
if TokenID = CSTI_Semicolon then
  begin
//  NextToken;  the semicolon is removed by the caller
  if UseUnitAtDT then
    fCurrentDTProc.Add('  cl.addClass(cl.FindClass(''TOBJECT''),'+aClassname+');')
  else
    fCurrentDTProc.Add('  cl.addClassN(cl.FindClass(''TOBJECT''),'''+aClassname+''');');
  if fCurrentRTProc = nil then
  begin
  Include(RunTimeProcType,ClassImporter);
  fCurrentRTProc := RegisterProc('procedure RIRegister_'+UnitName+
                                 '(CL: TIFPSRuntimeClassImporter);',RunTime,[PublicProc]);
  end;
  fCurrentRTProc.Add('  with Cl.Add('+aClassname+') do');
  exit;
  end
else if IfMatch(CSTII_of) then
  begin
  Match(CSTI_Identifier);
  fCurrentDTProc.add('  Cl.AddTypeS('''+aClassname+''', ''class of '+PrevToken+''');');
  exit;
  end
else If IfMatch(CSTI_OpenRound) then
  begin
  Match(CSTI_Identifier);
  aClassParent := PrevToken;
  Match(CSTI_CloseRound);
  if TokenId = CSTI_Semicolon then
  begin
    if UseUnitAtDT then
      fCurrentDTProc.Add('  cl.addClass(cl.FindClass(''TOBJECT''),'+aClassname+');')
    else
      fCurrentDTProc.Add('  cl.addClassN(cl.FindClass(''TOBJECT''),'''+aClassname+''');');
    if fCurrentRTProc = nil then
    begin
    Include(RunTimeProcType,ClassImporter);
    fCurrentRTProc := RegisterProc('procedure RIRegister_'+UnitName+
                                 '(CL: TIFPSRuntimeClassImporter);',RunTime,[PublicProc]);
    end;
    fCurrentRTProc.Add('  with Cl.Add('+aClassname+') do');
    exit;
  end;
  end
else
  aClassParent := 'TOBJECT';
AddRequiredUnit('ifps3',RunTime,true);
if fCurrentRTProc = nil then
  begin
  Include(RunTimeProcType,ClassImporter);
  fCurrentRTProc := RegisterProc('procedure RIRegister_'+UnitName+
                                 '(CL: TIFPSRuntimeClassImporter);',RunTime,[PublicProc]);
  end;
OldRTProc := fCurrentRTProc;
fCurrentRTProc := RegisterProc('procedure RIRegister'+aClassname+
                                '(Cl: TIFPSRuntimeClassImporter);',RunTime,[PublicProc]);
fCurrentRTProc.Add('  with Cl.Add('+aClassname+') do');
fCurrentRTProc.Add('  begin');

OldDTProc := fCurrentDTProc;
fCurrentDTProc := RegisterProc('procedure SIRegister'+aClassname+
                                '(CL: TIFPSPascalCompiler);',CompileTime,[PublicProc]);
if UseUnitAtDT then
  begin
  AddRequiredUnit(UnitName,CompileTime,false);
  fCurrentDTProc.Add('  With cl.AddClass(Cl.FindClass('''+aClassParent+'''),'+aClassname+') do');
  fCurrentDTProc.Add('  begin');
  fCurrentDTProc.Add('    RegisterPublishedProperties;');
  end
else
  begin
  fCurrentDTProc.Add('  With cl.AddClassN(Cl.FindClass('''+aClassParent+'''),'''+aClassname+''') do');
  fCurrentDTProc.Add('  begin');
  end;
CurrPos := cp_public;
While Not IfMatch(CSTII_End) do
  case TokenID of
    CSTII_Private :
      begin
      CurrPos := cp_private;
      NextToken;
      end;
    CSTII_Protected :
      begin
      CurrPos := cp_Protected;
      NextToken;
      end;
    CSTII_Public :
      begin
      CurrPos := cp_public;
      NextToken;
      end;
    CSTII_Published :
      begin
      CurrPos := cp_published;
      NextToken;
      end;
    CSTII_Procedure, CSTII_Function,
    CSTII_Constructor, CSTII_Destructor : ProcessProc;
    CSTI_Identifier : ProcessVar;
    CSTII_Property : ProcessProp;
  else RaiseError('Unknown keyword '''+GetTokenName(TokenID)+'''',TokenRow, TokenCol);
  end;
fCurrentRTProc.Add('  end;');
fCurrentDTProc.Add('  end;');
if OldDTProc <> nil then
  fCurrentDTProc := OldDTProc;
fCurrentDTProc.add('  SIRegister'+aClassname+'(Cl);');
if OldRTProc <> nil then
  fCurrentRTProc := OldRTProc;
fCurrentRTProc.add('  RIRegister'+aClassname+'(Cl);');
end; {ParseClassDef}

Procedure TUnitParser.ParseType(aTokenID : TIfPasToken;
                                const TypeName : string;
                                var TypeDescriptor : string;
                                var CheckSemiColon : boolean);
var
  s : string;
  b : boolean;
begin
CheckSemiColon := True;
case aTokenID of
  CSTI_Integer: // range
    begin
      TypeDescriptor := TypeDescriptor + 'Integer';
      while not (TokenId in [CSTI_EOF, CSTI_Semicolon]) do
      begin
        NextToken;
      end;
      Match(CSTI_Semicolon);
      CheckSemicolon := False;
    end;
  CSTI_Identifier: // simple type by name  (MyInt = Integer)
    begin
    Match(CSTI_Identifier);
    TypeDescriptor := TypeDescriptor + PrevToken;
    end;
  CSTI_Dereference : // ie 'PInteger = ^Integer'
    begin  { todo 3-cWishList : When pointers are supported by ifps3, supported them or provide emulation }
    Match(CSTI_Dereference);
    TypeDescriptor := TypeDescriptor + ' ^';
    ParseType(CSTI_Identifier,TypeName,TypeDescriptor,CheckSemiColon);
    Writeln('Pointers are not supported, this declaration will fail. At position :'+inttostr(TokenRow)+':'+inttostr(TokenCol));
    TypeDescriptor := TypeDescriptor + ' // will not work';
    end;
  CSTII_type : // type identity (MyInt = type Integer)
    begin
    Match(CSTII_type);
//    TypeDescriptor := TypeDescriptor + 'type';
    ParseType(CSTI_Identifier,TypeName,TypeDescriptor,CheckSemiColon);
    end;
  CSTII_procedure,
  CSTII_function : // parse a routine/method pointer
    begin
    ParseProcDecl(s,TypeDescriptor,s,[IsPointer]);
    CheckSemiColon := false;
    end;
  CSTI_OpenRound : // enums  (somename,somename2,..)
    begin
    Match(CSTI_OpenRound);
    TypeDescriptor := TypeDescriptor + '( ';
    b := false;
    repeat
      Match(CSTI_Identifier);
      if b then
        TypeDescriptor := TypeDescriptor +', '+ PrevToken
      else
        begin
        b := true;
        TypeDescriptor := TypeDescriptor + PrevToken;
        end;
      if TokenID = CSTI_CloseRound then
        begin
        NextToken;
        TypeDescriptor := TypeDescriptor + ' ) ';
        break;
        end
      else
        Match(CSTI_Comma);
    until false;
    end;
  CSTII_record : // records (rec = record a : integer; end;)
    begin
    Match(CSTII_record);
    TypeDescriptor := TypeDescriptor + 'record ';
    b := false;
    while TokenID = CSTI_Identifier do
      begin
      TypeDescriptor := TypeDescriptor + Token + ' : ';
      NextToken;
      Match(CSTI_Colon);
      ParseType(TokenId,TypeName,TypeDescriptor,CheckSemiColon);
      if TypeDescriptor = '' then
        b := true; // invalidat this type
      Match(CSTI_SemiColon);
      TypeDescriptor := TypeDescriptor + '; ';
      end;
    TypeDescriptor := TypeDescriptor + 'end ';
    if b then TypeDescriptor := '';    
    Match(CSTII_end);
    end;
  CSTII_set :   // sets    (set of (...))
    begin // parse a set declaration
    Match(CSTII_set);
    Match(CSTII_of);
    TypeDescriptor := TypeDescriptor + 'set of ';
    ParseType(TokenID,TypeName,TypeDescriptor,CheckSemiColon);

   { todo 1 -cWishList : When Sets are supported by ifps3, supported them }
//    RaiseError('Sets are not supported',TokenPos);
   end;
  CSTII_array : // arrays  (array [<const expression>..<const expression>] of ...)
    begin
    Match(CSTII_array);
    b := false;
    TypeDescriptor := TypeDescriptor +  'array ';
    if Ifmatch(CSTI_OpenBlock) then
      begin
      TypeDescriptor := TypeDescriptor +'[ '+ ParseConstantExpression(s);
      If IfMatch(CSTI_Period) then
        begin
        Match(CSTI_Period,'..');
        TypeDescriptor := TypeDescriptor +' .. '+ ParseConstantExpression(s);
        end;
      TypeDescriptor := TypeDescriptor +'] ';
      Match(CSTI_CloseBlock);
      { TODO 1 -cWishList : When static arrays are supported by ifps3, supported them }
      b := true;
      end;
    Match(CSTII_of);
    TypeDescriptor := TypeDescriptor +  'of ';
    Parsetype(TokenID,TypeName,TypeDescriptor,CheckSemiColon);

    if b then TypeDescriptor := '';
    end;
  CSTII_Interface : // interfaces (  objectname = Interface ... end)
    begin
    TypeDescriptor := ''; // suppresses the default register action
//    Writeln('Interfaces are not supported. At position :'+inttostr(TokenPos));
    ParseInterfaceDef(TypeName);
    end;
  CSTII_class : // classes (  objectname = class ... end)
    begin
    TypeDescriptor := ''; // suppresses the default register action
    ParseClassDef(TypeName);
    end;
else RaiseError('Expecting valid type, but found '''+GetTokenName(TokenID)+'''',TokenRow, TokenCol);
end;
end; {ParseType}


Procedure TUnitParser.ParseTypes;
var
  TypeName : string;
  TypeDescriptor,tmp : string;
  CheckSemiColon : boolean;
  len,index : integer;
begin {ParseTypes}
Match(CSTII_type);
Repeat
  // get the type name
  Match(CSTI_Identifier);
  TypeName := PrevToken;
  Match(CSTI_equal);
  // biuld the type discriptor
  TypeDescriptor := '';
  ParseType(TokenID,TypeName,TypeDescriptor,CheckSemiColon);
  if CheckSemiColon then
    Match(CSTI_SemiColon);
  if (TypeDescriptor <> '') then
    begin
    TypeDescriptor := trim(TypeDescriptor);
    // break up the TypeDescriptor to make it fit with in 80 characters per line
    tmp := '  Cl.addTypeS('''+TypeName+''', ''';
    len := Length(tmp) + length(TypeDescriptor)+3;
    if len <= 80 then
      fCurrentDTProc.add(tmp+TypeDescriptor+''');')
    else
      begin
      len := 79 - Length(tmp);
      fCurrentDTProc.add(tmp);
      if len > 0 then
        begin
        tmp := copy(TypeDescriptor,1,len);
        Delete(TypeDescriptor,1,len);
        index := fCurrentDTProc.count - 1;
        fCurrentDTProc[index] := fCurrentDTProc[index] + tmp+'''';
        end
      else
        begin
        fCurrentDTProc.Add('   +'''+copy(TypeDescriptor,1,74)+'''');
        Delete(TypeDescriptor,1,74);
        end;
      while TypeDescriptor <> '' do
        begin
        fCurrentDTProc.Add('   +'''+copy(TypeDescriptor,1,74)+'''');
        Delete(TypeDescriptor,1,74);
        end;
      index := fCurrentDTProc.count - 1;
      fCurrentDTProc[index] := fCurrentDTProc[index] +');';
      end;
    end;
until (TokenID <> CSTI_Identifier);
end; {ParseTypes}



procedure TUnitParser.ParserError(Parser: TObject;
  Kind: TIFParserErrorKind);
var
  s: string;
begin
  Writeln('Error parsing file');
  case Kind of
    iCommentError: s := 'Comment';
    iStringError:  s := 'String';
    iCharError:    s := 'Char';
    iSyntaxError : s := 'Syntax';
  end;
  Writeln(s+' Error, Position :'+Inttostr(TIfPascalParser(Parser).Row)+':'+IntToStr(TIfPascalParser(Parser).Col));
end;

end.

