pascal/lazarus-ccr
1
0
Fork 0
Code Issues Releases Activity

updated to the latest ObjCParserTypes

Browse Source 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@400 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
skalogryz
2008-04-01 06:29:04 +00:00
parent 0c99d758e2
commit e39229a140
1 changed files with 177 additions and 61 deletions
Download Patch File Download Diff File Expand all files Collapse all files

236
bindings/pascocoa/parser/ObjCParserUtils.pas
View File

@@ -19,7 +19,7 @@ uses
procedure WriteOutIncludeFile(hdr: TObjCHeader; st: TStrings); procedure WriteOutIncludeFile(hdr: TObjCHeader; st: TStrings);
function ObjCToDelphiType(const objcType: AnsiString): AnsiString; function ObjCToDelphiType(const objcType: AnsiString; isPointer: Boolean): AnsiString;
function StrFromFile(const FileName: AnsiString): AnsiString; function StrFromFile(const FileName: AnsiString): AnsiString;
@@ -28,13 +28,56 @@ function GetMethodStr(cl: TClassDef; m: TClassMethodDef; ForImplementation: Bool
function GetProcFuncHead(const FuncName, OfClass, Params, ResType: AnsiString; const FuncDest: AnsiString = ''): AnsiString; function GetProcFuncHead(const FuncName, OfClass, Params, ResType: AnsiString; const FuncDest: AnsiString = ''): AnsiString;
function GetMethodParams(const m: TClassMethodDef): AnsiString; function GetMethodParams(const m: TClassMethodDef): AnsiString;
function GetMethodResultType(const m: TClassMethodDef): AnsiString; function GetMethodResultType(const m: TClassMethodDef): AnsiString;
function IsPascalReserved(const s: AnsiString): Boolean;
implementation implementation
function GetMethodResultType(const m: TClassMethodDef): AnsiString; function IsPascalReserved(const s: AnsiString): Boolean;
var
ls : AnsiString;
begin begin
if not Assigned(m.GetResultType) then Result := '' //todo: a hash table should be used?
else Result := ObjCToDelphiType(m.GetResultType._TypeName); Result := true;
if s = '' then Exit;
ls := AnsiLowerCase(s);
case ls[1] of
'a': Result := (ls = 'absolute') or (ls = 'abstract') or (ls = 'and') or (ls = 'array') or (ls = 'as') or (ls= 'asm') or (ls = 'assembler');
'b': Result := (ls = 'begin') or (ls = 'break');
'c': Result := (ls = 'cdecl') or (ls = 'class') or (ls = 'const') or (ls = 'constructor') or (ls = 'continue') or (ls = 'cppclass');
'd': Result := (ls = 'deprecated') or (ls = 'destructor') or (ls = 'div') or (ls = 'do') or (ls = 'downto');
'e': Result := (ls = 'else') or (ls = 'end') or (ls = 'except') or (ls = 'exit') or (ls = 'export') or (ls = 'exports') or (ls = 'external');
'f': Result := (ls = 'fail') or (ls = 'false') or (ls = 'far') or (ls = 'file') or (ls = 'finally') or (ls = 'for') or (ls = 'forward') or (ls = 'function');
'g': Result := (ls = 'goto');
'i':
Result := (ls = 'if') or (ls = 'implementation') or (ls = 'in') or (ls = 'index') or (ls = 'inherited') or (ls = 'initialization') or (ls = 'inline')
or (ls = 'interface') or (ls = 'interrupt') or (ls = 'is');
'l': Result := (ls = 'label') or (ls = 'library');
'm': Result := (ls = 'mod');
'n': Result := {(ls = 'name') or} (ls = 'near') or (ls = 'nil') or (ls = 'not');
'o': Result := (ls = 'object') or (ls = 'of') or (ls = 'on') or (ls = 'operator') or (ls = 'or') or (ls = 'otherwise');
'p':
Result := (ls = 'packed') or (ls = 'popstack') or (ls = 'private') or (ls = 'procedure') or (ls = 'program') or (ls = 'property')
or (ls = 'protected') or (ls = 'public');
'r': Result := (ls = 'raise') or (ls = 'record') or (ls = 'reintroduce') or (ls = 'repeat');
's': Result := (ls = 'self') or (ls = 'set') or (ls = 'shl') or (ls = 'shr') or (ls = 'stdcall') or (ls = 'string');
't': Result := (ls = 'then') or (ls = 'to') or (ls = 'true') or (ls = 'try') or (ls = 'type');
'u': Result := (ls = 'unimplemented') or (ls = 'unit') or (ls = 'until') or (ls = 'uses');
'v': Result := (ls = 'var') or (ls = 'virtual');
'w': Result := (ls = 'while') or (ls = 'with');
'x': Result := (ls = 'xor');
end;
end;
function GetMethodResultType(const m: TClassMethodDef): AnsiString;
var
res : TObjCResultTypeDef;
begin
res := m.GetResultType;
if not Assigned(res) then Result := ''
else Result := ObjCToDelphiType(m.GetResultType._Name, m.GetResultType._IsPointer);
end; end;
function GetMethodParams(const m: TClassMethodDef): AnsiString; function GetMethodParams(const m: TClassMethodDef): AnsiString;
@@ -51,9 +94,9 @@ begin
p := TObject(m.Items[i]); p := TObject(m.Items[i]);
if p is TParamDescr then if p is TParamDescr then
vname := TParamDescr(p)._Descr vname := TParamDescr(p)._Descr
else if p is TParameterDef then begin else if p is TObjCParameterDef then begin
if vname = '' then vname := TParameterDef(p)._Name; if vname = '' then vname := TObjCParameterDef(p)._Name;
vtype := ObjCToDelphiType(TParameterDef(p)._Res._TypeName); vtype := ObjCToDelphiType(TObjCParameterDef(p)._Res._Name, TObjCParameterDef(p)._Res._IsPointer);
if Result <> '' then Result := Result + '; '; if Result <> '' then Result := Result + '; ';
Result := Result + vname + ': ' + vtype; Result := Result + vname + ': ' + vtype;
vname := ''; vname := '';
@@ -74,12 +117,10 @@ begin
Result := Result + FuncName; Result := Result + FuncName;
if Params <> '' then if Params <> '' then
Result := Result + '('+Params+')'; Result := Result + '('+Params+')';
if ResType <> '' then Result := Result+':'+ResType; if ResType <> '' then Result := Result+': '+ResType;
Result := Result + ';'; Result := Result + ';';
end; end;
function StrFromFile(const FileName: AnsiString): AnsiString; function StrFromFile(const FileName: AnsiString): AnsiString;
var var
fs : TFileStream; fs : TFileStream;
@@ -93,7 +134,7 @@ begin
end; end;
end; end;
function ObjCToDelphiType(const objcType: AnsiString): AnsiString; function ObjCToDelphiType(const objcType: AnsiString; isPointer: Boolean): AnsiString;
var var
l : AnsiString; l : AnsiString;
begin begin
@@ -102,7 +143,10 @@ begin
if l = '' then Exit; if l = '' then Exit;
case l[1] of case l[1] of
'v': 'v':
if l = 'void' then Result := ''; if l = 'void' then begin
if not isPointer then Result := ''
else Result := 'Pointer';
end;
'i': 'i':
if l = 'id' then Result := 'objc.id' if l = 'id' then Result := 'objc.id'
else if l = 'int' then Result := 'Integer'; else if l = 'int' then Result := 'Integer';
@@ -125,7 +169,7 @@ end;
function IsMethodConstructor(cl: TClassDef; m: TClassMethodDef): Boolean; function IsMethodConstructor(cl: TClassDef; m: TClassMethodDef): Boolean;
var var
res : TResultTypeDef; res : TObjCResultTypeDef;
l : AnsiString; l : AnsiString;
begin begin
Result := m._IsClassMethod; Result := m._IsClassMethod;
@@ -139,20 +183,26 @@ begin
if not Result then Exit; if not Result then Exit;
res := m.GetResultType; res := m.GetResultType;
l := res._TypeName; l := res._Name;
Result := (l = 'id') or (l = cl._ClassName); Result := (l = 'id') or (l = cl._ClassName);
end; end;
function GetMethodStr(cl: TClassDef; m: TClassMethodDef; ForImplementation: Boolean): AnsiString; function GetMethodStr(cl: TClassDef; m: TClassMethodDef; ForImplementation: Boolean): AnsiString;
var var
i : integer; // i : integer;
ft : AnsiString; ft : AnsiString;
res : AnsiString;
begin begin
if IsMethodConstructor(cl, m) then ft := 'constructor' res := GetMethodResultType(m);
else ft := ''; if IsMethodConstructor(cl, m) then begin
ft := 'constructor';
res := '';
end else
ft := '';
if ForImplementation if ForImplementation
then Result := GetProcFuncHead(m._Name, cl._ClassName, GetMethodParams(m), GetMethodResultType(m), ft) then Result := GetProcFuncHead(m._Name, cl._ClassName, GetMethodParams(m), res, ft)
else Result := GetProcFuncHead(m._Name, '', GetMethodParams(m), GetMethodResultType(m), ft) else Result := GetProcFuncHead(m._Name, '', GetMethodParams(m), res, ft)
end; end;
// returns define pas file name form Objective C name, like // returns define pas file name form Objective C name, like
@@ -161,7 +211,7 @@ end;
function GetIfDefFileName(const FileName, DefExt: AnsiString): AnsiString; function GetIfDefFileName(const FileName, DefExt: AnsiString): AnsiString;
var var
i : integer; i : integer;
s : AnsiString; // s : AnsiString;
begin begin
//todo: don't like it... //todo: don't like it...
Result := Copy(FileName, 1, length(FileName) - length(ExtractFileExt(FileName))); Result := Copy(FileName, 1, length(FileName) - length(ExtractFileExt(FileName)));
@@ -182,8 +232,9 @@ begin
//todo: don't like it... //todo: don't like it...
Result := ''; Result := '';
if s = '' then Exit; if s = '' then Exit;
i := length(s); // i := length(s);
if (s[i] = '"') or (s[i] = '>') then dec(i); { if (s[i] = '"') or (s[i] = '>') then
dec(i);}
i := length(s) - 1; i := length(s) - 1;
// dummy, but it works =) // dummy, but it works =)
while (i > 0) and (s[i] in ['.', 'A'..'Z', 'a'..'z', '0'..'9']) do dec(i); while (i > 0) and (s[i] in ['.', 'A'..'Z', 'a'..'z', '0'..'9']) do dec(i);
@@ -342,7 +393,7 @@ end;
procedure WriteOutClassToHeader(cl : TClassDef; subs: TStrings; conststr: TStrings); procedure WriteOutClassToHeader(cl : TClassDef; subs: TStrings; conststr: TStrings);
var var
i : Integer; i : Integer;
j : Integer; // j : Integer;
s : AnsiString; s : AnsiString;
ss : AnsiString; ss : AnsiString;
mtd : TClassMethodDef; mtd : TClassMethodDef;
@@ -369,6 +420,32 @@ begin
subs.Add(''); subs.Add('');
end; end;
procedure ParseDefine(const s: AnsiString; var DefWhat, DefTo: AnsiString);
var
i : Integer;
begin
i := 1;
ScanWhile(s, i, [#9, #32, #10, #13]);
if i < length(s) then begin
DefWhat := ScanTo(s, i, [#9, #32, #10, #13]);
ScanWhile(s, i, [#9, #32]);
DefTo := Copy(s, i, length(s) - i + 1);
end else
DefTo := '';
end;
procedure WriteOutPrecompDefine(const Prec: TPrecompiler; Prefix: AnsiString; st: TStrings);
var
a, b: AnsiString;
begin
if Prec._Directive = '#define' then begin
ParseDefine(Prec._Params, a, b);
if b <> ''
then st.Add(Prefix + Format('%s = %s;', [a, b]))
else st.Add(Prefix + Format('{$define %s}', [a]));
end;
end;
procedure WriteOutPrecompInclude(Prec: TPrecompiler; st: TStrings); procedure WriteOutPrecompInclude(Prec: TPrecompiler; st: TStrings);
var var
dlph : AnsiString; dlph : AnsiString;
@@ -435,7 +512,7 @@ procedure MatchFixes(const Name: AnsiString; var prefix, postfix: AnsiString);
var var
i : integer; i : integer;
ni, pi: integer; ni, pi: integer;
nc, pc: AnsiChar; // nc, pc: AnsiChar;
begin begin
for i := 1 to Min(length(Name), length(prefix)) do for i := 1 to Min(length(Name), length(prefix)) do
if Name[i] <> prefix[i] then begin if Name[i] <> prefix[i] then begin
@@ -482,7 +559,7 @@ end;
procedure WriteOutEnumToHeader(enm: TEnumTypeDef; st: TStrings); procedure WriteOutEnumToHeader(enm: TEnumTypeDef; st: TStrings);
var var
i : Integer; // i : Integer;
s : AnsiString; s : AnsiString;
begin begin
if enm._Name = '' then s := EvaluateEnumName(enm) if enm._Name = '' then s := EvaluateEnumName(enm)
@@ -503,7 +580,7 @@ var
i : Integer; i : Integer;
cl : TClassDef; cl : TClassDef;
subs : TStringList; subs : TStringList;
s : AnsiString; // s : AnsiString;
consts : TStringList; consts : TStringList;
const const
SpacePrefix = ' '; SpacePrefix = ' ';
@@ -521,6 +598,7 @@ begin
WriteOutClassToHeader(cl, subs, consts); WriteOutClassToHeader(cl, subs, consts);
end else if (TObject(hdr.Items[i]) is TPrecompiler) then begin end else if (TObject(hdr.Items[i]) is TPrecompiler) then begin
WriteOutPrecompInclude(TPrecompiler(hdr.Items[i]), st); WriteOutPrecompInclude(TPrecompiler(hdr.Items[i]), st);
WriteOutPrecompDefine(TPrecompiler(hdr.Items[i]), ' ', subs);
end; end;
end; end;
@@ -559,13 +637,13 @@ end;
procedure WriteOutClassToClasses(cl: TClassDef; subs: TStrings); procedure WriteOutClassToClasses(cl: TClassDef; subs: TStrings);
var var
i : Integer; i : Integer;
cnt : Integer; // cnt : Integer;
s : AnsiString; s : AnsiString;
j : Integer; j : Integer;
obj : TObject; // or TEntity obj : TObject; // or TEntity
mtds : TStringList; // name of methods mtds : TStringList; // name of methods
over : TStringList; // overloaded names // over : TStringList; // overloaded names
const const
SpacePrefix = ' '; SpacePrefix = ' ';
begin begin
@@ -617,9 +695,9 @@ end;
procedure WriteOutClassesSection(hdr: TObjCHeader; st: TStrings); procedure WriteOutClassesSection(hdr: TObjCHeader; st: TStrings);
var var
i : integer; i : integer;
cl : TClassDef; // cl : TClassDef;
j : integer; // j : integer;
s : AnsiString; // s : AnsiString;
subs : TStringList; subs : TStringList;
begin begin
BeginSection('CLASSES', st); BeginSection('CLASSES', st);
@@ -627,7 +705,7 @@ begin
subs := TStringList.Create; subs := TStringList.Create;
try try
for i := 0 to hdr.Items.Count - 1 do for i := 0 to hdr.Items.Count - 1 do
if Assigned(hdr.Items[i]) then if Assigned(hdr.Items[i]) and (TObject(hdr.Items[i]) is TPrecompiler) then
WriteOutPrecompInclude(TPrecompiler(hdr.Items[i]), st); WriteOutPrecompInclude(TPrecompiler(hdr.Items[i]), st);
for i := 0 to hdr.Items.Count - 1 do for i := 0 to hdr.Items.Count - 1 do
@@ -653,7 +731,7 @@ var
begin begin
Result := false; Result := false;
for i := 0 to mtd.Items.Count - 1 do for i := 0 to mtd.Items.Count - 1 do
if TObject(mtd.Items[i]) is TParameterDef then begin if TObject(mtd.Items[i]) is TObjCParameterDef then begin
Result := true; Result := true;
Exit; Exit;
end; end;
@@ -665,7 +743,7 @@ const
procedure ObjCMethodToProcType(mtd: TClassMethodDef; var typeName: AnsiString; subs: TStrings); procedure ObjCMethodToProcType(mtd: TClassMethodDef; var typeName: AnsiString; subs: TStrings);
var var
i : integer; // i : integer;
s : AnsiString; s : AnsiString;
begin begin
typeName := MtdPrefix + mtd._Name + MtdPostFix; typeName := MtdPrefix + mtd._Name + MtdPostFix;
@@ -688,8 +766,8 @@ begin
if obj is TParamDescr then begin if obj is TParamDescr then begin
if vName <> '' then Result := Result + vname + ', '; if vName <> '' then Result := Result + vname + ', ';
vname := TParamDescr(obj)._Descr; vname := TParamDescr(obj)._Descr;
end else if obj is TParameterDef then begin end else if obj is TObjCParameterDef then begin
if vname = '' then vname := TParameterDef(obj)._Name; if vname = '' then vname := TObjCParameterDef(obj)._Name;
end; end;
end; end;
Result := Result + vname; Result := Result + vname;
@@ -702,7 +780,7 @@ var
res : Ansistring; res : Ansistring;
sp : AnsiString; sp : AnsiString;
s : AnsiString; s : AnsiString;
isConsts : Boolean; // isConsts : Boolean;
typeName : AnsiString; typeName : AnsiString;
begin begin
typeName := ''; typeName := '';
@@ -736,7 +814,7 @@ begin
subs.Add('begin'); subs.Add('begin');
subs.Add(Format(' vmethod := %s(@objc_msgSend);', [typeName])); subs.Add(Format(' vmethod := %s(@objc_msgSend);', [typeName]));
s := Format('vmethod(Handle, sel_registerName(PChar(Str_%s)), %s)', [mtd._Name, GetParamsNames(mtd)]); s := Format('vmethod(Handle, sel_registerName(PChar(Str_%s)), %s)', [mtd._Name, GetParamsNames(mtd)]);
if ObjCToDelphiType(mtd.GetResultType._TypeName) <> '' then if ObjCToDelphiType(mtd.GetResultType._Name, mtd.GetResultType._IsPointer) <> '' then
s := 'Result := ' + s; s := 'Result := ' + s;
s := s + ';'; s := s + ';';
subs.Add(' ' + s); subs.Add(' ' + s);
@@ -814,46 +892,84 @@ begin
Result := true; Result := true;
end; end;
procedure FixAppleCategories(Items: TList; category: TClassDef);
var
i : Integer;
j : Integer;
cl : TClassdef;
begin
for i := 0 to Items.Count - 1 do
if TObject(Items[i]) is TClassDef then begin
cl := TClassDef(Items[i]);
if cl._SuperClass <> '' then
for j := 0 to category.Items.Count - 1 do begin
cl.Items.Add(category.Items[j]);
TEntity(category.Items[j]).owner := cl;
end; {of if}
end; {of if}
end;
procedure AppleHeaderFix(ent : TEntity); procedure AppleHeaderFix(ent : TEntity);
var var
i : Integer; i : Integer;
j : Integer;
obj : TEntity; obj : TEntity;
begin begin
i := 0; // i := 0;
while i < ent.Items.Count do begin for i := 0 to ent.Items.Count - 1 do begin
obj := TEntity(ent.Items[i]); obj := TEntity(ent.Items[i]);
if obj is TTypeNameDef then begin if (obj is TTypeNameDef) and (AppleEnumType(ent.Items, i)) then begin
if AppleEnumType(ent.Items, i) then ent.Items[i] := nil;
ent.Items.Delete(i) obj.Free;
else end else if (obj is TClassDef) and (TClassDef(obj)._SuperClass = '') then begin
inc(i); FixAppleCategories(ent.Items, TClassDef(obj));
end else ent.Items[i] := nil;
inc(i) obj.Free;
end else if (obj is TParamDescr) then begin
if IsPascalReserved(TParamDescr(obj)._Descr) then
TParamDescr(obj)._Descr := '_'+TParamDescr(obj)._Descr;
end else if (obj is TObjCParameterDef) then begin
if IsPascalReserved(TObjCParameterDef(obj)._Name) then
TObjCParameterDef(obj)._Name := '_' + TObjCParameterDef(obj)._Name;
end;
end; end;
j := 0;
for i := 0 to ent.Items.Count - 1 do
if Assigned(ent.Items[i]) then begin
ent.Items[j] := ent.Items[i];
inc(j);
end;
ent.Items.Count := j;
for i := 0 to ent.Items.Count - 1 do for i := 0 to ent.Items.Count - 1 do
AppleHeaderFix( TEntity(ent.Items[i])); AppleHeaderFix( TEntity(ent.Items[i]));
end; end;
procedure WriteOutIncludeFile(hdr: TObjCHeader; st: TStrings); procedure WriteOutIncludeFile(hdr: TObjCHeader; st: TStrings);
var var
i : integer; // i : integer;
cmt : TComment; cmt : TComment;
begin begin
if hdr.Items.Count <= 0 then Exit; try
AppleHeaderFix(hdr); if hdr.Items.Count <= 0 then Exit;
AppleHeaderFix(hdr);
// .inc header-comment is the first comment entity in .h file , if any // .inc header-comment is the first comment entity in .h file , if any
if TObject(hdr.Items[0]) is TComment then begin if TObject(hdr.Items[0]) is TComment then begin
cmt := TComment(hdr.Items[0]); cmt := TComment(hdr.Items[0]);
st.Add('(*' + cmt._Comment + '*)'); st.Add('(*' + cmt._Comment + '*)');
cmt.Free; cmt.Free;
hdr.Items.Delete(0); hdr.Items.Delete(0);
end;
WriteOutHeaderSection(hdr, st);
WriteOutClassesSection(hdr, st);
WriteOutImplementationSection(hdr, st);
except
end; end;
WriteOutHeaderSection(hdr, st);
WriteOutClassesSection(hdr, st);
WriteOutImplementationSection(hdr, st);
end; end;
end. end.