added enum types support, #ifdef

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

bindings/pascocoa/parser/ObjCParserUtils.pas

@@ -16,7 +16,7 @@ interface
 
 uses
   Classes, SysUtils, ObjCParserTypes;
-
+  
 procedure WriteOutIncludeFile(hdr: TObjCHeader; st: TStrings);
 
 function ObjCToDelphiType(const objcType: AnsiString): AnsiString;
@@ -154,12 +154,15 @@ begin
     else Result := GetProcFuncHead(m._Name, '', GetMethodParams(m), GetMethodResultType(m), ft)
 end;
 
-
+// returns define pas file name form Objective C name, like
+// NSApplication.h  ->  NSAPPLICATION_PAS_H
+// SomePath/SomePath/SomeFileName.h -> SOMEFILENAME_PAS_H
 function GetIfDefFileName(const FileName: AnsiString): AnsiString;
 var
   i : integer;
   s : AnsiString;
 begin
+  //todo: don't like it...
   Result := Copy(FileName, 1, length(FileName) - length(ExtractFileExt(FileName)));
   Result := AnsiUpperCase(Result);
   for i := 1 to length(Result) do
@@ -168,6 +171,100 @@ begin
   Result := Result + '_PAS_H';
 end;
 
+// returns include pas file name form Objective C name, like
+// <AppKit/NSApplication.h>  ->  NSApplication.inc
+// "SomePath/SomePath/SomeFileName.h> -> SomeFileName.h
+function GetIncludeFile(const s: AnsiString): AnsiString;
+var
+  i   : Integer;
+begin
+  //todo: don't like it...
+  Result := '';
+  if s = '' then Exit;
+  i := length(s);
+  if (s[i] = '"') or (s[i] = '>') then dec(i);
+  i := length(s) - 1;
+  // dummy, but it works =)
+  while (i > 0) and (s[i] in ['.', 'A'..'Z', 'a'..'z', '0'..'9']) do dec(i);
+
+  Result := Copy(s, i + 1, length(s) - i);
+  if Result <> '' then begin
+    if Result[length(Result)] in ['"', '>'] then Result :=
+      Copy(Result, 1, length(Result) - 1);
+    Result := Copy(Result, 1, length(Result) - length(ExtractFileExt(Result))) + '.inc';
+  end;
+end;
+
+// returns pascal style of precomiler "if defined" section
+// exclusion is done for Cocoa known precompiler definion, for ex:
+// MAC_OS_X_VERSION_MAX_ALLOWED >= MAC_OS_X_VERSION_10_3 -> MAC_OS_X_VERSION_10_3
+// any other #ifdef excpresions would be passed "as is" even if are incorrect
+// for pascal
+function PrecompileIfDefToPascal(const prm: AnsiString): AnsiString;
+var
+  i   : Integer;
+const
+  VerExclude = 'MAC_OS_X_VERSION_MAX_ALLOWED >=';
+begin
+  // really slow... and... don't like this anyway!
+  Result := prm;
+  i := Pos(VerExclude, prm);
+  if i > 0 then begin
+    i := i + length(VerExclude);
+    while (i <= length(Result)) and (Result[i] = ' ') do inc(i);
+    if i <= length(Result) then
+      Result := Copy(prm, i, length(Result) - i + 1);
+  end;
+end;
+
+// converts TProcpmiler entity to pascal entity
+// #import or #include -> {$Include Something.inc}
+// #define SOMETHING -> {$define SOMETHING}
+// #ifdef SOMETHING -> {$ifdef SOMETHING}
+// etc...
+function WriteOutPrecompToPascal(Prec: TPrecompiler): AnsiString;
+var
+  dir : AnsiString;
+begin
+  dir := AnsiLowerCase(Prec._Directive);
+  if (dir = '#import') or (dir = '#include') then
+    Result := Format('{$include %s}', [GetIncludeFile(Prec._Params)])
+  else if (dir = '#if') then
+    Result := Format('{$ifdef %s}', [PrecompileIfDefToPascal(Prec._Params)])
+  else if (dir = '#else') then
+    Result := '{$else}'
+  else if (dir = '#endif') then
+    Result := '{$endif}';
+end;
+
+// clears empty precompile statements, like
+// {$ifdef SOMETHING}
+// {$endif}
+// and
+// {$ifdef SOMETHING}
+// {$else}
+// {$endif}
+// will be removed
+procedure ClearEmptyPrecompile(subs: TStrings);
+var
+  i   : integer;
+  j   : Integer;
+begin
+  // don't like it either...
+  i := subs.Count - 1; if i < 0 then Exit;
+  j := i;
+  
+  if Pos('{$endif', subs[i]) = 0 then Exit;
+  dec(i); if i < 0 then Exit;
+  
+  if Pos('{$else', subs[i]) > 0 then
+    dec(i); if i < 0 then Exit;
+  
+  if Pos('{$ifdef', subs[i]) > 0 then
+    for i := j downto i do
+      subs.Delete(i);
+end;
+
 procedure BeginSection(const FileName, SectionName: AnsiString; st: TStrings);
 var
   nm : AnsiString;
@@ -185,27 +282,155 @@ begin
   st.Add('{$endif}');
 end;
 
+// todo: remove Prefix param...
+procedure WriteOutIfDefPrecompiler(prec: TPrecompiler; subs: TStrings; const Prefix: AnsiString);
+var
+  ppas  : AnsiString;
+  isend : Boolean;
+begin
+  ppas := WriteOutPrecompToPascal(prec);
+  isend := IsSubStr('{$endif', ppas, 1);
+  if isend or IsSubStr('{$ifdef', ppas, 1) or IsSubStr('{$else', ppas, 1) then
+    subs.Add(Prefix + ppas);
+  if isend then ClearEmptyPrecompile(subs);
+end;
+
 procedure WriteOutClassToHeader(cl : TClassDef; subs: TStrings; conststr: TStrings);
 var
   i   : Integer;
+  j   : Integer;
   s   : AnsiString;
   ss  : AnsiString;
   mtd : TClassMethodDef;
+  obj : TObject;
 begin
   if conststr.IndexOf(cl._ClassName) < 0 then begin
     conststr.Add(cl._ClassName);
     s := Format('  Str_%s = '#39'%s'#39';', [cl._ClassName, cl._ClassName]);
     subs.Add(s);
   end;
-  for i := 0 to cl.Items.Count - 1 do
+  for i := 0 to cl.Items.Count - 1 do begin
-    if TObject(cl.Items[i]) is TClassMethodDef then begin
+    obj := TObject(cl.Items[i]);
+    if obj is TClassMethodDef then begin
       mtd := TClassMethodDef(cl.Items[i]);
       if conststr.IndexOf(mtd._Name) < 0 then begin
         conststr.Add(mtd._Name);
         ss := Format('  Str_%s = '#39'%s'#39';', [mtd._Name, mtd._Name]);
         subs.add(ss);
       end;
+    end else if obj is TPrecompiler then begin
+      WriteOutIfDefPrecompiler(TPrecompiler(obj), subs, '  ');
     end;
+  end; {of for}
+  subs.Add('');
+end;
+
+procedure WriteOutPrecompToHeader(Prec: TPrecompiler; st: TStrings);
+var
+  dlph  : AnsiString;
+begin
+  dlph := WriteOutPrecompToPascal(Prec);
+  if IsSubStr('{$include', dlph, 1) then st.Add(dlph);
+end;
+
+function GetPascalEnumValue(const Name, Param: AnsiString): AnsiString;
+begin
+  Result := Name;
+  if Param <> '' then Result := Result + ' = ' + Param;
+end;
+
+function GetPascalConstValue(const Vl: AnsiString): AnsiString;
+begin
+  Result := vl;
+end;
+
+procedure WriteOutEnumValues(enm: TEnumTypeDef; st: TStrings; const Prefix: AnsiString);
+var
+  vl  : TEnumValue;
+  s   : AnsiString;
+  i   : Integer;
+  j   : Integer;
+begin
+  j := st.Count;
+  for i := 0 to enm.Items.Count - 1 do
+    if TObject(enm.Items[i]) is TEnumValue then begin
+      vl := TEnumValue(enm.Items[i]);
+      if st.Count > j then st[st.Count-1]:=st[st.Count-1]+', ';
+      s := GetPascalEnumValue(vl._Name, GetPascalConstValue(vl._Value));
+      s := Prefix + s;
+      st.Add(s);
+    end;
+end;
+
+function Min(a, b: Integer): Integer;
+begin
+  if a < b then Result := a
+  else Result := b;
+end;
+
+procedure MatchFixes(const Name: AnsiString; var prefix, postfix: AnsiString);
+var
+  i     : integer;
+  ni, pi: integer;
+  nc, pc: AnsiChar;
+begin
+  for i := 1 to Min(length(Name), length(prefix)) do
+    if Name[i] <> prefix[i] then begin
+      prefix := Copy(prefix, 1, i - 1);
+      Break;
+    end;
+    
+  ni := length(Name);
+  pi := length(postfix);
+  for i := 1 to Min(length(Name), length(postfix)) do begin
+    if Name[ni] <> postfix[pi] then begin // this cause a bug
+      //writeln('postfix ', ni + 1, ' ', length(Name) - ni);
+      postfix := Copy(Name, ni + 1, length(Name) - ni);
+//      writeln('postfixing: ', postfix);
+      Break;
+    end;
+    dec(ni);
+    dec(pi);
+  end;
+
+end;
+
+function EvaluateEnumName(enm: TEnumTypeDef): AnsiString;
+var
+  prefix  : AnsiString;
+  postfix : AnsiSTring;
+  vl      : TEnumValue;
+  known   : integer;
+  i       : Integer;
+begin
+  known := 0;
+  for i := 0 to enm.Items.Count - 1 do begin
+    if TObject(enm.Items[i]) is TEnumValue then begin
+      vl := TEnumValue(enm.Items[i]);
+      if known = 0 then begin
+        prefix := vl._Name;
+        postfix := vl._Name;
+      end else
+        MatchFixes(vl._Name, prefix, postfix);
+      //writeln(vl._Name, ' "', prefix, '", "', postfix,'"');
+      inc(known)
+    end;
+  end;
+  if (known <= 1) or (length(Result) < 3) then Result := 'todoEnumName' // if only one enumaration or none, name cannot be defined...
+  else Result := prefix + postfix;
+end;
+
+procedure WriteOutEnumToHeader(enm: TEnumTypeDef; st: TStrings);
+var
+  i   : Integer;
+  s   : AnsiString;
+begin
+  if enm._Name = '' then s := EvaluateEnumName(enm)
+  else s := enm._Name;
+  st.Add(Format('  %s = (', [s] ));
+  WriteOutEnumValues(enm, st, '    ');
+  st.Add('  );');
+  st.Add('');
 end;
 
 procedure WriteOutHeaderSection(hdr: TObjCHeader; st: TStrings);
@@ -221,9 +446,13 @@ begin
   consts := TStringList.Create;
   try
     for i := 0 to hdr.Items.Count - 1 do
-      if Assigned(hdr.Items[i]) and (TObject(hdr.Items[i]) is TClassDef) then begin
+      if Assigned(hdr.Items[i]) then begin
-        cl := TClassDef(hdr.Items[i]);
+        if (TObject(hdr.Items[i]) is TClassDef) then begin
-        WriteOutClassToHeader(cl, subs, consts);
+          cl := TClassDef(hdr.Items[i]);
+          WriteOutClassToHeader(cl, subs, consts);
+        end else if (TObject(hdr.Items[i]) is TPrecompiler) then begin
+          WriteOutPrecompToHeader(TPrecompiler(hdr.Items[i]), st);
+        end;
       end;
 
     if subs.Count > 0 then begin
@@ -231,6 +460,22 @@ begin
       st.AddStrings(subs);
       subs.Clear;
     end;
+    
+    for i := 0 to hdr.Items.Count - 1 do
+      if Assigned(hdr.Items[i]) then begin
+        if (TObject(hdr.Items[i]) is TEnumTypeDef) then begin
+          WriteOutEnumToHeader(TEnumTypeDef(hdr.Items[i]), subs);
+        end else if (TObject(hdr.Items[i]) is TPrecompiler) then begin
+          WriteOutIfDefPrecompiler(TPrecompiler(hdr.Items[i]), st, '  ');
+        end;
+      end; {of if}
+    
+    if subs.Count > 0 then begin
+      st.Add('type');
+      st.AddStrings(subs);
+      subs.Clear;
+    end;
+
   finally
     EndSection(st);
     subs.Free;
@@ -240,8 +485,16 @@ end;
 
 procedure WriteOutClassToClasses(cl: TClassDef; subs: TStrings);
 var
+  i   : Integer;
+  cnt : Integer;
   s   : AnsiString;
   j   : Integer;
+  obj : TObject; // or TEntity
+  
+  mtds   : TStringList; // name of methods
+  over   : TStringList; // overloaded names
+const
+  SpacePrefix = '    ';
 begin
   subs.Add('  { '+cl._ClassName +' }');
   subs.Add('');
@@ -254,21 +507,45 @@ begin
     subs.Add(s + '{from category '+ cl._Category +'}');
     subs.Add('  public');
   end;
-  for j := 0 to cl.Items.Count - 1 do
+
-    if TObject(cl.Items[j]) is TClassMethodDef then begin
+  mtds := TStringList.Create;
-      s := GetMethodStr(cl, TClassMethodDef(cl.Items[j]), false);
+  try
-      subs.Add('    ' + s);
+    for j := 0 to cl.Items.Count - 1 do begin
+      obj := TObject(cl.Items[j]);
+      if obj is TClassMethodDef then begin
+        i := mtds.indexOf(TClassMethodDef(obj)._Name);
+        if i < 0 then
+          mtds.Add( TClassMethodDef(obj)._Name)
+        else
+          mtds.Objects[i] := TObject(Integer(mtds.Objects[i]) + 1);
+      end;
     end;
+
+    for j := 0 to cl.Items.Count - 1 do begin
+      obj := TObject(cl.Items[j]);
+      if obj is TClassMethodDef then begin
+        s := GetMethodStr(cl, TClassMethodDef(cl.Items[j]), false);
+        i := mtds.IndexOf(TClassMethodDef(cl.Items[j])._Name);
+        if Integer(mtds.Objects[i]) > 0 then s := s + ' overload;';
+        subs.Add(SpacePrefix + s);
+      end else if obj is TPrecompiler then begin
+        WriteOutIfDefPrecompiler(TPrecompiler(obj), subs, SpacePrefix);
+      end;
+    end;
+  finally
+    mtds.Free;
+  end;
+  
   subs.Add('  end;');
   subs.Add('');
 end;
 
 procedure WriteOutClassesSection(hdr: TObjCHeader; st: TStrings);
 var
-  i   : integer;
+  i     : integer;
-  cl  : TClassDef;
+  cl    : TClassDef;
-  j   : integer;
+  j     : integer;
-  s   : AnsiString;
+  s     : AnsiString;
   subs  : TStringList;
 begin
   BeginSection(hdr._FileName, 'CLASSES', st);
@@ -390,6 +667,7 @@ end;
 procedure WriteOutClassToImplementation(cl: TClassDef; subs: TStrings);
 var
   i   : integer;
+  obj : TObject;
 begin
   subs.Add('{ '+cl._ClassName + ' }');
   
@@ -405,10 +683,13 @@ begin
   subs.Add('end');
   subs.Add('');
   
-  
+  for i := 0 to cl.Items.Count - 1 do begin
-  for i := 0 to cl.Items.Count - 1 do
+    obj := TObject(cl.Items[i]);
-    if TObject(cl.Items[i]) is TClassMethodDef then
+    if obj is TClassMethodDef then
-      WriteOutMethodToImplementation ( TClassMethodDef(cl.Items[i]), subs);
+      WriteOutMethodToImplementation ( TClassMethodDef(cl.Items[i]), subs)
+    else if obj is TPrecompiler then
+      WriteOutIfDefPrecompiler( TPrecompiler(obj), subs, '');
+  end;
 end;
 
 procedure WriteOutImplementationSection(hdr: TObjCHeader; st: TStrings);
@@ -418,8 +699,10 @@ begin
   BeginSection(hdr._FileName, 'IMPLEMENTATION', st);
   try
     for i := 0 to hdr.Items.Count - 1 do
-      if Assigned(hdr.Items[i]) and (TObject(hdr.Items[i]) is TClassDef) then
+      if Assigned(hdr.Items[i]) then begin
-        WriteOutClassToImplementation(TClassDef(hdr.Items[i]), st);
+        if (TObject(hdr.Items[i]) is TClassDef) then
+          WriteOutClassToImplementation(TClassDef(hdr.Items[i]), st);
+      end;
   finally
     EndSection(st);
   end;