|
|
|
@@ -0,0 +1,851 @@ |
|
|
|
unit HeaderGenerator; |
|
|
|
|
|
|
|
{$mode objfpc}{$H+} |
|
|
|
|
|
|
|
interface |
|
|
|
|
|
|
|
uses |
|
|
|
Classes, SysUtils, DOM, fgl, variants; |
|
|
|
|
|
|
|
type |
|
|
|
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// |
|
|
|
THeaderGenerator = class(TObject) |
|
|
|
private type |
|
|
|
TvkObjectType = ( |
|
|
|
otUnknown, |
|
|
|
otType, |
|
|
|
otHandle, |
|
|
|
otFuncPtr, |
|
|
|
otStruct, |
|
|
|
otEnum, |
|
|
|
otCommand); |
|
|
|
TvkObjectTypes = set of TvkObjectType; |
|
|
|
|
|
|
|
TvkObject = class; |
|
|
|
TvkObjectList = class(specialize TFPGObjectList<TvkObject>) |
|
|
|
public |
|
|
|
function FindObj(const aName: DOMstring; const aTypes: TvkObjectTypes; out aObject): Boolean; |
|
|
|
procedure MarkObj(const aName: DOMstring; const aTypes: TvkObjectTypes; const aMark: Integer); |
|
|
|
end; |
|
|
|
|
|
|
|
//////////////////////////////////////////////////////////////////////////////////////////// |
|
|
|
TvkObject = class(TObject) |
|
|
|
private |
|
|
|
fType: TvkObjectType; |
|
|
|
fMark: Integer; |
|
|
|
fName: DOMString; |
|
|
|
fComment: DOMString; |
|
|
|
fList: TvkObjectList; |
|
|
|
private |
|
|
|
procedure SetMark(aValue: Integer); |
|
|
|
protected |
|
|
|
procedure DoMark(const aMark: Integer); virtual; |
|
|
|
public |
|
|
|
property Mark: Integer read fMark write SetMark; |
|
|
|
property Name: DOMString read fName write fName; |
|
|
|
property Comment: DOMString read fComment write fComment; |
|
|
|
property VkType: TvkObjectType read fType; |
|
|
|
property List: TvkObjectList read fList write fList; |
|
|
|
|
|
|
|
procedure AddCommentFromXml(xml: TDOMNode); |
|
|
|
|
|
|
|
constructor Create(const aType: TvkObjectType); |
|
|
|
public |
|
|
|
class function CreateFromXml(const xml: TDOMNode): THeaderGenerator.TvkObject; |
|
|
|
end; |
|
|
|
|
|
|
|
//////////////////////////////////////////////////////////////////////////////////////////// |
|
|
|
TvkTypeSimple = class(TvkObject) |
|
|
|
private |
|
|
|
fParent: DOMString; |
|
|
|
protected |
|
|
|
procedure DoMark(const aMark: Integer); override; |
|
|
|
public |
|
|
|
property Parent: DOMString read fParent write fParent; |
|
|
|
public |
|
|
|
class function CreateFromXml(const xml: TDOMNode): THeaderGenerator.TvkTypeSimple; |
|
|
|
end; |
|
|
|
|
|
|
|
//////////////////////////////////////////////////////////////////////////////////////////// |
|
|
|
TvkTypeHandle = class(TvkTypeSimple) |
|
|
|
private |
|
|
|
fNonDispatchable: Boolean; |
|
|
|
public |
|
|
|
property NonDispatchable: Boolean read fNonDispatchable write fNonDispatchable; |
|
|
|
public |
|
|
|
class function CreateFromXml(const xml: TDOMNode): THeaderGenerator.TvkTypeHandle; |
|
|
|
end; |
|
|
|
|
|
|
|
//////////////////////////////////////////////////////////////////////////////////////////// |
|
|
|
TvkTypeFunction = class(TvkObject) |
|
|
|
private type |
|
|
|
TArgument = class(TObject) |
|
|
|
Typ: DOMString; |
|
|
|
Name: DOMString; |
|
|
|
IsPointer: Boolean; |
|
|
|
IsConst: Boolean; |
|
|
|
end; |
|
|
|
TArgumentList = specialize TFPGObjectList<TArgument>; |
|
|
|
private |
|
|
|
fReturnValue: TArgument; |
|
|
|
fArguments: TArgumentList; |
|
|
|
protected |
|
|
|
procedure DoMark(const aMark: Integer); override; |
|
|
|
public |
|
|
|
property ReturnValue: TArgument read fReturnValue; |
|
|
|
property Arguments: TArgumentList read fArguments; |
|
|
|
|
|
|
|
constructor Create(const aType: TvkObjectType); |
|
|
|
destructor Destroy; override; |
|
|
|
end; |
|
|
|
|
|
|
|
//////////////////////////////////////////////////////////////////////////////////////////// |
|
|
|
TvkTypeFunctionPtr = class(TvkTypeFunction) |
|
|
|
public |
|
|
|
class function CreateFromXml(const xml: TDOMNode): THeaderGenerator.TvkTypeFunctionPtr; |
|
|
|
end; |
|
|
|
|
|
|
|
//////////////////////////////////////////////////////////////////////////////////////////// |
|
|
|
TvkCommand = class(TvkTypeFunction) |
|
|
|
public |
|
|
|
class function CreateFromXml(const xml: TDOMNode): THeaderGenerator.TvkCommand; |
|
|
|
end; |
|
|
|
|
|
|
|
//////////////////////////////////////////////////////////////////////////////////////////// |
|
|
|
TvkTypeStruct = class(TvkObject) |
|
|
|
private type |
|
|
|
TMember = class(TObject) |
|
|
|
Typ: DOMString; |
|
|
|
Name: DOMString; |
|
|
|
ArrSize: Integer; |
|
|
|
IsPointer: Boolean; |
|
|
|
IsConst: Boolean; |
|
|
|
end; |
|
|
|
TMemberList = specialize TFPGObjectList<TMember>; |
|
|
|
private |
|
|
|
fIsUnion: Boolean; |
|
|
|
fMember: TMemberList; |
|
|
|
protected |
|
|
|
procedure DoMark(const aMark: Integer); override; |
|
|
|
public |
|
|
|
property Member: TMemberList read fMember; |
|
|
|
property IsUnion: Boolean read fIsUnion write fIsUnion; |
|
|
|
|
|
|
|
constructor Create(const aType: TvkObjectType); |
|
|
|
destructor Destroy; override; |
|
|
|
public |
|
|
|
class function CreateFromXml(const xml: TDOMNode): THeaderGenerator.TvkTypeStruct; |
|
|
|
end; |
|
|
|
|
|
|
|
//////////////////////////////////////////////////////////////////////////////////////////// |
|
|
|
TvkTypeEnum = class(TvkObject) |
|
|
|
private type |
|
|
|
TValue = class(TObject) |
|
|
|
Name: DOMString; |
|
|
|
Value: Variant; |
|
|
|
IsBit: Boolean; |
|
|
|
end; |
|
|
|
TValueList = specialize TFPGObjectList<TValue>; |
|
|
|
private |
|
|
|
fValues: TValueList; |
|
|
|
public |
|
|
|
property Values: TValueList read fValues; |
|
|
|
|
|
|
|
constructor Create(const aType: TvkObjectType); |
|
|
|
destructor Destroy; override; |
|
|
|
public |
|
|
|
class function CreateFromXml(const xml: TDOMNode): THeaderGenerator.TvkTypeEnum; |
|
|
|
end; |
|
|
|
|
|
|
|
private const |
|
|
|
VK_OBJECT_TYPES: TvkObjectTypes = [ otType, otHandle, otFuncPtr, otStruct, otEnum ]; |
|
|
|
|
|
|
|
private |
|
|
|
fDocument: TXMLDocument; |
|
|
|
fComment: DOMString; |
|
|
|
fObjects: TvkObjectList; |
|
|
|
|
|
|
|
public |
|
|
|
procedure ReadFile(const aFilename: String); |
|
|
|
procedure ReadFile(const aStream: TStream); |
|
|
|
|
|
|
|
procedure Clear; |
|
|
|
|
|
|
|
constructor Create; |
|
|
|
destructor Destroy; override; |
|
|
|
end; |
|
|
|
|
|
|
|
implementation |
|
|
|
|
|
|
|
uses |
|
|
|
XMLRead, RegExpr; |
|
|
|
|
|
|
|
type |
|
|
|
XmlException = class(Exception) |
|
|
|
public |
|
|
|
xml: TDOMNode; |
|
|
|
constructor Create(const aMsg: WideString; const aXml: TDOMNode); |
|
|
|
end; |
|
|
|
|
|
|
|
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// |
|
|
|
function FormatType(const aType: THeaderGenerator.TvkObjectType): WideString; |
|
|
|
begin |
|
|
|
case aType of |
|
|
|
otType: result := 'TYPE'; |
|
|
|
otHandle: result := 'HANDLE'; |
|
|
|
otFuncPtr: result := 'FUNCPTR'; |
|
|
|
otStruct: result := 'STRUCT'; |
|
|
|
otEnum: result := 'ENUM'; |
|
|
|
otCommand: result := 'COMMAND'; |
|
|
|
else |
|
|
|
result := ''; |
|
|
|
end; |
|
|
|
end; |
|
|
|
|
|
|
|
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// |
|
|
|
procedure WriteResolveWarning(const aName: DOMString); |
|
|
|
begin |
|
|
|
WriteLn('WARNING! unable to resolve identifier: ' + aName); |
|
|
|
end; |
|
|
|
|
|
|
|
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// |
|
|
|
function GetNodeValue(xml: TDOMNode; const aName: WideString): DOMString; |
|
|
|
var x: TDOMNode; |
|
|
|
begin |
|
|
|
x := xml.FindNode(aName); |
|
|
|
if not Assigned(x) then |
|
|
|
raise XmlException.Create(xml.NodeName + ' witout child ''' + aName + '''', xml); |
|
|
|
result := x.TextContent; |
|
|
|
end; |
|
|
|
|
|
|
|
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// |
|
|
|
function GetNodeValue(xml: TDOMNode; const aName: WideString; const aDefault: DOMString): DOMString; |
|
|
|
var x: TDOMNode; |
|
|
|
begin |
|
|
|
x := xml.FindNode(aName); |
|
|
|
if not Assigned(x) |
|
|
|
then result := aDefault |
|
|
|
else result := x.TextContent; |
|
|
|
end; |
|
|
|
|
|
|
|
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// |
|
|
|
function GetNodeAttrib(xml: TDOMNode; const aName: WideString): DOMString; |
|
|
|
var x: TDOMNode; |
|
|
|
begin |
|
|
|
if xml.HasAttributes then begin |
|
|
|
x := xml.Attributes.GetNamedItem(aName); |
|
|
|
if Assigned(x) then begin |
|
|
|
result := x.TextContent; |
|
|
|
exit; |
|
|
|
end; |
|
|
|
end; |
|
|
|
raise XmlException.Create(xml.NodeName + ' without ''' + aName + ''' attribute', xml); |
|
|
|
end; |
|
|
|
|
|
|
|
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// |
|
|
|
function GetNodeAttrib(xml: TDOMNode; const aName: WideString; const aDefault: DOMString): DOMString; |
|
|
|
var x: TDOMNode; |
|
|
|
begin |
|
|
|
result := aDefault; |
|
|
|
if xml.HasAttributes then begin |
|
|
|
x := xml.Attributes.GetNamedItem(aName); |
|
|
|
if Assigned(x) then |
|
|
|
result := x.TextContent; |
|
|
|
end; |
|
|
|
end; |
|
|
|
|
|
|
|
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// |
|
|
|
//XmlException////////////////////////////////////////////////////////////////////////////////////////////////////////// |
|
|
|
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// |
|
|
|
constructor XmlException.Create(const aMsg: WideString; const aXml: TDOMNode); |
|
|
|
begin |
|
|
|
inherited Create(String(aMsg + ': ' + aXml.TextContent)); |
|
|
|
xml := aXml; |
|
|
|
end; |
|
|
|
|
|
|
|
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// |
|
|
|
//THeaderGenerator.TvkObjectList//////////////////////////////////////////////////////////////////////////////////////// |
|
|
|
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// |
|
|
|
function THeaderGenerator.TvkObjectList.FindObj(const aName: DOMstring; const aTypes: TvkObjectTypes; out aObject): Boolean; |
|
|
|
var |
|
|
|
o: TvkObject; |
|
|
|
begin |
|
|
|
if (aName = '') then |
|
|
|
raise Exception.Create('empty name'); |
|
|
|
|
|
|
|
result := true; |
|
|
|
TvkObject(aObject) := nil; |
|
|
|
for o in self do begin |
|
|
|
if (o.VkType in aTypes) and (o.Name = aName) then begin |
|
|
|
TvkObject(aObject) := o; |
|
|
|
exit; |
|
|
|
end; |
|
|
|
end; |
|
|
|
result := false; |
|
|
|
end; |
|
|
|
|
|
|
|
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// |
|
|
|
procedure THeaderGenerator.TvkObjectList.MarkObj(const aName: DOMstring; const aTypes: TvkObjectTypes; |
|
|
|
const aMark: Integer); |
|
|
|
var o: TvkObject; |
|
|
|
begin |
|
|
|
if FindObj(aName, aTypes, o) |
|
|
|
then o.Mark := aMark |
|
|
|
else WriteResolveWarning(aName); |
|
|
|
end; |
|
|
|
|
|
|
|
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// |
|
|
|
//THeaderGenerator.TvkObject//////////////////////////////////////////////////////////////////////////////////////////// |
|
|
|
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// |
|
|
|
procedure THeaderGenerator.TvkObject.SetMark(aValue: Integer); |
|
|
|
begin |
|
|
|
if (fMark <> 0) then |
|
|
|
exit; |
|
|
|
fMark := aValue; |
|
|
|
DoMark(fMark); |
|
|
|
end; |
|
|
|
|
|
|
|
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// |
|
|
|
procedure THeaderGenerator.TvkObject.DoMark(const aMark: Integer); |
|
|
|
begin |
|
|
|
WriteLn(Format(' %-10s%-50s marked for generation', [FormatType(fType), fName])); |
|
|
|
end; |
|
|
|
|
|
|
|
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// |
|
|
|
procedure THeaderGenerator.TvkObject.AddCommentFromXml(xml: TDOMNode); |
|
|
|
begin |
|
|
|
xml := xml.FindNode('comment'); |
|
|
|
if Assigned(xml) then |
|
|
|
fComment := xml.TextContent; |
|
|
|
end; |
|
|
|
|
|
|
|
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// |
|
|
|
constructor THeaderGenerator.TvkObject.Create(const aType: TvkObjectType); |
|
|
|
begin |
|
|
|
inherited Create; |
|
|
|
fType := aType; |
|
|
|
end; |
|
|
|
|
|
|
|
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// |
|
|
|
class function THeaderGenerator.TvkObject.CreateFromXml(const xml: TDOMNode): THeaderGenerator.TvkObject; |
|
|
|
var |
|
|
|
s: DOMString; |
|
|
|
x: TDOMNode; |
|
|
|
begin |
|
|
|
result := nil; |
|
|
|
if (xml.NodeName = 'type') and xml.HasAttributes then begin |
|
|
|
x := xml.Attributes.GetNamedItem('category'); |
|
|
|
if not Assigned(x) then |
|
|
|
exit; |
|
|
|
s := x.TextContent; |
|
|
|
if (s = 'basetype') or (s = 'bitmask') then |
|
|
|
result := TvkTypeSimple.CreateFromXml(xml) |
|
|
|
else if (s = 'handle') then |
|
|
|
result := TvkTypeHandle.CreateFromXml(xml) |
|
|
|
else if (s = 'funcpointer') then |
|
|
|
result := TvkTypeFunctionPtr.CreateFromXml(xml) |
|
|
|
else if (s = 'struct') or (s = 'union') then |
|
|
|
result := TvkTypeStruct.CreateFromXml(xml); |
|
|
|
end else if (xml.NodeName = 'command') then |
|
|
|
result := TvkCommand.CreateFromXml(xml); |
|
|
|
end; |
|
|
|
|
|
|
|
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// |
|
|
|
//THeaderGenerator.TvkTypeSimple//////////////////////////////////////////////////////////////////////////////////////// |
|
|
|
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// |
|
|
|
procedure THeaderGenerator.TvkTypeSimple.DoMark(const aMark: Integer); |
|
|
|
begin |
|
|
|
inherited DoMark(aMark); |
|
|
|
if (fParent <> '') and Assigned(fList) then |
|
|
|
fList.MarkObj(fParent, VK_OBJECT_TYPES, aMark); |
|
|
|
end; |
|
|
|
|
|
|
|
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// |
|
|
|
class function THeaderGenerator.TvkTypeSimple.CreateFromXml(const xml: TDOMNode): THeaderGenerator.TvkTypeSimple; |
|
|
|
begin |
|
|
|
result := TvkTypeSimple.Create(otType); |
|
|
|
try |
|
|
|
result.Name := GetNodeValue(xml, 'name'); |
|
|
|
result.Parent := GetNodeValue(xml, 'type'); |
|
|
|
except |
|
|
|
FreeAndNil(result); |
|
|
|
raise; |
|
|
|
end; |
|
|
|
end; |
|
|
|
|
|
|
|
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// |
|
|
|
//THeaderGenerator.TvkTypeHandle//////////////////////////////////////////////////////////////////////////////////////// |
|
|
|
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// |
|
|
|
class function THeaderGenerator.TvkTypeHandle.CreateFromXml(const xml: TDOMNode): THeaderGenerator.TvkTypeHandle; |
|
|
|
begin |
|
|
|
result := TvkTypeHandle.Create(otHandle); |
|
|
|
try |
|
|
|
result.Name := GetNodeValue(xml, 'name'); |
|
|
|
result.Parent := GetNodeValue(xml, 'parent', 'VkHandle'); |
|
|
|
result.NonDispatchable := (GetNodeValue(xml, 'type', '') = 'VK_DEFINE_NON_DISPATCHABLE_HANDLE'); |
|
|
|
except |
|
|
|
FreeAndNil(result); |
|
|
|
raise; |
|
|
|
end; |
|
|
|
end; |
|
|
|
|
|
|
|
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// |
|
|
|
procedure THeaderGenerator.TvkTypeFunction.DoMark(const aMark: Integer); |
|
|
|
var a: TArgument; |
|
|
|
begin |
|
|
|
inherited DoMark(aMark); |
|
|
|
if Assigned(fList) then begin |
|
|
|
fList.MarkObj(fReturnValue.Typ, VK_OBJECT_TYPES, aMark); |
|
|
|
for a in fArguments do |
|
|
|
fList.MarkObj(a.Typ, VK_OBJECT_TYPES, aMark); |
|
|
|
end; |
|
|
|
end; |
|
|
|
|
|
|
|
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// |
|
|
|
//THeaderGenerator.TvkTypeFunction/////////////////////////////////////////////////////////////////////////////////////// |
|
|
|
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// |
|
|
|
constructor THeaderGenerator.TvkTypeFunction.Create(const aType: TvkObjectType); |
|
|
|
begin |
|
|
|
inherited Create(aType); |
|
|
|
fReturnValue := TArgument.Create; |
|
|
|
fArguments := TArgumentList.Create; |
|
|
|
end; |
|
|
|
|
|
|
|
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// |
|
|
|
destructor THeaderGenerator.TvkTypeFunction.Destroy; |
|
|
|
begin |
|
|
|
FreeAndNil(fReturnValue); |
|
|
|
FreeAndNil(fArguments); |
|
|
|
inherited Destroy; |
|
|
|
end; |
|
|
|
|
|
|
|
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// |
|
|
|
//THeaderGenerator.TvkTypeFunctionPtr/////////////////////////////////////////////////////////////////////////////////// |
|
|
|
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// |
|
|
|
class function THeaderGenerator.TvkTypeFunctionPtr.CreateFromXml(const xml: TDOMNode): THeaderGenerator.TvkTypeFunctionPtr; |
|
|
|
var |
|
|
|
x, p: TDOMNode; |
|
|
|
a: TArgument; |
|
|
|
rx: TRegExpr; |
|
|
|
begin |
|
|
|
result := TvkTypeFunctionPtr.Create(otFuncPtr); |
|
|
|
try |
|
|
|
x := xml.FindNode('name'); |
|
|
|
if not Assigned(x) then |
|
|
|
raise XmlException.Create(xml.NodeName + ' witout child ''name''', xml); |
|
|
|
result.Name := x.TextContent; |
|
|
|
|
|
|
|
p := x.PreviousSibling; |
|
|
|
if not Assigned(p) then |
|
|
|
raise XmlException.Create(xml.NodeName + ' witout return type', xml); |
|
|
|
|
|
|
|
rx := TRegExpr.Create('typedef\s+((const)?)\s*([-_A-Za-z0-9\s]+?)\s*(\*?)\s*\('); |
|
|
|
try |
|
|
|
if not rx.Exec(String(p.TextContent)) then |
|
|
|
raise XmlException.Create('unable to parse return type of function pointer', xml); |
|
|
|
|
|
|
|
result.ReturnValue.IsConst := (Trim(rx.Match[1]) = 'const'); |
|
|
|
result.ReturnValue.Typ := WideString(Trim(rx.Match[3])); |
|
|
|
result.ReturnValue.IsPointer := (Trim(rx.Match[4]) = '*'); |
|
|
|
|
|
|
|
x := xml.FirstChild; |
|
|
|
while Assigned(x) do begin |
|
|
|
if (x.NodeName = 'type') then begin |
|
|
|
a := TArgument.Create; |
|
|
|
try |
|
|
|
p := x.PreviousSibling; |
|
|
|
if not Assigned(p) then |
|
|
|
raise XmlException.Create('unable to parse function pointer arguments', xml); |
|
|
|
rx.Expression := '[A-Za-z]*'; |
|
|
|
a.IsConst := rx.Exec(String(p.TextContent)) and (rx.Match[0] = 'const'); |
|
|
|
a.Typ := x.TextContent; |
|
|
|
|
|
|
|
p := x.NextSibling; |
|
|
|
if not Assigned(p) then |
|
|
|
raise XmlException.Create('unable to parse function pointer arguments', xml); |
|
|
|
rx.Expression := '(\*?)\s*([-_A-Za-z0-9]+)'; |
|
|
|
if not rx.Exec(String(p.TextContent)) then |
|
|
|
raise XmlException.Create('unable to parse function pointer arguments', xml); |
|
|
|
|
|
|
|
a.IsPointer := (rx.Match[1] = '*'); |
|
|
|
a.Name := WideString(Trim(rx.Match[2])); |
|
|
|
result.Arguments.Add(a); |
|
|
|
except |
|
|
|
FreeAndNil(a) |
|
|
|
end; |
|
|
|
end; |
|
|
|
x := x.NextSibling; |
|
|
|
end; |
|
|
|
finally |
|
|
|
FreeAndNil(rx); |
|
|
|
end; |
|
|
|
except |
|
|
|
FreeAndNil(result); |
|
|
|
raise; |
|
|
|
end; |
|
|
|
end; |
|
|
|
|
|
|
|
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// |
|
|
|
//THeaderGenerator.TvkCommand/////////////////////////////////////////////////////////////////////////////////////// |
|
|
|
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// |
|
|
|
class function THeaderGenerator.TvkCommand.CreateFromXml(const xml: TDOMNode): THeaderGenerator.TvkCommand; |
|
|
|
|
|
|
|
procedure ParseProto(const x: TDOMNode); |
|
|
|
begin |
|
|
|
result.Name := GetNodeValue(x, 'name'); |
|
|
|
result.ReturnValue.Typ := GetNodeValue(x, 'type'); |
|
|
|
end; |
|
|
|
|
|
|
|
procedure ParseParam(const x: TDOMNode); |
|
|
|
var |
|
|
|
p: TDOMNode; |
|
|
|
a: TArgument; |
|
|
|
begin |
|
|
|
a := TArgument.Create; |
|
|
|
try |
|
|
|
p := x.FindNode('name'); |
|
|
|
if not Assigned(p) then |
|
|
|
raise XmlException.Create('unable to parse command; param without name', xml); |
|
|
|
a.Name := p.TextContent; |
|
|
|
|
|
|
|
p := x.FindNode('type'); |
|
|
|
if not Assigned(p) then |
|
|
|
raise XmlException.Create('unable to parse command; param without type', xml); |
|
|
|
a.Typ := p.TextContent; |
|
|
|
a.IsConst := Assigned(p.PreviousSibling) and (Trim(p.PreviousSibling.TextContent) = 'const'); |
|
|
|
a.IsPointer := Assigned(p.NextSibling) and (Trim(p.NextSibling.TextContent) = '*'); |
|
|
|
result.Arguments.Add(a); |
|
|
|
except |
|
|
|
FreeAndNil(a); |
|
|
|
raise; |
|
|
|
end; |
|
|
|
end; |
|
|
|
|
|
|
|
var |
|
|
|
x: TDOMNode; |
|
|
|
begin |
|
|
|
result := TvkCommand.Create(otCommand); |
|
|
|
try |
|
|
|
x := xml.FirstChild; |
|
|
|
while Assigned(x) do begin |
|
|
|
if (x.NodeName = 'proto') then |
|
|
|
ParseProto(x) |
|
|
|
else if (x.NodeName = 'param') then |
|
|
|
ParseParam(x); |
|
|
|
x := x.NextSibling; |
|
|
|
end; |
|
|
|
except |
|
|
|
FreeAndNil(result); |
|
|
|
raise; |
|
|
|
end; |
|
|
|
end; |
|
|
|
|
|
|
|
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// |
|
|
|
procedure THeaderGenerator.TvkTypeStruct.DoMark(const aMark: Integer); |
|
|
|
var m: TMember; |
|
|
|
begin |
|
|
|
inherited DoMark(aMark); |
|
|
|
if Assigned(fList) then begin |
|
|
|
for m in fMember do |
|
|
|
fList.MarkObj(m.Typ, VK_OBJECT_TYPES, aMark); |
|
|
|
end; |
|
|
|
end; |
|
|
|
|
|
|
|
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// |
|
|
|
//THeaderGenerator.TvkTypeStruct//////////////////////////////////////////////////////////////////////////////////////// |
|
|
|
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// |
|
|
|
constructor THeaderGenerator.TvkTypeStruct.Create(const aType: TvkObjectType); |
|
|
|
begin |
|
|
|
inherited Create(aType); |
|
|
|
fMember := TMemberList.Create; |
|
|
|
end; |
|
|
|
|
|
|
|
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// |
|
|
|
destructor THeaderGenerator.TvkTypeStruct.Destroy; |
|
|
|
begin |
|
|
|
FreeAndNil(fMember); |
|
|
|
inherited Destroy; |
|
|
|
end; |
|
|
|
|
|
|
|
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// |
|
|
|
class function THeaderGenerator.TvkTypeStruct.CreateFromXml(const xml: TDOMNode): THeaderGenerator.TvkTypeStruct; |
|
|
|
var |
|
|
|
x, p: TDOMNode; |
|
|
|
m: TMember; |
|
|
|
rx: TRegExpr; |
|
|
|
begin |
|
|
|
result := TvkTypeStruct.Create(otStruct); |
|
|
|
try |
|
|
|
result.Name := GetNodeAttrib(xml, 'name'); |
|
|
|
result.IsUnion := (GetNodeAttrib(xml, 'category') = 'union'); |
|
|
|
|
|
|
|
x := xml.FirstChild; |
|
|
|
while Assigned(x) do begin |
|
|
|
if (x.NodeName = 'member') then begin |
|
|
|
m := TMember.Create; |
|
|
|
try |
|
|
|
// read name |
|
|
|
p := x.FindNode('name'); |
|
|
|
if not Assigned(p) then |
|
|
|
raise XmlException.Create('struct member without name', xml); |
|
|
|
m.Name := p.TextContent; |
|
|
|
if Assigned(p.NextSibling) then |
|
|
|
m.Name := m.Name + p.NextSibling.TextContent; |
|
|
|
m.Name := Trim(m.Name); |
|
|
|
rx := TRegExpr.Create('([-_A-Za-z0-9]+)\s*\[\s*([0-9]+)\s*\]'); |
|
|
|
try |
|
|
|
if rx.Exec(String(m.Name)) then begin |
|
|
|
m.Name := WideString(rx.Match[1]); |
|
|
|
m.ArrSize := StrToInt(rx.Match[2]); |
|
|
|
end; |
|
|
|
finally |
|
|
|
FreeAndNil(rx); |
|
|
|
end; |
|
|
|
|
|
|
|
// read type |
|
|
|
p := x.FindNode('type'); |
|
|
|
if not Assigned(p) then |
|
|
|
raise XmlException.Create('struct member without type', xml); |
|
|
|
m.Typ := p.TextContent; |
|
|
|
m.IsConst := Assigned(p.PreviousSibling) and (Trim(p.PreviousSibling.TextContent) = 'const'); |
|
|
|
m.IsPointer := Assigned(p.NextSibling) and (Trim(p.NextSibling.TextContent) = '*'); |
|
|
|
result.Member.Add(m); |
|
|
|
except |
|
|
|
FreeAndNil(m); |
|
|
|
end; |
|
|
|
end; |
|
|
|
x := x.NextSibling; |
|
|
|
end; |
|
|
|
except |
|
|
|
FreeAndNil(result); |
|
|
|
raise; |
|
|
|
end; |
|
|
|
end; |
|
|
|
|
|
|
|
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// |
|
|
|
//THeaderGenerator.TvkTypeEnum////////////////////////////////////////////////////////////////////////////////////////// |
|
|
|
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// |
|
|
|
constructor THeaderGenerator.TvkTypeEnum.Create(const aType: TvkObjectType); |
|
|
|
begin |
|
|
|
inherited Create(aType); |
|
|
|
fValues := TValueList.Create; |
|
|
|
end; |
|
|
|
|
|
|
|
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// |
|
|
|
destructor THeaderGenerator.TvkTypeEnum.Destroy; |
|
|
|
begin |
|
|
|
FreeAndNil(fValues); |
|
|
|
inherited Destroy; |
|
|
|
end; |
|
|
|
|
|
|
|
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// |
|
|
|
class function THeaderGenerator.TvkTypeEnum.CreateFromXml(const xml: TDOMNode): THeaderGenerator.TvkTypeEnum; |
|
|
|
var |
|
|
|
x, p: TDOMNode; |
|
|
|
v: TValue; |
|
|
|
|
|
|
|
function StrToValue(s: String): Variant; |
|
|
|
var |
|
|
|
f: TFormatSettings; |
|
|
|
rx: TRegExpr; |
|
|
|
begin |
|
|
|
f.DecimalSeparator := '.'; |
|
|
|
rx := TRegExpr.Create; |
|
|
|
try |
|
|
|
result := Unassigned; |
|
|
|
|
|
|
|
rx.Expression := '^-?(0x)?([0-9A-Fa-f]+)$'; |
|
|
|
if rx.Exec(s) then |
|
|
|
result := StrToInt(rx.Match[1] + rx.Match[2]); |
|
|
|
|
|
|
|
rx.Expression := '^([0-9\.]+)(f|d)?$'; |
|
|
|
if rx.Exec(s) then begin |
|
|
|
result := StrToFloat(rx.Match[1], f); |
|
|
|
if (rx.Match[2] = 'd') then |
|
|
|
result := Double(result); |
|
|
|
end; |
|
|
|
|
|
|
|
rx.Expression := '^\(~0U([L]*)\)$'; |
|
|
|
if rx.Exec(s) then begin |
|
|
|
if (rx.Match[2] = '') |
|
|
|
then result := High(Cardinal) |
|
|
|
else result := High(UInt64); |
|
|
|
end; |
|
|
|
|
|
|
|
if (result = Unassigned) then |
|
|
|
raise XmlException.Create(WideString('invalid enum value (' + s + ')'), xml); |
|
|
|
finally |
|
|
|
FreeAndNil(rx); |
|
|
|
end; |
|
|
|
end; |
|
|
|
|
|
|
|
begin |
|
|
|
result := TvkTypeEnum.Create(otEnum); |
|
|
|
try |
|
|
|
result.Name := GetNodeAttrib(xml, 'name'); |
|
|
|
x := xml.FirstChild; |
|
|
|
while Assigned(x) do begin |
|
|
|
if (x.NodeName = 'enum') then begin |
|
|
|
v := TValue.Create; |
|
|
|
try |
|
|
|
v.Name := GetNodeAttrib(x, 'name'); |
|
|
|
p := x.Attributes.GetNamedItem('value'); |
|
|
|
if Assigned(p) then begin |
|
|
|
v.IsBit := false; |
|
|
|
v.Value := StrToValue(String(p.TextContent)); |
|
|
|
end else begin |
|
|
|
p := x.Attributes.GetNamedItem('bitpos'); |
|
|
|
if not Assigned(p) then |
|
|
|
raise XmlException.Create('enum without value or bitpos', xml); |
|
|
|
v.IsBit := false; |
|
|
|
v.Value := StrToValue(String(p.TextContent)); |
|
|
|
end; |
|
|
|
result.Values.Add(v); |
|
|
|
except |
|
|
|
FreeAndNil(v); |
|
|
|
raise; |
|
|
|
end; |
|
|
|
end; |
|
|
|
x := x.NextSibling; |
|
|
|
end; |
|
|
|
except |
|
|
|
FreeAndNil(result); |
|
|
|
raise; |
|
|
|
end; |
|
|
|
end; |
|
|
|
|
|
|
|
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// |
|
|
|
//THeaderGenerator////////////////////////////////////////////////////////////////////////////////////////////////////// |
|
|
|
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// |
|
|
|
procedure THeaderGenerator.ReadFile(const aFilename: String); |
|
|
|
var |
|
|
|
fs: TFileStream; |
|
|
|
begin |
|
|
|
if not FileExists(aFilename) then |
|
|
|
raise Exception.Create('file does not exist: ' + aFilename); |
|
|
|
fs := TFileStream.Create(aFilename, fmOpenRead); |
|
|
|
try |
|
|
|
ReadFile(fs); |
|
|
|
finally |
|
|
|
FreeAndNil(fs); |
|
|
|
end; |
|
|
|
end; |
|
|
|
|
|
|
|
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// |
|
|
|
procedure THeaderGenerator.ReadFile(const aStream: TStream); |
|
|
|
var |
|
|
|
xml: TDOMNode; |
|
|
|
CurrentMark: Integer; |
|
|
|
|
|
|
|
procedure AddObject(const aObj: TvkObject); |
|
|
|
begin |
|
|
|
if Assigned(aObj) then begin |
|
|
|
fObjects.Add(aObj); |
|
|
|
aObj.List := fObjects; |
|
|
|
WriteLn(Format(' %-10s%s', [FormatType(aObj.VkType), aObj.Name])); |
|
|
|
end; |
|
|
|
end; |
|
|
|
|
|
|
|
procedure ParseTypes(const xml: TDOMNode); |
|
|
|
var |
|
|
|
x: TDOMNode; |
|
|
|
begin |
|
|
|
x := xml.FirstChild; |
|
|
|
while Assigned(x) do begin |
|
|
|
AddObject(TvkObject.CreateFromXml(x)); |
|
|
|
x := x.NextSibling; |
|
|
|
end; |
|
|
|
end; |
|
|
|
|
|
|
|
procedure EnableFeature(const xml: TDOMNode); |
|
|
|
var |
|
|
|
x: TDOMNode; |
|
|
|
begin |
|
|
|
x := xml.FirstChild; |
|
|
|
while Assigned(x) do begin |
|
|
|
if (x.NodeName = 'require') then |
|
|
|
EnableFeature(x) |
|
|
|
else if (x.NodeName = 'type') then |
|
|
|
fObjects.MarkObj(GetNodeAttrib(x, 'name'), VK_OBJECT_TYPES, CurrentMark) |
|
|
|
else if (x.NodeName = 'command') then |
|
|
|
fObjects.MarkObj(GetNodeAttrib(x, 'name'), [ otCommand ], CurrentMark); |
|
|
|
|
|
|
|
x := x.NextSibling; |
|
|
|
end; |
|
|
|
end; |
|
|
|
|
|
|
|
begin |
|
|
|
Clear; |
|
|
|
ReadXMLFile(fDocument, aStream); |
|
|
|
|
|
|
|
CurrentMark := 1; |
|
|
|
WriteLn('read xml data'); |
|
|
|
xml := fDocument.DocumentElement.FirstChild; |
|
|
|
while Assigned(xml) do begin |
|
|
|
if (xml.NodeName = 'types') or (xml.NodeName = 'commands') then |
|
|
|
ParseTypes(xml) |
|
|
|
else if (xml.NodeName = 'enums') then |
|
|
|
AddObject(TvkTypeEnum.CreateFromXml(xml)) |
|
|
|
else if (xml.NodeName = 'comment') then |
|
|
|
fComment := xml.TextContent |
|
|
|
else if (xml.NodeName = 'feature') then |
|
|
|
EnableFeature(xml); |
|
|
|
xml := xml.NextSibling; |
|
|
|
end; |
|
|
|
|
|
|
|
WriteLn('generate header'); |
|
|
|
|
|
|
|
end; |
|
|
|
|
|
|
|
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// |
|
|
|
procedure THeaderGenerator.Clear; |
|
|
|
|
|
|
|
procedure CreateBaseType(const aName: DOMString); |
|
|
|
var o: TvkObject; |
|
|
|
begin |
|
|
|
o := TvkTypeSimple.Create(otType); |
|
|
|
try |
|
|
|
o.Name := aName; |
|
|
|
o.List := fObjects; |
|
|
|
fObjects.Add(o); |
|
|
|
except |
|
|
|
FreeAndNil(o); |
|
|
|
raise; |
|
|
|
end; |
|
|
|
end; |
|
|
|
|
|
|
|
begin |
|
|
|
fComment := ''; |
|
|
|
fObjects.Clear; |
|
|
|
CreateBaseType('void'); |
|
|
|
CreateBaseType('uint16_t'); |
|
|
|
CreateBaseType('uint32_t'); |
|
|
|
CreateBaseType('uint64_t'); |
|
|
|
CreateBaseType('int16_t'); |
|
|
|
CreateBaseType('int32_t'); |
|
|
|
CreateBaseType('int64_t'); |
|
|
|
CreateBaseType('float'); |
|
|
|
CreateBaseType('double'); |
|
|
|
CreateBaseType('char'); |
|
|
|
CreateBaseType('uint8_t'); |
|
|
|
CreateBaseType('size_t'); |
|
|
|
CreateBaseType('VkHandle'); |
|
|
|
end; |
|
|
|
|
|
|
|
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// |
|
|
|
constructor THeaderGenerator.Create; |
|
|
|
begin |
|
|
|
inherited Create; |
|
|
|
fObjects := TvkObjectList.Create; |
|
|
|
end; |
|
|
|
|
|
|
|
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// |
|
|
|
destructor THeaderGenerator.Destroy; |
|
|
|
begin |
|
|
|
FreeAndNil(fObjects); |
|
|
|
FreeAndNil(fDocument); |
|
|
|
inherited Destroy; |
|
|
|
end; |
|
|
|
|
|
|
|
end. |
|
|
|
|
