chelper: started objc syntax support

git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@1283 8e941d3f-bd1b-0410-a28a-d453659cc2b4

components/chelper/cconvert.lpi

@@ -31,12 +31,17 @@
         <LaunchingApplication PathPlusParams="/usr/X11/bin/xterm -T 'Lazarus Run Output' -e $(LazarusDir)/tools/runwait.sh $(TargetCmdLine)"/>
       </local>
     </RunParams>
-    <Units Count="1">
+    <Units Count="2">
       <Unit0>
         <Filename Value="cconvert.lpr"/>
         <IsPartOfProject Value="True"/>
         <UnitName Value="cconvert"/>
       </Unit0>
+      <Unit1>
+        <Filename Value="objctopasconvert.pas"/>
+        <IsPartOfProject Value="True"/>
+        <UnitName Value="objctopasconvert"/>
+      </Unit1>
     </Units>
   </ProjectOptions>
   <CompilerOptions>

components/chelper/cconvert.lpr

@@ -22,7 +22,8 @@ program cconvert;
 
 uses
   SysUtils,Classes,
-  ctopasconvert,cparserutils,cconvconfig;
+  ctopasconvert,cparsertypes,cparserutils,cconvconfig, objcparsing,
+  objctopasconvert;
 
 var
   ConfigFile    : AnsiString = '';

components/chelper/cparsertypes.pas

@@ -20,12 +20,7 @@ unit cparsertypes;
 
 interface
 
-{$ifdef fpc}{$mode delphi}{$h+}
+{$ifdef fpc}{$mode delphi}{$h+}{$endif}
-{$else}
-{$warn unsafe_code off}
-{$warn unsafe_type off}
-{$warn unsafe_cast off}
-{$endif}
 
 uses
   Classes, SysUtils, TextParsingUtils;
@@ -232,7 +227,11 @@ type
   end;
 
 // parsing function
-function ParseNextEntity(AParser: TTextParser): TEntity;
+var
+  ParseNextEntity: function (AParser: TTextParser): TEntity = nil;
+
+function ParseNextCEntity(AParser: TTextParser): TEntity;
+
 function ParseCExpression(AParser: TTextParser; var ExpS: AnsiString): Boolean;
 procedure ParseCNumeric(const S: AnsiString; var idx: integer; var NumStr: AnsiSTring);
 function ParseCString(const S: AnsiString; var idx: Integer; var CStr: AnsiString): Boolean;
@@ -280,6 +279,7 @@ type
 
 procedure ErrorExpect(Parser: TTextParser; const Expect: AnsiString);
 function ConsumeToken(Parser: TTextParser; const Token: AnsiString): Boolean;
+function ConsumeIdentifier(Parser: TTextParser; var Id: AnsiString): Boolean;
 
 function ParseCType(Parser: TTextParser): TEntity;
 
@@ -1455,7 +1455,7 @@ begin
 end;
 
 
-function ParseNextEntity(AParser: TTextParser): TEntity;
+function ParseNextCEntity(AParser: TTextParser): TEntity;
 var
   s   : AnsiString;
   tt  : TTokenType;
@@ -1465,7 +1465,7 @@ var
   v   : TVarFuncEntity;
 begin
   Result := nil;
-  if not AParser.FindNextToken(s, tt) then Exit;
+  s:=AParser.Token;
 
   if s = 'typedef' then begin
     Result:=ParseTypeDef(AParser);
@@ -1507,6 +1507,16 @@ begin
   else Parser.SetError('Token expected: '+Token);
 end;
 
+function ConsumeIdentifier(Parser: TTextParser; var Id: AnsiString): Boolean;
+begin
+  Result:=Parser.TokenType=tt_Ident;
+  if Result then begin
+    id:=Parser.Token;
+    Parser.NextToken;
+  end else
+    Parser.SetError('Identifier expected');
+end;
+
 function ParseCType(Parser: TTextParser): TEntity;
 var
   simple  : TSimpleType;
@@ -2011,4 +2021,8 @@ begin
   inherited Destroy;
 end;
 
+initialization
+  ParseNextEntity:=@ParseNextCEntity;
+
+
 end.

components/chelper/ctopasconvert.pas

@@ -18,13 +18,15 @@
 }
 unit ctopasconvert;
 
+
 {$mode objfpc}{$H+}
 
 interface
 
 uses
   Classes, SysUtils,
-  cparsertypes, TextParsingUtils, codewriter, cparserutils;
+  cparsertypes, TextParsingUtils, codewriter, cparserutils,
+  objcparsing;
 
 type
 
@@ -140,6 +142,10 @@ type
     procedure WriteExp(x: TExpression);
     procedure WritePreprocessor(cent: TCPrepDefine);
 
+    function GetObjCMethodName(names: TStrings): AnsiString;
+    procedure WriteObjCMethod(m: TObjCMethod);
+    procedure WriteObjCInterface(cent: TObjCInterface);
+
     procedure PushWriter;
     procedure PopWriter;
   public
@@ -279,6 +285,8 @@ begin
   AParser.OnPrecompile:=@cmt.OnPrecompiler;
   Result:=nil;
 
+  AParser.NextToken;
+
   ent := ParseNextEntity(AParser);
   entidx:=AParser.Index;
 
@@ -582,6 +590,75 @@ begin
   end;
 end;
 
+function TCodeConvertor.GetObjCMethodName(names:TStrings):AnsiString;
+var
+  i : Integer;
+begin
+  Result:='';
+  for i:=0 to names.Count-1 do Result:=Result+names[i];
+  for i:=1 to length(Result) do if Result[i]=':' then Result[i]:='_';
+end;
+
+procedure TCodeConvertor.WriteObjCMethod(m: TObjCMethod);
+var
+  ret : AnsiString;
+  i   : INteger;
+begin
+  if m.RetType=nil then ret:='id' else ret:=GetPasTypeName(m.RetType, m.RetName);
+  if ret='' then wr.W('procedure ')
+  else wr.W('function ');
+  wr.W( GetObjCMethodName(m.Name) );
+
+  if length(m.Args)>0 then begin
+    wr.W('(');
+    for i:=0 to length(m.Args)-1 do begin
+      if m.Args[i].Name='' then wr.W(cfg.ParamPrefix+IntToStr(i))
+      else wr.W(m.Args[i].Name);
+      wr.W(': ');
+      wr.W(GetPasTypeName(m.Args[i].RetType, m.Args[i].TypeName));
+      if i<length(m.Args)-1 then wr.W('; ');
+    end;
+    wr.W(')');
+  end;
+
+  if ret<>'' then wr.W(': '+ ret);
+  wr.W(';');
+
+  wr.W(' message ''');
+  for i:=0 to m.Name.Count-1 do wr.W(m.Name[i]);
+  wr.Wln(''';');
+end;
+
+procedure TCodeConvertor.WriteObjCInterface(cent:TObjCInterface);
+var
+  i     : Integer;
+  m     : TObjCMethod;
+begin
+  SetPasSection(wr, 'type');
+  if cent.isCategory then begin
+    wr.W(cent.Name + ' = objccategory')
+  end else begin
+    wr.W(cent.Name + ' = objcclass');
+    if cent.SuperClass<>'' then wr.W('('+cent.SuperClass);
+    if cent.Protocols.Count>0 then begin
+      if cent.SuperClass='' then wr.W('(id, ')
+      else wr.W(', ');
+      for i:=0 to cent.Protocols.Count-2 do wr.W(cent.Protocols[i]+', ');
+      wr.W(cent.Protocols[cent.Protocols.Count-1]);
+    end;
+    if (cent.SuperClass<>'') or (cent.Protocols.Count>0) then wr.Wln(')');
+  end;
+
+  wr.Wln('public');
+  wr.IncIdent;
+  for i:=0 to cent.Methods.Count-1 do begin
+    m:=TObjCMethod(cent.Methods[i]);
+    WriteObjCMethod(m)
+  end;
+  wr.DecIdent;
+  wr.Wln('end;')
+end;
+
 procedure TCodeConvertor.PushWriter;
 begin
   if not Assigned(fWriters) then fWriters:=TList.Create;
@@ -900,6 +977,8 @@ begin
     WriteCommentToPas(cent as TComment)
   else if cent is TCPrepDefine then
     WritePreprocessor(cent as TCPrepDefine)
+  else if cent is TObjCInterface then
+    WriteObjCInterface(cent as TObjCInterface)
   else begin
     if DebugEntities then
       wr.Wln(cent.ClassName);

components/chelper/objcparsing.pas

@@ -0,0 +1,396 @@
+unit
+  objcparsing;
+
+interface
+
+{$ifdef fpc}{$mode delphi}{$h+}{$endif}
+
+uses
+  Classes, SysUtils, cparsertypes;
+
+type
+
+  { TObjCClasses }
+
+  TObjCClasses = class(TEntity)
+    Classes : TStringList;
+    constructor Create(AOffset: Integer=-1); override;
+    destructor Destroy; override;
+  end;
+
+  { TObjCMethod }
+
+  TObjCMethodArg = record
+    RetType  : TEntity;
+    TypeName : TNamePart;
+    Name     : AnsiString;
+  end;
+
+  TObjCMethod = class(TEntity)
+  public
+    isClassMethod : Boolean;
+    Name      : TStringList;
+    RetType   : TEntity;
+    RetName   : TNamePart;
+    Args      : array of TObjCMethodArg;
+    constructor Create(AOffset: Integer=-1); override;
+    destructor Destroy; override;
+    procedure AddArg(const ArgType: TEntity; ArgTypeName: TNamePart; const Name: AnsiString);
+  end;
+
+  { TObjCInterface }
+
+  TObjCInterface = class(TEntity)
+  public
+    Name        : AnsiString;
+    SuperClass  : AnsiString;
+    isCategory  : Boolean;
+    Protocols   : TStringList;
+    ProtVars    : TList;
+    PrivVars    : TList;
+    PubVars     : TList;
+    PackVars    : TList;
+    Methods     : TList;
+    constructor Create(AOffset: Integer=-1); override;
+    destructor Destroy; override;
+  end;
+
+function ParseClassList(AParser: TTextParser): TObjCClasses;
+function ParseInterface(AParser: TTextParser): TObjCInterface;
+function ParseMethod(AParser: TTextParser): TObjCMethod;
+function ParseMethods(AParser: TTextParser; MethodsList: TList; const EndToken: AnsiString): Boolean;
+function ParserProtocol(AParser: TTextParser): TEntity;
+
+function ParseNextObjCEntity(AParser: TTextParser): TEntity;
+
+function isObjCKeyword(const token: AnsiString): Boolean; inline;
+function GetObjCKeyword(const token: AnsiString): AnsiString;
+
+implementation
+
+function isObjCKeyword(const token: AnsiString): Boolean; inline;
+begin
+  Result:=(token<>'') and (token[1]='@');
+end;
+
+function GetObjCKeyword(const token: AnsiString): AnsiString;
+begin
+  if isObjCKeyword(token) then Result:=Copy(token, 2, length(token)-1)
+  else Result:=token;
+end;
+
+function ParseClassList(AParser: TTextParser): TObjCClasses;
+var
+  cl  : TObjCClasses;
+begin
+  Result:=nil;
+  if AParser.Token<>'@class' then Exit;
+  cl:=TObjCClasses.Create(AParser.TokenPos);
+  AParser.NextToken;
+  while AParser.Token<>';' do begin
+    if AParser.TokenType<>tt_Ident then begin
+      ErrorExpect(AParser,'identifier');
+      cl.Free;
+      Exit;
+    end;
+    cl.Classes.Add(AParser.Token);
+    AParser.NextToken;
+    if AParser.Token=',' then
+      AParser.NextToken
+    else if AParser.Token<>';' then begin
+      ErrorExpect(AParser,';');
+      cl.Free;
+      Exit;
+    end;
+  end;
+  Result:=cl;
+end;
+
+function ParseInstVars(AParser: TTextParser; itf: TObjCInterface): Boolean;
+var
+  vars  : TList;
+  v     : TVarFuncEntity;
+  s     : AnsiString;
+begin
+  Result:=True;
+  if AParser.Token<>'{' then Exit;
+
+  Result:=False;
+  AParser.NextToken;
+  vars:=itf.ProtVars;
+
+  while AParser.Token<>'}' do begin
+    if isObjCKeyword(AParser.Token) then begin
+      s:=GetObjCKeyword(APArser.Token);
+      if s='protected' then vars:=itf.ProtVars
+      else if s='private' then vars:=itf.PrivVars
+      else if s='public' then vars:=itf.PubVars
+      else if s='package' then vars:=itf.PackVars
+      else begin
+        ErrorExpect(AParser,'}');
+        Exit;
+      end;
+      AParser.NextToken;
+    end else begin
+      v:=TVarFuncEntity.Create(APArser.TokenPos);
+      if not ParseNames(AParser, v.RetType, v.Names) then Exit;
+      vars.Add(v);
+      if AParser.Token=';' then
+        AParser.NextToken;
+    end;
+  end;
+  AParser.NextToken;
+
+  Result:=True;
+end;
+
+function ParseInterface(AParser: TTextParser): TObjCInterface;
+var
+  itf : TObjCInterface;
+  i   : Integer;
+  nm  : AnsiString;
+begin
+  Result:=nil;
+  if AParser.Token<>'@interface' then Exit;
+  i:=AParser.TokenPos;
+  AParser.NextToken;
+
+  if not ConsumeIdentifier(AParser, nm) then Exit;
+
+  itf:=TObjCInterface.Create(i);
+  try
+    itf.Name:=nm;
+    itf.isCategory:=AParser.Token='(';
+    if itf.isCategory then begin
+       AParser.NextToken;
+       if not ConsumeIdentifier(AParser, itf.SuperClass) and ConsumeToken(AParser, ')') then
+        Exit;
+    end else begin
+
+      // super-class
+      if AParser.Token=':' then begin
+        AParser.NextToken;
+        if not ConsumeIdentifier(AParser, itf.SuperClass) then Exit;
+        //writeln('SuperClass = ', itf.SuperClass);
+      end;
+
+      // protocols
+      if AParser.Token='<' then begin
+        AParser.NextToken;
+        while AParser.Token<>'>' do begin
+          if not ConsumeIdentifier(AParser, nm) then Exit;
+          //writeln('Protos = ', nm);
+          itf.Protocols.Add(nm);
+          if AParser.Token=',' then AParser.NextToken
+          else if AParser.Token<>'>' then begin
+            ErrorExpect(AParser, '>');
+            Exit;
+          end;
+        end;
+        AParser.NextToken;
+      end;
+
+      //writeln('parsing vars1 ', AParser.Token);
+      ParseInstVars(AParser, itf);
+      //writeln('parsing vars2 ', AParser.Token);
+    end;
+
+    //writeln('parsing methods1 ', AParser.Token);
+    if not ParseMethods(AParser, itf.Methods, '@end') then Exit;
+    //writeln('parsing methods2 ', AParser.Token);
+
+    if AParser.Token='@end' then AParser.NextToken;
+
+    Result:=itf;
+  finally
+    if not Assigned(Result) then itf.Free;
+  end;
+end;
+
+function ParserProtocol(AParser: TTextParser): TEntity;
+begin
+  Result:=nil;
+end;
+
+var
+  PrevParseNextEntity : function (AParser: TTextParser): TEntity = nil;
+
+function ParseNextObjCEntity(AParser: TTextParser): TEntity;
+var
+  t   : AnsiString;
+begin
+  if AParser.Token[1]='@' then begin
+    t:=GetObjCKeyword(AParser.Token);
+    if t='class' then Result:=ParseClassList(AParser)
+    else if t='interface' then Result:=ParseInterface(AParser)
+    else if t='protocol' then Result:=ParserProtocol(AParser);
+  end else begin
+    if Assigned(PrevParseNextEntity) then
+      Result:=PrevParseNextEntity(AParser)
+    else
+      Result:=nil;
+  end;
+end;
+
+{ TObjCClasses }
+
+constructor TObjCClasses.Create(AOffset:Integer);
+begin
+  inherited Create(AOffset);
+  Classes := TStringList.Create;
+end;
+
+destructor TObjCClasses.Destroy;
+begin
+  Classes.Free;
+  inherited Destroy;
+end;
+
+{ TObjCInterface }
+
+constructor TObjCInterface.Create(AOffset:Integer);
+begin
+  ProtVars := TList.Create;
+  PrivVars := TList.Create;
+  PubVars  := TList.Create;
+  PackVars := TList.Create;
+  Methods  := TList.Create;
+  Protocols := TStringList.Create;
+  inherited Create(AOffset);
+end;
+
+destructor TObjCInterface.Destroy;
+var
+  i : Integer;
+begin
+  for i:=0 to ProtVars.Count-1 do TObject(ProtVars[i]).Free;
+  for i:=0 to PrivVars.Count-1 do TObject(PrivVars[i]).Free;
+  for i:=0 to PubVars.Count-1 do TObject(PubVars[i]).Free;
+  for i:=0 to PackVars.Count-1 do TObject(PubVars[i]).Free;
+  PrivVars.Free;
+  PubVars.Free;
+  ProtVars.Free;
+  PackVars.Free;
+
+  for i:=0 to Methods.Count-1 do TObject(Methods[i]).Free;
+  Methods.Free;
+
+  Protocols.Free;
+  inherited Destroy;
+end;
+
+function ParseMethod(AParser: TTextParser): TObjCMethod;
+var
+  m       : TObjCMethod;
+  nm      : AnsiString;
+  atype   : TEntity;
+  atname  : TNamePart;
+  aname   : Ansistring;
+  prm     : Boolean;
+begin
+  Result:=nil;
+  if (AParser.Token<>'+') and (AParser.Token<>'-') then Exit;
+  //writeln('in method: ', AParser.Token);
+  m:=TObjCMethod.Create(AParser.TokenPos);
+  try
+    AParser.NextToken;
+
+    //writeln('in method2: ', AParser.Token);
+    if AParser.Token='(' then begin
+      AParser.NextToken;
+      if not ParseName(AParser,  m.RetType, m.RetName) then Exit;
+      if not ConsumeToken(AParser, ')') then Exit;
+    end;
+
+    //writeln('in method3: ', AParser.Token);
+    if not ConsumeIdentifier(AParser, nm) then Exit;
+
+    //writeln('in method3: ', AParser.Token);
+    if (AParser.Token=':') then begin
+      m.Name.Add(nm+':');
+      AParser.NextToken;
+
+      //writeln('in method4: ', AParser.Token);
+      while AParser.Token<>';' do begin
+        prm:=ConsumeToken(AParser, '(') and
+             ParseName(APArser, atype, atname) and
+             ConsumeToken(AParser, ')') and
+             ConsumeIdentifier(AParser, aname);
+        if not prm then Exit;
+        m.AddArg(atype, atname, aname);
+
+        if AParser.TokenType=tt_Ident then ConsumeIdentifier(AParser, nm) else nm:='';
+        if AParser.Token<>';' then begin
+          if not ConsumeToken(AParser,':') then Exit;
+          m.Name.Add(nm+':');
+        end;
+      end;
+      AParser.NextToken;
+    end else begin
+      m.Name.Add(nm);
+      if not ConsumeToken(AParser, ';') then Exit;
+    end;
+
+    //writeln('in method5: ', AParser.Token);
+    Result:=m;
+  finally
+    if not Assigned(Result) then m.Free;
+  end;
+end;
+
+function ParseMethods(AParser: TTextParser; MethodsList: TList; const EndToken: AnsiString = '@end'): Boolean;
+var
+  m : TObjCMethod;
+begin
+  Result:=False;
+  if not Assigned(MethodsList) or not Assigned(AParser) then Exit;
+  while (AParser.Token<>EndToken) and (AParser.Token<>'') and (AParser.Token[1] in ['+','-']) do begin
+    //writeln('AParser.Token = ', AParser.Token);
+    m:=ParseMethod(AParser);
+    //writeln('m = ', Integer(m));
+    if not Assigned(m) then Exit;
+    MethodsList.Add(m);
+  end;
+  Result:=True;
+end;
+
+{ TObjCMethod }
+
+constructor TObjCMethod.Create(AOffset:Integer);
+begin
+  inherited Create(AOffset);
+  Name      := TStringList.Create;
+  RetType   := TVarFuncEntity.Create;
+end;
+
+destructor TObjCMethod.Destroy;
+var
+  i : Integer;
+begin
+  Name.Free;
+  RetType.Free;
+  RetName.Free;
+  for i:=0 to length(Args)-1 do begin
+    Args[i].RetType.Free;
+    Args[i].TypeName.Free;
+  end;
+  inherited Destroy;
+end;
+
+procedure TObjCMethod.AddArg(const ArgType:TEntity;ArgTypeName:TNamePart;const Name:AnsiString);
+var
+  i : Integer;
+begin
+  i:=length(Args);
+  SetLength(Args, i+1);
+  Args[i].Name:=Name;
+  Args[i].RetType:=ArgType;
+  Args[i].TypeName:=ArgTypeName;
+end;
+
+initialization
+  PrevParseNextEntity:=ParseNextEntity;
+  ParseNextEntity:=ParseNextObjCEntity;
+
+end.
+