mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-10-19 19:31:41 +02:00
852 lines
24 KiB
ObjectPascal
852 lines
24 KiB
ObjectPascal
{
|
|
pas2jni - JNI bridge generator for Pascal.
|
|
|
|
Copyright (c) 2013 by Yury Sidorov.
|
|
|
|
This program is free software; you can redistribute it and/or modify
|
|
it under the terms of the GNU General Public License as published by
|
|
the Free Software Foundation; either version 2 of the License, or
|
|
(at your option) any later version.
|
|
|
|
This program is distributed in the hope that it will be useful,
|
|
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
GNU General Public License for more details.
|
|
|
|
You should have received a copy of the GNU General Public License
|
|
along with this program; if not, write to the Free Software
|
|
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
|
|
|
|
****************************************************************************}
|
|
|
|
unit ppuparser;
|
|
|
|
{$mode objfpc}{$H+}
|
|
|
|
interface
|
|
|
|
uses
|
|
Classes, SysUtils, def;
|
|
|
|
type
|
|
TCheckItemResult = (crDefault, crInclude, crExclude);
|
|
TOnCheckItem = function (const ItemName: string): TCheckItemResult of object;
|
|
|
|
{ TPPUParser }
|
|
TPPUParser = class
|
|
private
|
|
FOnCheckItem: TOnCheckItem;
|
|
function FindUnit(const AName: string): string;
|
|
procedure ReadUnit(const AName: string; Lines: TStrings);
|
|
function InternalParse(const AUnitName: string): TUnitDef;
|
|
public
|
|
SearchPath: TStringList;
|
|
Units: TDef;
|
|
|
|
constructor Create(const ASearchPath: string);
|
|
destructor Destroy; override;
|
|
procedure Parse(const AUnitName: string);
|
|
property OnCheckItem: TOnCheckItem read FOnCheckItem write FOnCheckItem;
|
|
end;
|
|
|
|
var
|
|
ppudumpprog: string = 'ppudump';
|
|
|
|
implementation
|
|
|
|
uses process, pipes;
|
|
|
|
type
|
|
TCharSet = set of char;
|
|
|
|
function WordPosition(const N: Integer; const S: string;
|
|
const WordDelims: TCharSet): Integer;
|
|
var
|
|
Count, I: Integer;
|
|
begin
|
|
Count := 0;
|
|
I := 1;
|
|
Result := 0;
|
|
while (I <= Length(S)) and (Count <> N) do
|
|
begin
|
|
{ skip over delimiters }
|
|
while (I <= Length(S)) and (S[I] in WordDelims) do
|
|
Inc(I);
|
|
{ if we're not beyond end of S, we're at the start of a word }
|
|
if I <= Length(S) then
|
|
Inc(Count);
|
|
{ if not finished, find the end of the current word }
|
|
if Count <> N then
|
|
while (I <= Length(S)) and not (S[I] in WordDelims) do
|
|
Inc(I)
|
|
else
|
|
Result := I;
|
|
end;
|
|
end;
|
|
|
|
function ExtractWord(N: Integer; const S: string;
|
|
const WordDelims: TCharSet): string;
|
|
var
|
|
I: Integer;
|
|
Len: Integer;
|
|
begin
|
|
Len := 0;
|
|
I := WordPosition(N, S, WordDelims);
|
|
if I <> 0 then
|
|
{ find the end of the current word }
|
|
while (I <= Length(S)) and not (S[I] in WordDelims) do
|
|
begin
|
|
{ add the I'th character to result }
|
|
Inc(Len);
|
|
SetLength(Result, Len);
|
|
Result[Len] := S[I];
|
|
Inc(I);
|
|
end;
|
|
SetLength(Result, Len);
|
|
end;
|
|
|
|
{ TPPUParser }
|
|
|
|
constructor TPPUParser.Create(const ASearchPath: string);
|
|
var
|
|
i, j: integer;
|
|
s, d: string;
|
|
sr: TSearchRec;
|
|
begin
|
|
SearchPath:=TStringList.Create;
|
|
SearchPath.Delimiter:=';';
|
|
SearchPath.DelimitedText:=ASearchPath;
|
|
i:=0;
|
|
while i < SearchPath.Count do begin
|
|
s:=SearchPath[i];
|
|
if (Pos('*', s) > 0) or (Pos('?', s) > 0) then begin
|
|
d:=ExtractFilePath(s);
|
|
j:=FindFirst(s, faDirectory, sr);
|
|
while j = 0 do begin
|
|
if (sr.Name <> '.') and (sr.Name <> '..') then
|
|
SearchPath.Add(d + sr.Name);
|
|
j:=FindNext(sr);
|
|
end;
|
|
FindClose(sr);
|
|
SearchPath.Delete(i);
|
|
end
|
|
else
|
|
Inc(i);
|
|
end;
|
|
Units:=TDef.Create(nil, dtNone);
|
|
end;
|
|
|
|
destructor TPPUParser.Destroy;
|
|
begin
|
|
Units.Free;
|
|
SearchPath.Free;
|
|
inherited Destroy;
|
|
end;
|
|
|
|
procedure TPPUParser.Parse(const AUnitName: string);
|
|
begin
|
|
InternalParse(AUnitName);
|
|
end;
|
|
|
|
function TPPUParser.FindUnit(const AName: string): string;
|
|
var
|
|
i: integer;
|
|
fn: string;
|
|
begin
|
|
fn:=ChangeFileExt(LowerCase(AName), '.ppu');
|
|
if FileExists(fn) then begin
|
|
Result:=fn;
|
|
exit;
|
|
end;
|
|
for i:=0 to SearchPath.Count - 1 do begin
|
|
Result:=IncludeTrailingPathDelimiter(SearchPath[i]) + fn;
|
|
if FileExists(Result) then
|
|
exit;
|
|
end;
|
|
raise Exception.CreateFmt('Unable to find PPU file for unit "%s".', [AName]);
|
|
end;
|
|
|
|
procedure TPPUParser.ReadUnit(const AName: string; Lines: TStrings);
|
|
var
|
|
p: TProcess;
|
|
s, un: ansistring;
|
|
i, j: integer;
|
|
begin
|
|
un:=FindUnit(AName);
|
|
p:=TProcess.Create(nil);
|
|
try
|
|
p.Executable:=ppudumpprog;
|
|
p.Parameters.Add(un);
|
|
p.Options:=[poUsePipes, poNoConsole, poStderrToOutPut];
|
|
p.ShowWindow:=swoHIDE;
|
|
p.StartupOptions:=[suoUseShowWindow];
|
|
try
|
|
p.Execute;
|
|
except
|
|
raise Exception.CreateFmt('Unable to run "%s".'+LineEnding+'%s', [p.Executable, Exception(ExceptObject).Message]);
|
|
end;
|
|
s:='';
|
|
repeat
|
|
with p.Output do
|
|
while NumBytesAvailable > 0 do begin
|
|
i:=NumBytesAvailable;
|
|
j:=Length(s);
|
|
SetLength(s, j + i);
|
|
ReadBuffer(s[j + 1], i);
|
|
end;
|
|
until not p.Running;
|
|
if p.ExitStatus <> 0 then begin
|
|
if Length(s) > 300 then
|
|
s:='';
|
|
raise Exception.CreateFmt('Error reading contents of unit "%s" using "%s".'+LineEnding+'Error code: %d'+LineEnding+'%s', [un, ppudumpprog, p.ExitStatus, s]);
|
|
end;
|
|
finally
|
|
p.Free;
|
|
end;
|
|
Lines.Text:=s;
|
|
{$ifopt D+}
|
|
// Lines.SaveToFile(AName + '-dump.txt');
|
|
{$endif}
|
|
end;
|
|
|
|
const
|
|
LInc = 4;
|
|
SDefId = '** Definition Id ';
|
|
SSymId = '** Symbol Id ';
|
|
|
|
function TPPUParser.InternalParse(const AUnitName: string): TUnitDef;
|
|
var
|
|
FLines: TStringList;
|
|
deref: array of TUnitDef;
|
|
CurUnit: TUnitDef;
|
|
CurDef: TDef;
|
|
level, skiplevel: integer;
|
|
IsSystemUnit: boolean;
|
|
AMainUnit: boolean;
|
|
|
|
function _ThisLevel(const s: string): boolean;
|
|
var
|
|
i: integer;
|
|
begin
|
|
Result:=True;
|
|
if (level = 1) or (Length(s) < level - LInc) then
|
|
exit;
|
|
if s[1] = '-' then begin
|
|
Result:=False;
|
|
exit;
|
|
end;
|
|
i:=level;
|
|
repeat
|
|
Dec(i, LInc);
|
|
if Copy(s, i, 3) = '** ' then begin
|
|
Result:=False;
|
|
exit;
|
|
end;
|
|
until i = 1;
|
|
end;
|
|
|
|
function _GetDef(const Path: string; ExpectedClass: TDefClass = nil): TDef;
|
|
var
|
|
s, ss: string;
|
|
i, j: integer;
|
|
u: TUnitDef;
|
|
begin
|
|
Result:=nil;
|
|
u:=CurUnit;
|
|
s:=Trim(Path);
|
|
if Copy(s, 1, 1) = '(' then begin
|
|
i:=Pos(') ', s);
|
|
if i > 0 then
|
|
Delete(s, 1, i + 1);
|
|
end;
|
|
i:=1;
|
|
while True do begin
|
|
ss:=Trim(ExtractWord(i, s, [',']));
|
|
if ss = '' then
|
|
break;
|
|
if Pos('Unit', ss) = 1 then begin
|
|
j:=StrToInt(Copy(ss, 6, MaxInt));
|
|
u:=deref[j];
|
|
if u.DefType = dtNone then begin
|
|
// Reading unit
|
|
u:=InternalParse(LowerCase(u.Name));
|
|
if u = nil then
|
|
exit;
|
|
if u.CPU <> CurUnit.CPU then
|
|
raise Exception.CreateFmt('Invalid target CPU of unit "%s": %s', [u.Name, u.CPU]);
|
|
if u.OS <> CurUnit.OS then
|
|
raise Exception.CreateFmt('Invalid target OS of unit "%s": %s', [u.Name, u.OS]);
|
|
if u.PPUVer <> CurUnit.PPUVer then
|
|
raise Exception.CreateFmt('Invalid PPU version of unit "%s": %s', [u.Name, u.PPUVer]);
|
|
deref[j].Free;
|
|
deref[j]:=u;
|
|
end;
|
|
end
|
|
else
|
|
if Pos('DefId', ss) = 1 then begin
|
|
j:=StrToInt(Copy(ss, 7, MaxInt));
|
|
Result:=u.FindDef(j);
|
|
if Result = nil then begin
|
|
if ExpectedClass <> nil then
|
|
Result:=ExpectedClass.Create(u, dtNone)
|
|
else
|
|
Result:=TDef.Create(u, dtNone);
|
|
Result.DefId:=j;
|
|
end;
|
|
break;
|
|
end;
|
|
Inc(i);
|
|
end;
|
|
if (ExpectedClass <> nil) and (Result <> nil) then
|
|
if (Result.DefType <> dtNone) and not (Result is ExpectedClass) then
|
|
raise Exception.CreateFmt('Unexpected class. Expected: %s, got: %s', [ExpectedClass.ClassName, Result.ClassName]);
|
|
end;
|
|
|
|
function _ReadSym(var idx: integer; ParentDef: TDef): TDef;
|
|
var
|
|
s, ss, name: string;
|
|
id: integer;
|
|
i, j: integer;
|
|
d: TDef;
|
|
begin
|
|
Result:=nil;
|
|
// symvol id
|
|
s:=Trim(FLines[idx]);
|
|
id:=StrToInt(ExtractWord(4, s, [' ']));
|
|
Inc(idx);
|
|
s:=Trim(FLines[idx]);
|
|
if Pos('Property', s) = 1 then begin
|
|
name:=Trim(Copy(s, 10, MaxInt));
|
|
Result:=TVarDef.Create(nil, dtProp);
|
|
TVarDef(Result).VarOpt:=[];
|
|
end
|
|
else begin
|
|
i:=Pos('symbol', s);
|
|
if i = 0 then
|
|
exit;
|
|
name:=Trim(Copy(s, i + 7, MaxInt));
|
|
if Copy(name, 1, 1) = '$' then
|
|
exit;
|
|
|
|
s:=LowerCase(Trim(Copy(s, 1, i - 1)));
|
|
if s = 'field variable' then
|
|
Result:=TVarDef.Create(nil, dtField)
|
|
else
|
|
if s = 'global variable' then
|
|
Result:=TVarDef.Create(nil, dtVar)
|
|
else
|
|
if s = 'parameter variable' then begin
|
|
Result:=TVarDef.Create(nil, dtParam);
|
|
TVarDef(Result).VarOpt:=[voRead];
|
|
end
|
|
else
|
|
if s = 'enumeration' then begin
|
|
if ParentDef = CurUnit then
|
|
exit;
|
|
Result:=TConstDef.Create(nil, dtConst);
|
|
TConstDef(Result).VarType:=ParentDef;
|
|
end
|
|
else
|
|
if s = 'constant' then begin
|
|
Result:=TConstDef.Create(nil, dtConst);
|
|
end
|
|
|
|
else
|
|
if (s = 'procedure') or (s = 'type') then
|
|
Result:=nil
|
|
else
|
|
exit;
|
|
end;
|
|
|
|
if Result <> nil then begin
|
|
Result.Name:=name;
|
|
Result.SymId:=id;
|
|
end;
|
|
|
|
Inc(level, LInc);
|
|
skiplevel:=level;
|
|
Inc(idx);
|
|
while idx < FLines.Count do begin
|
|
s:=FLines[idx];
|
|
if not _ThisLevel(s) or (Copy(Trim(s), 1, 3) = '---') then begin
|
|
Dec(idx);
|
|
break;
|
|
end;
|
|
|
|
if Pos('Visibility :', s) > 0 then begin
|
|
s:=LowerCase(Trim(ExtractWord(2, s, [':'])));
|
|
if (s <> 'public') and (s <> 'published') then begin
|
|
FreeAndNil(Result);
|
|
exit;
|
|
end;
|
|
end
|
|
else
|
|
if (Pos('Definition :', s) > 0) or (Pos('Result Type :', s) > 0) then begin
|
|
if (Result = nil) or (Result.DefType <> dtConst) then begin
|
|
s:=Trim(ExtractWord(2, s, [':']));
|
|
d:=_GetDef(s);
|
|
if (d <> nil) and (d.Name = '') then begin
|
|
if (d.DefType = dtProc) and (TProcDef(d).ProcType = ptConstructor) and (CompareText(name, 'create') = 0) then
|
|
name:='Create'; // fix char case for standard constructors
|
|
d.Name:=name;
|
|
d.SymId:=id;
|
|
end;
|
|
end
|
|
end
|
|
else
|
|
if Pos('Options :', s) > 0 then begin
|
|
s:=LowerCase(Trim(ExtractWord(2, s, [':'])));
|
|
if Pos('hidden', s) > 0 then begin
|
|
FreeAndNil(Result);
|
|
exit;
|
|
end;
|
|
end
|
|
else
|
|
if Result <> nil then
|
|
case Result.DefType of
|
|
dtVar, dtField, dtProp, dtParam:
|
|
if (Pos('Var Type :', s) > 0) or (Pos('Prop Type :', s) > 0) then begin
|
|
s:=Trim(ExtractWord(2, s, [':']));
|
|
TVarDef(Result).VarType:=_GetDef(s);
|
|
end
|
|
else
|
|
if Pos('access :', s) > 0 then begin
|
|
if Pos('Sym:', Trim(FLines[idx+1])) = 1 then begin
|
|
d:=nil;
|
|
ss:=Trim(ExtractWord(2, s, [':']));
|
|
if Pos('Nil', ss) = 0 then
|
|
d:=_GetDef(ss, TProcDef);
|
|
with TVarDef(Result) do
|
|
if Pos('Readaccess :', s) > 0 then begin
|
|
VarOpt:=VarOpt + [voRead];
|
|
if (d <> nil) and (d.Count = 1) then
|
|
IndexType:=TVarDef(d[0]).VarType;
|
|
end
|
|
else
|
|
if Pos('Writeaccess :', s) > 0 then begin
|
|
VarOpt:=VarOpt + [voWrite];
|
|
if (d <> nil) and (d.Count = 2) then
|
|
IndexType:=TVarDef(d[0]).VarType;
|
|
end;
|
|
end;
|
|
end
|
|
else
|
|
if Pos('Spez :', s) > 0 then begin
|
|
with TVarDef(Result) do begin
|
|
s:=LowerCase(Trim(ExtractWord(2, s, [':'])));
|
|
if s = 'out' then
|
|
VarOpt:=[voWrite, voOut]
|
|
else
|
|
if s = 'var' then
|
|
VarOpt:=[voRead, voWrite, voVar]
|
|
else
|
|
if s = 'const' then
|
|
VarOpt:=[voRead, voConst];
|
|
end;
|
|
end;
|
|
|
|
dtConst:
|
|
begin
|
|
j:=Pos('Value :', s);
|
|
if j > 0 then begin
|
|
Inc(j, 6);
|
|
ss:=Trim(Copy(s, j + 1, MaxInt));
|
|
if Copy(ss, 1, 1) = '"' then begin
|
|
Delete(ss, 1, 1);
|
|
i:=level - LInc;
|
|
while True do begin
|
|
Inc(idx);
|
|
if idx >= FLines.Count then
|
|
break;
|
|
s:=FLines[idx];
|
|
if (Copy(s, i, 3) = '** ') or (Copy(s, j, 1) = ':') then
|
|
break;
|
|
ss:=ss + #10 + s;
|
|
end;
|
|
Dec(idx);
|
|
Delete(ss, Length(ss), 1);
|
|
ss:=StringReplace(ss, '\', '\\', [rfReplaceAll]);
|
|
ss:=StringReplace(ss, '"', '\"', [rfReplaceAll]);
|
|
ss:=StringReplace(ss, #10, '\n', [rfReplaceAll]);
|
|
ss:='"' + ss + '"';
|
|
end;
|
|
TConstDef(Result).Value:=ss;
|
|
end
|
|
else
|
|
if Pos('OrdinalType :', s) > 0 then begin
|
|
s:=Trim(ExtractWord(2, s, [':']));
|
|
TConstDef(Result).VarType:=_GetDef(s);
|
|
end
|
|
else
|
|
if Pos('Set Type :', s) > 0 then begin
|
|
// s:=Trim(ExtractWord(2, s, [':']));
|
|
// TConstDef(Result).VarType:=_GetDef(s);
|
|
FreeAndNil(Result);
|
|
exit;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
Inc(idx);
|
|
end;
|
|
|
|
if Result <> nil then
|
|
ParentDef.Add(Result);
|
|
end;
|
|
|
|
procedure _RemoveCurDef;
|
|
var
|
|
d: TDef;
|
|
begin
|
|
d:=CurDef;
|
|
CurDef:=CurDef.Parent;
|
|
d.Free;
|
|
skiplevel:=level;
|
|
end;
|
|
|
|
var
|
|
s: ansistring;
|
|
i, j: integer;
|
|
dd: TDef;
|
|
HdrRead: boolean;
|
|
begin
|
|
Result:=nil;
|
|
for i:=0 to Units.Count - 1 do
|
|
if CompareText(Units[i].Name, AUnitName) = 0 then begin
|
|
Result:=TUnitDef(Units[i]);
|
|
exit;
|
|
end;
|
|
|
|
AMainUnit:=FOnCheckItem(AUnitName) = crInclude;
|
|
|
|
if not AMainUnit and ( (CompareText(AUnitName, 'windows') = 0) or (CompareText(AUnitName, 'unix') = 0) ) then begin
|
|
Result:=nil;
|
|
exit;
|
|
end;
|
|
|
|
FLines:=TStringList.Create;
|
|
try
|
|
ReadUnit(AUnitName, FLines);
|
|
|
|
IsSystemUnit:=CompareText(AUnitName, 'system') = 0;
|
|
|
|
Result:=TUnitDef.Create(nil, dtUnit);
|
|
Units.Add(Result);
|
|
CurUnit:=Result;
|
|
SetLength(deref, 0);
|
|
CurDef:=Result;
|
|
level:=1;
|
|
skiplevel:=0;
|
|
i:=-1;
|
|
HdrRead:=False;
|
|
while True do begin
|
|
Inc(i);
|
|
if i >= FLines.Count then
|
|
break;
|
|
s:=FLines[i];
|
|
|
|
if s = 'Implementation symtable' then
|
|
break;
|
|
|
|
if not HdrRead then begin
|
|
if Trim(s) = 'Interface symtable' then begin
|
|
HdrRead:=True;
|
|
continue;
|
|
end;
|
|
|
|
if Pos('Analyzing', s) = 1 then begin
|
|
j:=Pos('(v', s);
|
|
if j > 0 then
|
|
Result.PPUVer:=StrToInt(Copy(s, j + 2, Length(s) - j - 2));
|
|
end
|
|
else
|
|
if Pos('Target processor', s) = 1 then
|
|
Result.CPU:=Trim(ExtractWord(2, s, [':']))
|
|
else
|
|
if Pos('Target operating system', s) = 1 then
|
|
Result.OS:=Trim(ExtractWord(2, s, [':']))
|
|
else
|
|
if Pos('Interface Checksum', s) = 1 then
|
|
Result.IntfCRC:=Trim(ExtractWord(2, s, [':']))
|
|
else
|
|
if (Pos('Module Name:', s) = 1) and (Result.Name = '') then begin
|
|
Result.Name:=Trim(ExtractWord(2, s, [':']));
|
|
continue;
|
|
end
|
|
else
|
|
if Pos('DerefMap[', s) = 1 then begin
|
|
s:=Trim(ExtractWord(2, s, ['=']));
|
|
j:=Length(deref);
|
|
SetLength(deref, j + 1);
|
|
deref[j]:=TUnitDef.Create(nil, dtNone);
|
|
deref[j].Name:=s;
|
|
continue;
|
|
end;
|
|
end;
|
|
|
|
while not _ThisLevel(s) do begin
|
|
if skiplevel = 0 then
|
|
CurDef:=CurDef.Parent;
|
|
Dec(level, LInc);
|
|
skiplevel:=0;
|
|
end;
|
|
|
|
if level = skiplevel then
|
|
continue; // Skipping not supported entries
|
|
|
|
// Definition
|
|
j:=Pos(SDefId, s);
|
|
if j > 0 then begin
|
|
Inc(level, LInc);
|
|
// def id
|
|
j:=StrToInt(Copy(s, j + Length(SDefId), Length(s) - (j + Length(SDefId)) - 2));
|
|
Inc(i);
|
|
s:=FLines[i];
|
|
if Pos('definition', s) = 0 then begin
|
|
skiplevel:=level;
|
|
continue;
|
|
end;
|
|
s:=LowerCase(Trim(ExtractWord(1, s, [' '])));
|
|
dd:=nil;
|
|
if s = 'object/class' then
|
|
dd:=TClassDef.Create(CurDef, dtClass)
|
|
else
|
|
if s = 'record' then
|
|
dd:=TRecordDef.Create(CurDef, dtRecord)
|
|
else
|
|
if s = 'procedure' then
|
|
dd:=TProcDef.Create(CurDef, dtProc)
|
|
else
|
|
if s = 'ordinal' then begin
|
|
dd:=TTypeDef.Create(CurDef, dtType);
|
|
TTypeDef(dd).BasicType:=btLongInt;
|
|
end
|
|
else
|
|
if Pos('string', s) > 0 then begin
|
|
dd:=TTypeDef.Create(CurDef, dtType);
|
|
dd.Name:=s;
|
|
if (s = 'widestring') or (s = 'unicodestring') then
|
|
TTypeDef(dd).BasicType:=btWideString
|
|
else
|
|
TTypeDef(dd).BasicType:=btString;
|
|
end
|
|
else
|
|
if s = 'float' then begin
|
|
dd:=TTypeDef.Create(CurDef, dtType);
|
|
TTypeDef(dd).BasicType:=btDouble;
|
|
end
|
|
else
|
|
if s = 'enumeration' then begin
|
|
dd:=TTypeDef.Create(CurDef, dtEnum);
|
|
TTypeDef(dd).BasicType:=btEnum;
|
|
end
|
|
else
|
|
if s = 'pointer' then begin
|
|
dd:=TTypeDef.Create(CurDef, dtType);
|
|
TTypeDef(dd).BasicType:=btPointer;
|
|
end
|
|
else
|
|
if s = 'procedural' then begin
|
|
dd:=TProcDef.Create(CurDef, dtProcType);
|
|
TProcDef(dd).ProcType:=ptProcedure;
|
|
end
|
|
else
|
|
if s = 'set' then begin
|
|
dd:=TSetDef.Create(CurDef, dtSet);
|
|
end
|
|
else
|
|
skiplevel:=level;
|
|
if dd <> nil then begin
|
|
CurDef:=dd;
|
|
CurDef.DefId:=j;
|
|
end;
|
|
continue;
|
|
end;
|
|
|
|
// Symbol
|
|
if Pos(SSymId, s) > 0 then begin
|
|
dd:=_ReadSym(i, CurDef);
|
|
continue;
|
|
end;
|
|
|
|
if CurDef <> nil then
|
|
case CurDef.DefType of
|
|
dtClass:
|
|
begin
|
|
if Pos('Type :', Trim(s)) = 1 then begin
|
|
s:=LowerCase(Trim(ExtractWord(2, s, [':'])));
|
|
if CurDef.DefId = 0 then
|
|
s:=s;
|
|
if s <> 'class' then
|
|
_RemoveCurDef;
|
|
end
|
|
else
|
|
if Pos('Ancestor Class :', s) > 0 then begin
|
|
s:=Trim(ExtractWord(2, s, [':']));
|
|
TClassDef(CurDef).AncestorClass:=TClassDef(_GetDef(s, TClassDef));
|
|
end
|
|
end;
|
|
dtRecord:
|
|
begin
|
|
if IsSystemUnit and (Pos('Name of Record :', s) > 0) then begin
|
|
s:=Trim(ExtractWord(2, s, [':']));
|
|
if CompareText(s, 'tguid') = 0 then begin
|
|
dd:=TTypeDef.Create(CurUnit, dtType);
|
|
TTypeDef(dd).BasicType:=btGuid;
|
|
dd.DefId:=CurDef.DefId;
|
|
CurDef.Free;
|
|
CurDef:=dd;
|
|
end;
|
|
end
|
|
else
|
|
if Pos('DataSize :', s) > 0 then begin
|
|
s:=Trim(ExtractWord(2, s, [':']));
|
|
TRecordDef(CurDef).Size:=StrToInt(s);
|
|
end;
|
|
end;
|
|
dtProc, dtProcType:
|
|
begin
|
|
s:=Trim(s);
|
|
if Pos('TypeOption :', s) = 1 then begin
|
|
s:=LowerCase(Trim(ExtractWord(2, s, [':'])));
|
|
with TProcDef(CurDef) do
|
|
if s = 'procedure' then
|
|
ProcType:=ptProcedure
|
|
else
|
|
if s = 'function' then
|
|
ProcType:=ptFunction
|
|
else
|
|
if s = 'constructor' then
|
|
ProcType:=ptConstructor
|
|
else
|
|
if s = 'destructor' then
|
|
ProcType:=ptDestructor;
|
|
end
|
|
else
|
|
if Pos('Return type :', s) = 1 then begin
|
|
s:=Trim(ExtractWord(2, s, [':']));
|
|
with TProcDef(CurDef) do begin
|
|
ReturnType:=_GetDef(s);
|
|
if (CurDef.DefType = dtProcType) and not ( (ReturnType is TTypeDef) and (TTypeDef(ReturnType).BasicType = btVoid) ) then
|
|
ProcType:=ptFunction;
|
|
end;
|
|
end
|
|
else
|
|
if Pos('Visibility :', s) = 1 then begin
|
|
s:=LowerCase(Trim(ExtractWord(2, s, [':'])));
|
|
if (s <> 'public') and (s <> 'published') then
|
|
CurDef.IsPrivate:=True;
|
|
end
|
|
else
|
|
if Pos('Options :', s) = 1 then begin
|
|
s:=LowerCase(Trim(ExtractWord(2, s, [':'])));
|
|
with TProcDef(CurDef) do begin
|
|
if Pos('overridingmethod', s) > 0 then begin
|
|
ProcOpt:=ProcOpt + [poOverride];
|
|
if ProcType <> ptConstructor then
|
|
CurDef.IsPrivate:=True;
|
|
end;
|
|
if Pos('overload', s) > 0 then
|
|
ProcOpt:=ProcOpt + [poOverload];
|
|
if Pos('methodpointer', s) > 0 then
|
|
ProcOpt:=ProcOpt + [poMethodPtr];
|
|
|
|
if (CurDef.Parent.DefType = dtClass) and (Pos('abstractmethod', s) > 0) then
|
|
TClassDef(CurDef.Parent).HasAbstractMethods:=True;
|
|
end;
|
|
end;
|
|
end;
|
|
dtType:
|
|
with TTypeDef(CurDef) do
|
|
if Pos('Base type :', s) > 0 then begin
|
|
s:=LowerCase(Trim(ExtractWord(2, s, [':'])));
|
|
if Pos('bool', s) = 1 then
|
|
BasicType:=btBoolean
|
|
else
|
|
if s = 'u8bit' then
|
|
BasicType:=btByte
|
|
else
|
|
if s = 's8bit' then
|
|
BasicType:=btShortInt
|
|
else
|
|
if s = 'u16bit' then
|
|
BasicType:=btWord
|
|
else
|
|
if s = 's16bit' then
|
|
BasicType:=btSmallInt
|
|
else
|
|
if s = 'u32bit' then
|
|
BasicType:=btLongWord
|
|
else
|
|
if s = 's32bit' then
|
|
BasicType:=btLongInt
|
|
else
|
|
if (s = 'u64bit') or (s = 's64bit') then
|
|
BasicType:=btInt64
|
|
else
|
|
if s = 'uvoid' then
|
|
BasicType:=btVoid
|
|
else
|
|
if s = 'uchar' then
|
|
BasicType:=btChar
|
|
else
|
|
if s = 'uwidechar' then
|
|
BasicType:=btWideChar;
|
|
end
|
|
else
|
|
if Pos('Float type :', s) > 0 then begin
|
|
s:=Trim(ExtractWord(2, s, [':']));
|
|
if s = '0' then
|
|
BasicType:=btSingle;
|
|
end
|
|
else
|
|
if Pos('Range :', s) > 0 then begin
|
|
s:=LowerCase(Trim(ExtractWord(2, s, [':'])));
|
|
if s = '0 to 1' then
|
|
BasicType:=btBoolean;
|
|
end;
|
|
dtSet:
|
|
with TSetDef(CurDef) do
|
|
if Pos('Size :', s) > 0 then
|
|
Size:=StrToInt(Trim(ExtractWord(2, s, [':'])))
|
|
else
|
|
if Pos('Set Base :', s) > 0 then
|
|
Base:=StrToInt(Trim(ExtractWord(2, s, [':'])))
|
|
else
|
|
if Pos('Set Max :', s) > 0 then
|
|
ElMax:=StrToInt(Trim(ExtractWord(2, s, [':'])))
|
|
else
|
|
if Pos('Element type :', s) > 0 then
|
|
ElType:=TTypeDef(_GetDef(Trim(ExtractWord(2, s, [':'])), TTypeDef))
|
|
else
|
|
if Pos('Type symbol :', s) > 0 then begin
|
|
s:=LowerCase(Trim(ExtractWord(2, s, [':'])));
|
|
if Trim(ExtractWord(2, s, [' '])) = 'nil' then
|
|
_RemoveCurDef;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
Result.ResolveDefs;
|
|
|
|
if AMainUnit then
|
|
Result.IsUsed:=True;
|
|
|
|
SetLength(Result.UsedUnits, Length(deref));
|
|
j:=0;
|
|
for i:=0 to High(deref) do
|
|
if deref[i].DefType = dtNone then
|
|
deref[i].Free
|
|
else begin
|
|
Result.UsedUnits[j]:=deref[i];
|
|
Inc(j);
|
|
end;
|
|
SetLength(Result.UsedUnits, j);
|
|
finally
|
|
FLines.Free;
|
|
end;
|
|
end;
|
|
|
|
end.
|
|
|