1
0
mirror of https://github.com/moparisthebest/Simba synced 2024-12-22 23:38:50 -05:00

Oh right, forgot the other files :)

This commit is contained in:
Niels 2010-03-26 23:09:12 +01:00
parent 70599f5a92
commit 6cf764e3f4
11 changed files with 13525 additions and 0 deletions

File diff suppressed because it is too large Load Diff

View File

@ -0,0 +1,322 @@
{---------------------------------------------------------------------------
The contents of this file are subject to the Mozilla Public License Version
1.1 (the "License"); you may not use this file except in compliance with the
License. You may obtain a copy of the License at
http://www.mozilla.org/NPL/NPL-1_1Final.html
Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
the specific language governing rights and limitations under the License.
The Original Code is: mwPasLexTypes, released November 14, 1999.
The Initial Developer of the Original Code is Martin Waldenburg
unit CastaliaPasLexTypes;
----------------------------------------------------------------------------}
unit CastaliaPasLexTypes;
{$include ValistusDefines.inc}
interface
uses SysUtils, TypInfo;
var
CompTable: array[#0..#255] of byte;
type
TMessageEventType = ( meError, meNotSupported );
TMessageEvent = procedure(Sender: TObject; const Typ : TMessageEventType; const Msg: string; X, Y: Integer ) of object; //jdj 7/16/1999; DR 2001-11-06
TCommentState = (csAnsi, csBor, csNo);
TTokenPoint = packed record
X : Integer;
Y : Integer;
end;
TptTokenKind = (
tokAbort, //JThurman 2004-11-8 (flow control routines)
tokAbsolute,
tokAbstract,
tokAdd,
tokAddressOp,
tokAmpersand,
tokAnd,
tokAnsiComment,
tokAnsiString,
tokArray,
tokAs,
tokAsciiChar,
tokAsm,
tokAssembler,
tokAssign,
tokAt,
tokAutomated,
tokBegin,
tokBoolean,
tokBorComment,
tokBraceClose,
tokBraceOpen,
tokBreak, //JThurman 2004-11-8 (flow control routines)
tokByte,
tokByteBool,
tokCardinal,
tokCase,
tokCdecl,
tokChar,
tokClass,
tokClassForward,
tokClassFunction,
tokClassProcedure,
tokColon,
tokComma,
tokComp,
tokCompDirect,
tokConst,
tokConstructor,
tokContains,
tokContinue, //JThurman 2004-11-8 (flow control routines)
tokCRLF,
tokCRLFCo,
tokCurrency,
tokDefault,
tokDefineDirect,
tokDeprecated, // DR 2001-10-20
tokDestructor,
tokDispid,
tokDispinterface,
tokDiv,
tokDo,
tokDotDot,
tokDouble,
tokDoubleAddressOp,
tokDownto,
tokDWORD,
tokDynamic,
tokElse,
tokElseDirect,
tokEnd,
tokEndIfDirect,
tokEqual,
tokError,
tokExcept,
tokExit, //JThurman 2004-11-8 (flow control routine)
tokExport,
tokExports,
tokExtended,
tokExternal,
tokFar,
tokFile,
{$IFDEF D8_NEWER} //JThurman 2004-03-20
tokFinal,
{$ENDIF}
tokFinalization,
tokFinally,
tokFloat,
tokFor,
tokForward,
tokFunction,
tokGoto,
tokGreater,
tokGreaterEqual,
tokHalt, //JThurman 2004-11-8 (flow control routines)
{$IFDEF D8_NEWER} //JThurman 2004-04-06
tokHelper,
{$ENDIF}
tokIdentifier,
tokIf,
tokIfDirect,
tokIfEndDirect,
tokElseIfDirect,
tokIfDefDirect,
tokIfNDefDirect,
tokIfOptDirect,
tokImplementation,
tokImplements,
tokIn,
tokIncludeDirect,
tokIndex,
tokInherited,
tokInitialization,
tokInline,
tokInt64,
tokInteger,
tokIntegerConst,
tokInterface,
tokIs,
tokLabel,
tokLibrary,
tokLocal, // DR 2001-11-14
tokLongBool,
tokLongint,
tokLongword,
tokLower,
tokLowerEqual,
tokMessage,
tokMinus,
tokMod,
tokName,
tokNear,
tokNil,
tokNodefault,
tokNone,
tokNot,
tokNotEqual,
tokNull,
tokObject,
tokOf,
tokOleVariant,
tokOn,
{$IFDEF D8_NEWER} //JThurman 2004-03-20
tokOperator,
{$ENDIF}
tokOr,
tokOut,
tokOverload,
tokOverride,
tokPackage,
tokPacked,
tokPascal,
tokPChar,
tokPlatform, // DR 2001-10-20
tokPlus,
tokPoint,
tokPointerSymbol,
tokPrivate,
tokProcedure,
tokProgram,
tokProperty,
tokProtected,
tokPublic,
tokPublished,
tokRaise,
tokRead,
tokReadonly,
tokReal,
tokReal48,
tokRecord,
{$IFDEF D12_NEWER}
tokReference, //JThurman 2008-25-07 (anonymous methods)
{$ENDIF}
tokRegister,
tokReintroduce,
tokRemove,
tokRepeat,
tokRequires,
tokResident,
tokResourceDirect,
tokResourcestring,
tokRoundClose,
tokRoundOpen,
tokRunError, //JThurman 2004-11-8 (flow control routines)
tokSafeCall,
{$IFDEF D8_NEWER} //JThurman 2004-03-19
tokSealed,
{$ENDIF}
tokSemiColon,
tokSet,
tokShl,
tokShortint,
tokShortString,
tokShr,
tokSingle,
tokSlash,
tokSlashesComment,
tokSmallint,
tokSpace,
tokSquareClose,
tokSquareOpen,
tokStar,
{$IFDEF D8_NEWER} //JThurman 2004-03-20
tokStatic,
{$ENDIF}
tokStdcall,
tokStored,
{$IFDEF D8_NEWER}
tokStrict, //JThurman 2004-03-03
{$ENDIF}
tokString,
tokStringConst,
tokStringDQConst, // 2002-01-14
tokStringresource,
tokSymbol,
tokThen,
tokThreadvar,
tokTo,
tokTry,
tokType,
tokUndefDirect,
tokUnit,
tokUnknown,
{$IFDEF D8_NEWER} //JThurman 2004-03-2003
tokUnsafe,
{$ENDIF}
tokUntil,
tokUses,
tokVar,
tokVarargs, // DR 2001-11-14
tokVariant,
tokVirtual,
tokWhile,
tokWideChar,
tokWideString,
tokWith,
tokWord,
tokWordBool,
tokWrite,
tokWriteonly,
tokXor,
tok_DONE);
TmwPasLexStatus = record
CommentState: TCommentState;
ExID: TptTokenKind;
LineNumber: Integer;
LinePos: Integer;
Origin: PAnsiChar;
RunPos: Integer;
TokenPos: Integer;
TokenID: TptTokenKind;
end;
const ExTypes = [tokDWORD, tokUnknown];
function TokenName(Value: TptTokenKind): string;
function tokTokenName(Value: TptTokenKind): string;
function IsTokenIDJunk(const aTokenID : TptTokenKind ) :Boolean; //XM 20001210
implementation
function TokenName(Value: TptTokenKind): string;
begin //jdj 7/18/1999
Result := Copy(tokTokenName(Value), 4, MaxInt);
end;
function tokTokenName(Value: TptTokenKind): string;
begin
result := GetEnumName(TypeInfo(TptTokenKind), Integer(Value));
end;
function IsTokenIDJunk(const aTokenID : TptTokenKind ) :boolean; //XM 20001210
begin
Result := aTokenID in [tokAnsiComment, tokBorComment, tokCRLF, tokCRLFCo, tokSlashesComment, tokSpace,
tokIfDirect,
tokIfEndDirect,
tokElseIfDirect,
tokIfDefDirect,
tokIfNDefDirect,
tokEndIfDirect,
tokIfOptDirect,
tokDefineDirect,
tokUndefDirect];
end;
end.

File diff suppressed because it is too large Load Diff

View File

@ -0,0 +1,330 @@
{---------------------------------------------------------------------------
The contents of this file are subject to the Mozilla Public License Version
1.1 (the "License"); you may not use this file except in compliance with the
License. You may obtain a copy of the License at
http://www.mozilla.org/NPL/NPL-1_1Final.html
Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
the specific language governing rights and limitations under the License.
The Original Code is: mwSimplePasParTypes, released November 14, 1999.
The Initial Developer of the Original Code is Martin Waldenburg
unit CastaliaPasLexTypes;
----------------------------------------------------------------------------}
unit CastaliaSimplePasParTypes;
{$include ValistusDefines.inc}
interface
uses SysUtils, TypInfo;
type
TmwParseError = (
InvalidAdditiveOperator,
InvalidAccessSpecifier,
InvalidCharString,
InvalidClassMethodHeading,
InvalidConstantDeclaration,
InvalidConstSection,
InvalidDeclarationSection,
InvalidDirective16Bit,
InvalidDirectiveBinding,
InvalidDirectiveCalling,
InvalidExportedHeading,
InvalidForStatement,
InvalidInitializationSection,
InvalidInterfaceDeclaration,
InvalidInterfaceType,
InvalidLabelId,
InvalidLabeledStatement,
InvalidMethodHeading,
InvalidMultiplicativeOperator,
InvalidNumber,
InvalidOrdinalIdentifier,
InvalidParameter,
InvalidParseFile,
InvalidProceduralDirective,
InvalidProceduralType,
InvalidProcedureDeclarationSection,
InvalidProcedureMethodDeclaration,
InvalidRealIdentifier,
InvalidRelativeOperator,
InvalidStorageSpecifier,
InvalidStringIdentifier,
InvalidStructuredType,
InvalidTryStatement,
InvalidTypeKind,
InvalidVariantIdentifier,
InvalidVarSection,
vchInvalidClass, //vch
vchInvalidMethod, //vch
vchInvalidProcedure,//vch
vchInvalidCircuit, //vch
vchInvalidIncludeFile //vch
);
TmwPasCodeInfo = (
ciNone, //: @BUG heresy !
ciAccessSpecifier,
ciAdditiveOperator,
ciArrayConstant,
ciArrayType,
ciAsmStatement,
ciBlock,
ciCaseLabel,
ciCaseSelector,
ciCaseStatement,
ciCharString,
ciClassClass, //DR 2001-07-16
ciClassField,
ciClassForward,
ciClassFunctionHeading,
ciClassHeritage,
ciClassMemberList,
ciClassMethodDirective,
ciClassMethodHeading,
ciClassMethodOrProperty,
ciClassMethodResolution,
ciClassProcedureHeading,
ciClassProperty,
ciClassReferenceType,
ciClassType,
ciClassTypeEnd, // DR 2001-07-31
ciClassVisibility,
ciCompoundStatement,
ciConstantColon,
ciConstantDeclaration,
ciConstantEqual,
ciConstantExpression,
ciConstantName,
ciConstantValue,
ciConstantValueTyped,
ciConstParameter,
ciConstructorHeading,
ciConstructorName,
ciConstSection,
ciContainsClause,
ciContainsExpression,
ciContainsIdentifier,
ciContainsStatement,
ciDeclarationSection,
ciDesignator,
ciDestructorHeading,
ciDestructorName,
ciDirective16Bit,
ciDirectiveBinding,
ciDirectiveCalling,
ciDirectiveDeprecated, // DR 2001-10-20
ciDirectiveLibrary, // DR 2001-10-20
ciDirectiveLocal, // DR 2001-11-14
ciDirectivePlatform, // DR 2001-10-20
ciDirectiveVarargs, // DR 2001-11-14
ciDispIDSpecifier, // DR 2001-07-26
ciDispInterfaceForward,
ciEmptyStatement,
ciEnumeratedType,
ciEnumeratedTypeItem, // DR 2001-10-29
ciExceptBlock,
ciExceptionBlockElseBranch,
ciExceptionClassTypeIdentifier,
ciExceptionHandler,
ciExceptionHandlerList,
ciExceptionIdentifier,
ciExceptionVariable,
ciExpliciteType,
ciExportedHeading,
ciExportsClause,
ciExportsElement,
ciExpression,
ciExpressionList,
ciExternalDirective,
ciExternalDirectiveThree,
ciExternalDirectiveTwo,
ciFactor,
ciFieldDeclaration,
ciFieldList,
ciFileType,
ciFormalParameterList,
ciFormalParameterSection,
ciForStatement,
ciForwardDeclaration, // DR 2001-07-23
ciFunctionHeading,
ciFunctionMethodDeclaration,
ciFunctionMethodName,
ciFunctionProcedureBlock,
ciFunctionProcedureName,
ciHandlePtCompDirect, //XM 20001125
ciHandlePtDefineDirect, //XM 20001125
ciHandlePtElseDirect, //XM 20001125
ciHandlePtIfDefDirect, //XM 20001125
ciHandlePtEndIfDirect, //XM 20001125
ciHandlePtIfNDefDirect, //XM 20001125
ciHandlePtIfOptDirect, //XM 20001125
ciHandlePtIncludeDirect,//XM 20001125
ciHandlePtResourceDirect,//XM 20001125
ciHandlePtUndefDirect, //XM 20001125
ciIdentifier,
ciIdentifierList,
ciIfStatement,
ciImplementationSection,
ciIncludeFile,
ciIndexSpecifier, // DR 2001-07-26
ciInheritedStatement,
ciInitializationSection,
ciInlineStatement,
ciInterfaceDeclaration,
ciInterfaceForward,
ciInterfaceGUID,
ciInterfaceHeritage,
ciInterfaceMemberList,
ciInterfaceSection,
ciInterfaceType,
ciLabelDeclarationSection,
ciLabeledStatement,
ciLabelId,
ciLibraryFile,
ciMainUsedUnitExpression,
ciMainUsedUnitName,
ciMainUsedUnitStatement,
ciMainUsesClause,
ciMultiplicativeOperator,
ciNewFormalParameterType,
ciNumber,
ciNextToken, //XM 20002512
ciObjectConstructorHeading,
ciObjectDestructorHeading,
ciObjectField,
ciObjectForward,
ciObjectFunctionHeading,
ciObjectHeritage,
ciObjectMemberList,
ciObjectMethodDirective,
ciObjectMethodHeading,
ciObjectNameOfMethod,
ciObjectProcedureHeading,
ciObjectProperty, // DR 2001-08-07
ciObjectPropertySpecifiers, // DR 2001-08-07
ciObjectType,
ciObjectTypeEnd, // DR 2001-08-07
ciObjectVisibility,
ciOldFormalParameterType,
ciOrdinalIdentifier,
ciOrdinalType,
ciOutParameter,
ciPackageFile,
ciParameterFormal,
ciParameterName,
ciParameterNameList,
ciParseFile,
ciPointerType,
ciProceduralDirective,
ciProceduralType,
ciProcedureDeclarationSection,
ciProcedureHeading,
ciProcedureMethodDeclaration,
ciProcedureMethodName,
ciProgramBlock,
ciProgramFile,
ciPropertyDefault, // DR 2001-07-16
ciPropertyInterface,
ciPropertyName,
ciPropertyParameterConst,
ciPropertyParameterList,
ciPropertySpecifiers,
ciQualifiedIdentifier,
ciQualifiedIdentifierList,
ciRaiseStatement,
ciReadAccessIdentifier,
ciRealIdentifier,
ciRealType,
ciRecordConstant,
ciRecordFieldConstant,
ciRecordType,
ciRecordVariant,
ciRelativeOperator,
ciRepeatStatement,
ciRequiresClause,
ciRequiresIdentifier,
ciResolutionInterfaceName,
ciResourceDeclaration,
ciReturnType,
ciSEMICOLON, //XM 20002512
ciSetConstructor,
ciSetElement,
ciSetType,
ciSimpleExpression,
ciSimpleStatement,
ciSimpleType,
ciSkipAnsiComment,
ciSkipBorComment,
ciSkipSlashesComment,
ciSkipSpace, //XM 20002511
ciSkipCRLFco, //XM 20002511
ciSkipCRLF, //XM 20002511
ciStatement,
ciStatementList,
ciStorageExpression,
ciStorageIdentifier,
ciStorageDefault,
ciStorageNoDefault,
ciStorageSpecifier,
ciStorageStored,
ciStringIdentifier,
ciStringStatement,
ciStringType,
ciStructuredType,
ciSubrangeType,
ciTagField,
ciTagFieldName,
ciTagFieldTypeName,
ciTerm,
ciTryStatement,
ciTypedConstant,
ciTypeDeclaration,
ciTypeId,
ciTypeKind,
ciTypeName,
ciTypeSection,
ciUnitFile,
ciUnitId,
ciUsedUnitName,
ciUsedUnitsList,
ciUsesClause,
ciVarAbsolute,
ciVarEqual,
ciVarDeclaration,
ciVariable,
ciVariableList,
ciVariableReference,
ciVariableTwo,
ciVariantIdentifier,
ciVariantSection,
ciVarParameter,
ciVarSection,
ciVisibilityAutomated,
ciVisibilityPrivate,
ciVisibilityProtected,
ciVisibilityPublic,
ciVisibilityPublished,
ciVisibilityUnknown,
ciWhileStatement,
ciWithStatement,
ciWriteAccessIdentifier
);
function ParserErrorName(Value: TmwParseError): string;
implementation
function ParserErrorName(Value: TmwParseError): string;
begin
result := GetEnumName(TypeInfo(TmwParseError), Integer(Value));
end;
end.

View File

@ -0,0 +1,343 @@
{
@abstract(Component wrapper for IFPS3 compiler and executer)
A component wrapper for IFPS3, including debugging support.
}
//{$I PascalScript.inc}
unit PSDump;
interface
uses
{$IFNDEF LINUX} Windows, {$ENDIF} SysUtils, Classes, uPSRuntime, uPSUtils, uPSComponent,
uPSCompiler, uPSC_dll, typInfo;
type
TPSOnCompCleanup = function (Sender: TObject; aComp: TPSPascalCompiler): Boolean of object;
TPSOnException = procedure (Sender: TPSExec; ExError: TPSError; const ExParam: tbtstring; ExObject: TObject; ProcNo, Position: Cardinal) of object;
TPSScriptExtension = class(TPSScriptDebugger)
private
FOnBeforeCleanUp: TPSOnCompCleanup;
FNeedCompiling: Boolean;
FOnScriptChange: TNotifyEvent;
FOnException: TPSOnException;
fItems: TStrings;
procedure GetCodeProps;
protected
function DoBeforeCleanup(Sender: TObject; aComp: TPSPascalCompiler):Boolean;
procedure DoScriptChange(sender:TObject);
public
constructor Create(AOwner: TComponent); override;
function Compile: Boolean; override;
function Execute: Boolean; override;
procedure GetValueDefs(aItems: TStrings);
procedure CompileIfNeeded;
property NeedCompiling : Boolean read FNeedCompiling;
published
property OnBeforeCleanUp: TPSOnCompCleanup read FOnBeforeCleanUp write FOnBeforeCleanUp;
Property OnScriptChange: TNotifyEvent read FOnScriptChange write fOnScriptChange;
property OnException: TPSOnException read FOnException write FOnException;
end;
implementation
function BeforeCleanup(Sender: TPSPascalCompiler): Boolean;
begin
Result := TPSScriptExtension(Sender.ID).DoBeforeCleanUp(TObject(Sender.ID),Sender);
end;
procedure CEException(Sender: TPSExec; ExError: TIFError; const ExParam: tbtstring; ExObject: TObject; ProcNo, Position: Cardinal);
begin
if (@TPSScriptExtension(Sender.ID).FOnException <> nil) then
TPSScriptExtension(Sender.ID).FOnException(Sender, ExError, ExParam, ExObject, ProcNo, Position);
end;
{ TPSScriptExtension }
function TPSScriptExtension.Compile: Boolean;
begin
Result := inherited Compile;
FNeedCompiling := not result;
end;
constructor TPSScriptExtension.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Comp.OnBeforeCleanup := {$IFDEF FPC}@{$ENDIF}BeforeCleanup;
Exec.OnException := {$IFDEF FPC}@{$ENDIF}CEException;
TStringList(script).OnChange := {$IFDEF FPC}@{$ENDIF}DoScriptChange;
FNeedCompiling := True;
end;
type
_TMyPascalCompiler = class(TPSPascalCompiler);
procedure TPSScriptExtension.GetCodeProps;
function TypeToString(t: TPSType; Definition: Boolean = False): string; forward;
function FunctionType(f: TObject): string;
const
FuncStr: array[Boolean] of string = ('procedure', 'function');
begin
if (f is TPSDelphiClassItemConstructor) then
Result := 'constructor'
else if (f is TPSDelphiClassItemMethod) then
Result := FuncStr[TPSDelphiClassItemMethod(f).Decl.Result <> nil]
else if (f is TPSProceduralType) then
Result := FuncStr[TPSProceduralType(f).ProcDef.Result <> nil]
else if (f is TPSRegProc) then
Result := FuncStr[TPSRegProc(f).Decl.Result <> nil]
else if (f is TPSInternalProcedure) then
Result := FuncStr[TPSInternalProcedure(f).Decl.Result <> nil]
else
Result := '';
end;
function ParamsToString(d: TPSParametersDecl; CheckResult: Boolean = True): string;
const
ParamStr: array [pmIn..pmInOut] of tbtstring = ('','out ','var ');
var
i: Integer;
begin
Result := '';
for i := 0 to d.ParamCount - 1 do
begin
if (Result <> '') then
Result := Result + '; ';
Result := Result + ParamStr[d.Params[i].Mode] + d.Params[i].OrgName;
if (d.Params[i].aType <> nil) then
Result := Result +': '+ TypeToString(d.Params[i].aType);
end;
if (Result <> '') then
Result := '('+Result+')';
if CheckResult and (d.Result <> nil) then
Result := Result + ': ' + TypeToString(d.Result);
end;
function ClassItemsToString(c: TPSCompileTimeClass; DoneList: TStrings = nil): string;
var
ci: TPSDelphiClassItem;
i, ii: Integer;
s: string;
Def: Cardinal;
ListFree: Boolean;
begin
Result := '';
if (c = nil) then
Exit;
if (DoneList = nil) then
begin
DoneList := TStringList.Create;
TStringList(DoneList).Sorted := True;
ListFree := True;
end
else
ListFree := False;
if (not c.Property_Find('', Def)) then
Def := 0;
for i := 0 to c.Count - 1 do
begin
ci := c.Items[i];
If (ci = nil) or (DoneList.IndexOf(ci.OrgName) > -1) then
Continue;
DoneList.Add(ci.OrgName);
if (ci is TPSDelphiClassItemConstructor) or (ci is TPSDelphiClassItemMethod) then
Result := Result + FunctionType(ci) + ' ' + ci.OrgName + ParamsToString(ci.Decl, not (ci is TPSDelphiClassItemConstructor)) + '; '
else if (ci is TPSDelphiClassItemProperty) then
begin
s := '';
for ii := 0 to ci.Decl.ParamCount - 1 do
begin
if (s <> '') then
s := s + ', ';
s := s + 'Index';
if (ii > 0) then
s := s + IntToStr(ii + 1);
s := s + ': ' + TypeToString(ci.Decl.Params[ii].aType);
end;
if (s <> '') then
s := '['+s+']';
Result := Result + 'property ' + ci.OrgName + s;
if (ci.Decl.Result <> nil) then
Result := Result + ': '+ TypeToString(ci.Decl.Result);
if (Cardinal(ci) = Def) then
Result := Result + '; default';
Result := Result + '; ';
end;
end;
Result := Result + ClassItemsToString(c.ClassInheritsFrom, DoneList);
if ListFree then
DoneList.Free;
end;
function TypeToString(t: TPSType; Definition: Boolean = False): string;
var
r: PIFPSRecordFieldTypeDef;
i: Integer;
begin
if (not Definition) and (t.OriginalName <> '') and (t.OriginalName[1] <> '!') then
Result := t.OriginalName
else if (t is TPSRecordType) then
begin
Result := 'record ';
for i := 0 to (t as TPSRecordType).RecValCount - 1 do
begin
r := (t as TPSRecordType).RecVal(i);
Result := Result + r.FieldOrgName + ': ' + TypeToString(r.aType) + '; ';
end;
Result := Result + 'end';
end
else if (t is TPSClassType) then
Result := 'class ' + ClassItemsToString((t as TPSClassType).Cl) + 'end'
else if (t is TPSProceduralType) then
Result := FunctionType(t) + ParamsToString((t as TPSProceduralType).ProcDef)
else if (t is TPSArrayType) then
Result := 'array of ' + TypeToString((t as TPSArrayType).ArrayTypeNo)
else if (t is TPSStaticArrayType) then
with (t as TPSStaticArrayType) do
Result := 'array[' + IntToStr(StartOffset) + '..' + IntToStr(StartOffset + Length) + ' of ' + TypeToString(ArrayTypeNo)
else if (t is TPSSetType) then
Result := 'set of ' + TypeToString((t as TPSSetType).SetType)
else if (t is TPSTypeLink) then
Result := TypeToString((t as TPSTypeLink).LinkTypeNo)
else if (t is TPSEnumType) then
begin
Result := '';
for i := 0 to t.Attributes.Count - 1 do
begin
if (Result <> '') then
Result := Result + ', ';
Result := Result + TPSConstant(t.Attributes[i].AType).OrgName;
end;
if (Result <> '') then
Result := '('+Result+')'
else
Result := 'enum';
end
else
Result := t.OriginalName;
end;
function IfRVariantToString(v: TIfRVariant): string;
begin
case v.FType.BaseType of
btU8: Result := IntToStr(v.tu8);
btS8: Result := IntToStr(v.ts8);
btU16: Result := IntToStr(v.tu16);
btS16: Result := IntToStr(v.ts16);
btU32: Result := IntToStr(v.tu32);
btS32: Result := IntToStr(v.ts32);
btSingle: Result := FloatToStr(v.tsingle);
btDouble: Result := FloatToStr(v.tdouble);
btExtended: Result := FloatToStr(v.textended);
btString: Result := tbtString(v.tstring);
{$IFNDEF PS_NOINT64}
btS64: Result := IntToStr(v.ts64);
{$ENDIF}
btChar: Result := '#' + IntToStr(Ord(v.tchar));
{$IFNDEF PS_NOWIDESTRING}
btWideString: Result := tbtwidestring(v.twidestring);
btWideChar: Result := '#' + IntToStr(Ord(v.twidechar));
{$ENDIF}
btCurrency: Result := FloatToStr(v.tcurrency);
btUnicodeString: Result := tbtunicodestring(v.tunistring);
else
Result := v.FType.OriginalName;
end;
end;
var
i : Integer;
begin
if (fItems = nil) then
Exit;
fItems.BeginUpdate;
try
fItems.Clear;
with _TMyPascalCompiler(Comp) do
begin
for i := 0 to FConstants.Count - 1 do
with TPSConstant(FConstants[i]) do
if (Value^.FType is TPSEnumType) then
Value^.FType.Attributes.Add(TPSAttributeType(FConstants[i]))
else
fItems.Add('const ' + OrgName + ' = ' + IfRVariantToString(Value^) + ';');
for i := 0 to FTypes.Count - 1 do
with TPSType(FTypes[i]) do
if (OriginalName <> '') and (OriginalName[1] <> '!') then
fItems.Add('type ' + OriginalName + ' = ' + TypeToString(TPSType(FTypes[i]), True) + ';');
for i := 0 to FVars.Count - 1 do
with TPSVar(FVars[i]) do
fItems.Add('var ' + OrgName + ': ' + TypeToString(TPSType(FVars[i]), True) + ';');
for i := 0 to FRegProcs.Count - 1 do
with TPSRegProc(FRegProcs[i]) do
fItems.Add(FunctionType(TObject(FRegProcs[i])) + ' ' + OrgName + ParamsToString(Decl) + '; forward;');
for i := 0 to FProcs.Count - 1 do
if (TPSProcedure(FProcs[i]) is TPSInternalProcedure) then
with TPSInternalProcedure(FProcs[i]) do
if (Name <> '') and (Name[1] <> '!') then
fItems.Add(FunctionType(TObject(FProcs[i])) + ' ' + OriginalName + ParamsToString(Decl) + '; forward;');
end;
finally
fItems.EndUpdate;
end;
end;
procedure TPSScriptExtension.GetValueDefs(aItems: TStrings);
begin
fItems := aItems;
try
Compile;
finally
fItems := nil;
end;
end;
function TPSScriptExtension.DoBeforeCleanup(Sender: TObject; aComp: TPSPascalCompiler): Boolean;
begin
Result := True;
if (fItems <> nil) then
GetCodeProps;
if (@FOnBeforeCleanUp <> nil) then
Result := FOnBeforeCleanUp(Sender, aComp);
end;
function TPSScriptExtension.Execute: Boolean;
begin
CompileIfNeeded;
Result := inherited Execute;
end;
procedure TPSScriptExtension.DoScriptChange(sender: TObject);
begin
FNeedCompiling := True;
if (@FOnScriptChange <> nil) then
FOnScriptChange(sender);
end;
procedure TPSScriptExtension.CompileIfNeeded;
begin
if FNeedCompiling then
Compile;
end;
end.

View File

@ -0,0 +1,11 @@
//Code Insight
{$DEFINE ciCHECKDUPLICATES}
{$DEFINE D8_NEWER1}
{$DEFINE D9_NEWER}
{$DEFINE D10_NEWER}
{.$DEFINE D11_NEWER}
{.$DEFINE D12_NEWER}
{$IFDEF FPC}
{$H+}
{$ENDIF}

View File

@ -0,0 +1,18 @@
unit v_Constants;
interface
//Code Insight Constants
const
{$IFNDEF FPC}
LineEnding = #13#10;
{$ENDIF}
ci_RangeError = 'Array range error at "%s" in statement: "%s"';
ci_UnknownMember = 'Unknown member "%s" in statement: "%s"';
ci_UnknownStruct = 'Cannot find proper structure for "%s" in statement: "%s"';
ci_UnknownInclude = 'Unknown include "%s"';
implementation
end.

View File

@ -0,0 +1,145 @@
unit v_MiscFunctions;
interface
type
TStringArray = array of string;
function Explode(Sep, s: string): TStringArray;
function PrePrepareString(s: string): string;
function PrepareString(s: string; out ArrayCount: Integer): string; overload;
function PrepareString(s: string): string; overload;
function GetFirstWord(s: string): string;
function CompressWhiteSpace(s: string): string;
implementation
uses
SysUtils, StrUtils;
function Explode(Sep, s: string): TStringArray;
var
p1, p2: Integer;
begin
SetLength(Result, 0);
s := s + Sep;
p1 := 1;
p2 := Pos(Sep, s);
while (p1 > 0) and (p2 > 0) do
begin
SetLength(Result, Length(Result) + 1);
Result[High(Result)] := Copy(s, p1, p2 - p1);
p1 := p2 + Length(Sep);
p2 := PosEx(Sep, s, p1 + 1);
end;
end;
function PrePrepareString(s: string): string;
var
i: Integer;
BraceCount: Integer;
begin
Result := '';
BraceCount := 0;
for i := 1 to Length(s) do
if (BraceCount = 0) and (s[i] in ['a'..'z', 'A'..'Z', '0'..'9', '_', '.', '[', ']']) then
Result := Result + s[i]
else if (s[i] = '(') then
Inc(BraceCount)
else if (s[i] = ')') then
Dec(BraceCount);
end;
function PrepareString(s: string; out ArrayCount: Integer): string; overload;
var
i: Integer;
BraceCount, BracketCount: Integer;
begin
Result := '';
BraceCount := 0;
BracketCount := 0;
ArrayCount := 0;
s := UpperCase(s);
for i := 1 to Length(s) do
if (BraceCount = 0) and (BracketCount = 0) and (s[i] in ['A'..'Z', '0'..'9', '_']) then
Result := Result + s[i]
else if (s[i] = '[') then
begin
if (BracketCount = 0) then
Inc(ArrayCount);
Inc(BracketCount);
end
else if (s[i] = ']') then
Dec(BracketCount)
else if (s[i] = '(') then
Inc(BraceCount)
else if (s[i] = ')') then
Dec(BraceCount);
end;
function PrepareString(s: string): string; overload;
var
a: Integer;
begin
Result := PrepareString(s, a);
end;
function GetFirstWord(s: string): string;
var
i: Integer;
begin
i := 1;
while (i <= Length(s)) and (s[i] in ['a'..'z', 'A'..'Z']) do
Inc(i);
Result := Copy(s, 1, i - 1);
end;
function CompressWhiteSpace(s: string): string;
function GetNextChar(s: string; i: Integer; out c: Char): Boolean;
begin
Result := True;
c := #0;
while (i <= Length(s)) and (s[i] in [#10, #11, #13, #32]) do
Inc(i);
if (i <= Length(s)) then
c := s[i]
else
Result := False;
end;
var
i: Integer;
c: Char;
LastSpace: Boolean;
begin
Result := '';
i := 1;
LastSpace := False;
while (i <= Length(s)) do
begin
if (s[i] in [#10, #11, #13, #32]) then
begin
if (not LastSpace) and (GetNextChar(s, i, c) and (c in ['a'..'z', 'A'..'Z', '0'..'9', '_'])) then
Result := Result + ' ';
Inc(i);
while (i <= Length(s)) and (s[i] in [#10, #11, #13, #32]) do
Inc(i);
LastSpace := True;
end
else
begin
LastSpace := False;
Result := Result + s[i];
if (s[i] in [':', ';']) then
begin
Result := Result + ' ';
LastSpace := True;
end;
Inc(i);
end;
end;
end;
end.

View File

@ -0,0 +1,585 @@
unit v_AutoCompleteForm;
interface
{$IFDEF FPC}
{$mode objfpc}{$H+}
{$ENDIF}
uses
Classes, SysUtils, Forms, Controls, Graphics, Dialogs,
StdCtrls, ExtCtrls,
{$IFDEF FPC}
LMessages,
lcltype
{$ELSE}
Windows,
Messages
{$ENDIF};
type
TInsertProc = procedure(Str: string) of object;
TAutoCompleteListBox = class(TListBox)
protected
fIndexList: array of Integer;
fList: TStrings;
fInsertList: TStrings;
fFilter: string;
procedure setItemList(List: TStrings);
procedure setInsertList(List: TStrings);
procedure setFilter(Filter: string);
procedure DblClick; override;
procedure DrawItem(Index: Integer; ARect: TRect; State: TOwnerDrawState); override;
{$IFDEF FPC}
procedure WMEraseBkgnd(var message: TLMEraseBkgnd); message LM_ERASEBKGND;
procedure WMVScroll(var message: TLMVScroll); message LM_VSCROLL;
procedure CNChar(var message: TLMessage); message CN_CHAR;
{$ELSE}
procedure WMEraseBkgnd(var message: TWMEraseBkgnd); message WM_ERASEBKGND;
procedure WMVScroll(var message: TWMVScroll); message WM_VSCROLL;
procedure CNChar(var message: TMessage); message CN_CHAR;
{$ENDIF}
public
ColumnSizes: array of Integer;
Redirect: TWinControl;
InsertProc: TInsertProc;
procedure setLists(ItemList, InsertList: TStrings);
function getInsert: string;
constructor Create(TheOwner: TComponent); override;
destructor Destroy; override;
published
property ItemList: TStrings read fList write setItemList;
property InsertList: TStrings read fInsertList write setInsertList;
property Filter: string read fFilter write setFilter;
end;
TAutoCompletePopup = class(TForm)
protected
l: TAutoCompleteListBox;
procedure DoShow; override;
function getRedirect: TWinControl;
procedure setRedirect(Control: TWinControl);
function getInsertProc: TInsertProc;
procedure setInsertProc(Proc: TInsertProc);
public
constructor Create(TheOwner: TComponent); override;
procedure Show(Pos: TPoint; ItemList, InsertList: TStrings; Filter: string = ''; Editor: TWinControl = nil); reintroduce;
procedure DoHide; override;
procedure HandleKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
procedure HandleKeyPress(Sender: TObject; var Key: char);
published
property ListBox: TAutoCompleteListBox read l;
property Redirect: TWinControl read getRedirect write setRedirect;
property InsertProc: TInsertProc read getInsertProc write setInsertProc;
end;
TParamHint = class(THintWindow)
public
constructor Create(TheOwner: TComponent); override;
procedure Paint; override;
end;
implementation
uses
StrUtils {$IFDEF FPC}, lclintf{$ENDIF}, Themes;
procedure TAutoCompleteListBox.setItemList(List: TStrings);
begin
fList.Assign(List);
end;
procedure TAutoCompleteListBox.setInsertList(List: TStrings);
begin
fInsertList.Assign(List);
end;
procedure TAutoCompleteListBox.setLists(ItemList, InsertList: TStrings);
var
i: Integer;
begin
//fList.Assign(ItemList);
//fInsertList.Assign(InsertList);
{$IFDEF FPC}LockSelectionChange;{$ENDIF}
fList.BeginUpdate;
try
fList.Clear;
fList.AddStrings(ItemList);
finally
fList.EndUpdate;
end;
fInsertList.BeginUpdate;
try
fInsertList.Clear;
fInsertList.AddStrings(InsertList);
finally
fInsertList.EndUpdate;
end;
Items.BeginUpdate;
try
Items.Clear;
Items.AddStrings(ItemList);
finally
Items.EndUpdate;
end;
fFilter := '';
SetLength(fIndexList, fList.Count);
for i := 0 to fList.Count - 1 do
fIndexList[i] := i;
if (fList.Count > 0) then
ItemIndex := 0
else
ItemIndex := -1;
{$IFDEF FPC}UnlockSelectionChange;{$ENDIF}
end;
procedure TAutoCompleteListBox.setFilter(Filter: string);
var
i, c, l, del: Integer;
begin
Filter := LowerCase(Filter);
if (Filter = fFilter) then
Exit;
{$IFDEF FPC}LockSelectionChange;{$ENDIF}
c := 0;
if (LeftStr(Filter, Length(fFilter)) = fFilter) then
begin
fFilter := Filter;
Items.BeginUpdate;
try
l := Length(fFilter);
del := 0;
for i := 0 to Items.Count - 1 do
if (LowerCase(LeftStr(fInsertList[fIndexList[i]], l)) <> fFilter) then
begin
Items.Delete(i - del);
Inc(del);
end
else
begin
if (ItemIndex = i) or (LowerCase(fInsertList[fIndexList[i]]) = fFilter) then
ItemIndex := c;
fIndexList[c] := fIndexList[i];
Inc(c);
end;
SetLength(fIndexList, c + 1);
finally
Items.EndUpdate;
end;
end
else
begin
fFilter := Filter;
Items.BeginUpdate;
try
Items.Clear;
l := Length(fFilter);
SetLength(fIndexList, fInsertList.Count);
for i := 0 to fInsertList.Count - 1 do
if (LowerCase(LeftStr(fInsertList[i], l)) = fFilter) then
begin
Items.Append(fList[i]);
if (LowerCase(fInsertList[i]) = fFilter) then
ItemIndex := i;
fIndexList[c] := i;
Inc(c);
end;
SetLength(fIndexList, c + 1);
finally
Items.EndUpdate;
end;
end;
{$IFDEF FPC}UnlockSelectionChange;{$ENDIF}
end;
function TAutoCompleteListBox.getInsert: string;
begin
if (ItemIndex < 0) or (ItemIndex > Length(fIndexList)) then
Result := ''
else
Result := fInsertList[fIndexList[ItemIndex]];
end;
{$IFDEF FPC}
procedure TAutoCompleteListBox.WMEraseBkgnd(var message: TLMEraseBkgnd);
{$ELSE}
procedure TAutoCompleteListBox.WMEraseBkgnd(var message: TWMEraseBkgnd);
{$ENDIF}
begin
if (Count < Round(Height / ItemHeight)) then
begin
Canvas.Brush.Color := clYellow;
FillRect(message.DC, Rect(0, Count * ItemHeight, Width, Height), HBRUSH({$IFDEF FPC}Brush.Reference.Handle{$ELSE}Parent.Brush.Handle{$ENDIF}));
end;
message.Result := 1;
end;
{$IFDEF FPC}
procedure TAutoCompleteListBox.WMVScroll(var message: TLMVScroll);
{$ELSE}
procedure TAutoCompleteListBox.WMVScroll(var message: TWMVScroll);
{$ENDIF}
var
c: Integer;
begin
{$IFDEF FPC}LockSelectionChange;{$ENDIF}
if (ItemIndex < TopIndex) then
ItemIndex := TopIndex
else
begin
c := Round(Height / ItemHeight) - 1;
if (ItemIndex > TopIndex + c) then
ItemIndex := TopIndex + c;
end;
{$IFDEF FPC}UnlockSelectionChange;{$ENDIF}
end;
{$IFDEF FPC}
procedure TAutoCompleteListBox.CNChar(var message: TLMessage);
{$ELSE}
procedure TAutoCompleteListBox.CNChar(var message: TMessage);
{$ENDIF}
begin
inherited;
{$IFDEF FPC}
if (message.Result = 0) and (Redirect <> nil) and (TLMChar(message).CharCode <> VK_DOWN) and (TLMChar(message).CharCode <> VK_UP) and (TLMChar(message).CharCode <> VK_RETURN) then
{$ELSE}
if (message.Result = 0) and (Redirect <> nil) and (TWMChar(message).CharCode <> VK_DOWN) and (TWMChar(message).CharCode <> VK_UP) and (TWMChar(message).CharCode <> VK_RETURN) then
{$ENDIF}
begin
Redirect.SetFocus;
Application.ProcessMessages;
SendMessage(Redirect.Handle, CN_Char, message.wParam, message.lParam);
end;
end;
procedure TAutoCompleteListBox.DblClick;
begin
if (Assigned(InsertProc)) then
InsertProc(GetInsert);
if (Owner is TForm) then
TForm(Owner).Hide;
end;
procedure TAutoCompleteListBox.DrawItem(Index: Integer; ARect: TRect; State: TOwnerDrawState);
var
p1, p2, p3, tl, col: Integer;
s, c: string;
begin
if (ItemIndex = -1) and (Count > 0) then
begin
{$IFDEF FPC}LockSelectionChange;{$ENDIF}
ItemIndex := TopIndex;
{$IFDEF FPC}UnlockSelectionChange;{$ENDIF}
end;
if {$IFDEF FPC}(odPainted in State) or{$ENDIF} (not Visible) or (ARect.Left > ClientRect.Right) or (ARect.Top > ClientRect.Bottom) or (Index < 0) or (Index >= Items.Count) then
Exit;
tl := ARect.Left;
col := 0;
with Canvas do
begin
Font.Style := [];
Font.Color := clBlack;
if (odSelected in State) then
Brush.Color := clHighlight
else if (odHotLight in State) then
Brush.Color := clHotLight
else if Odd(Index) then
Brush.Color := $F0F0F0
else
Brush.Color := clWhite;
FillRect(ARect);
s := Items[Index];
p1 := Pos('{', s);
p3 := 1;
while (p1 > 0) do
begin
p2 := PosEx('}', s, p1 + 1);
if (p2 > 0) then
begin
if (s[p2 - 1] <> '\') then
begin
c := Copy(s, p3, p1 - p3);
TextOut(tl, ARect.Top + Round((ItemHeight - TextHeight(c) + 0.001) / 2) , c);
tl := tl + TextWidth(c) + 1;
p3 := p2 + 1;
if ((p2 - p1 - 2) > 0) then
begin
c := LowerCase(Copy(s, p1 + 2, p2 - p1 - 2));
case Char(CharUpper({$IFNDEF FPC}PChar{$ELSE}Char{$ENDIF}(s[p1 + 1]))) of
'#', 'C': Font.Color := StringToColor(c);
'B':
if (c = '+') then
Font.Style := Font.Style + [fsBold]
else
Font.Style := Font.Style - [fsBold];
'I':
if (c = '+') then
Font.Style := Font.Style + [fsItalic]
else
Font.Style := Font.Style - [fsItalic];
'U':
if (c = '+') then
Font.Style := Font.Style + [fsUnderline]
else
Font.Style := Font.Style - [fsUnderline];
end;
end
else if (s[p1 + 1] = '|') then
begin
if (ColumnSizes[col] = -1) then
ColumnSizes[col] := Canvas.TextWidth('constructor') + 5;
tl := ColumnSizes[col];
Inc(Col);
end;
p1 := PosEx('{', s, p2 + 1);
end;
end
else
Break;
end;
if ((Length(s) - p3 + 1) > 0) then
begin
c := Copy(s, p3, Length(s) - p3 + 1);
TextOut(tl, ARect.Top + Round((ItemHeight - TextHeight(c) + 0.001) / 2), c);
end;
end;
end;
constructor TAutoCompleteListBox.Create(TheOwner: TComponent);
begin
inherited;
DoubleBuffered := True;
ControlStyle := ControlStyle + [csOpaque];
BorderStyle := bsNone;
Style := lbOwnerDrawFixed;
IntegralHeight := True;
{$IFDEF FPC}
ItemHeight := CalculateStandardItemHeight + 4;
{$ELSE}
ItemHeight := 19;
{$ENDIF}
Constraints.MinHeight := ItemHeight;
SetLength(ColumnSizes, 1);
ColumnSizes[0] := -1;
Redirect := nil;
InsertProc := nil;
Items.Clear;
fList := TStringList .Create;
fInsertList := TStringList.Create;
fFilter := '';
end;
destructor TAutoCompleteListBox.Destroy;
begin
FreeAndNil(fList);
FreeAndNil(fInsertList);
inherited;
end;
procedure TAutoCompletePopup.DoShow;
begin
//ClientHeight := Max(Min(Round(ClientHeight / l.ItemHeight), l.Count), 1) * l.ItemHeight;
//ClientHeight := Max(Round(ClientHeight / l.ItemHeight), 1) * l.ItemHeight;
end;
function TAutoCompletePopup.getRedirect: TWinControl;
begin
Result := ListBox.Redirect;
end;
procedure TAutoCompletePopup.setRedirect(Control: TWinControl);
begin
ListBox.Redirect := Control;
end;
function TAutoCompletePopup.getInsertProc: TInsertProc;
begin
Result := ListBox.InsertProc;
end;
procedure TAutoCompletePopup.setInsertProc(Proc: TInsertProc);
begin
ListBox.InsertProc := Proc;
end;
constructor TAutoCompletePopup.Create(TheOwner: TComponent);
begin
inherited;
l := TAutoCompleteListBox.Create(Self);
with l do
begin
Parent := Self;
Align := alClient;
OnKeyDown := {$IFDEF FPC}@{$ENDIF}HandleKeyDown;
OnKeyPress := {$IFDEF FPC}@{$ENDIF}HandleKeyPress;
end;
DefaultMonitor := dmMainForm;
FormStyle := fsStayOnTop;
{$IFDEF FPC}
ShowInTaskBar := stNever;
{$ENDIF}
BorderStyle := bsSizeToolWin;
BorderIcons := [];
SetWindowLong(Handle, GWL_STYLE, GetWindowLong(Handle, GWL_STYLE) and (not WS_CAPTION) or WS_BORDER);
Height := Height - GetSystemMetrics(SM_CYCAPTION);
DoubleBuffered := True;
ControlStyle := ControlStyle + [csOpaque];
ClientHeight := Round(ClientHeight / l.ItemHeight) * l.ItemHeight;
Constraints.MinHeight := l.ItemHeight;
Constraints.MinWidth := 100;
end;
procedure TAutoCompletePopup.DoHide;
begin
ListBox.Clear;
inherited;
end;
procedure TAutoCompletePopup.HandleKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
if Visible then
begin
case Key of
VK_UP:
if (ListBox.Count > 0) and (ListBox.ItemIndex > 0) then
ListBox.ItemIndex := ListBox.ItemIndex - 1;
VK_DOWN:
if (ListBox.Count > 0) and (ListBox.ItemIndex + 1 < ListBox.Count) then
ListBox.ItemIndex := ListBox.ItemIndex + 1;
VK_RETURN:
ListBox.DblClick;
VK_ESCAPE:
Hide;
else
Exit;
end;
Key := 0;
end;
end;
procedure TAutoCompletePopup.HandleKeyPress(Sender: TObject; var Key: char);
begin
if Visible and (not (Key in ['a'..'z', 'A'..'Z', '0'..'9', '_'])) then
if (Key in ['.', '(', '[', ';', ':']) then
ListBox.DblClick
else
Hide;
end;
procedure TAutoCompletePopup.Show(Pos: TPoint; ItemList, InsertList: TStrings; Filter: string = ''; Editor: TWinControl = nil);
begin
ListBox.setLists(ItemList, InsertList);
ListBox.Redirect := Editor;
ListBox.Filter := Filter;
Left := Pos.x;
Top := Pos.y;
inherited Show;
if (Editor <> nil) then
Editor.SetFocus;
end;
constructor TParamHint.Create(TheOwner: TComponent);
begin
inherited;
{$IFDEF FPC}
AutoHide := False;
{$ENDIF}
end;
procedure TParamHint.Paint;
function GetDrawTextFlags: Cardinal;
var
EffectiveAlignment: TAlignment;
begin
Result := DT_NOPREFIX or DT_VCENTER or DT_WORDBREAK;
EffectiveAlignment := Alignment;
if BiDiMode <> bdLeftToRight then
begin
Result := Result or DT_RTLREADING;
//change alignment if is RTL
if BiDiMode = bdRightToLeft then
begin
case Alignment of
taLeftJustify: EffectiveAlignment := taRightJustify;
taRightJustify: EffectiveAlignment := taLeftJustify;
end;
end;
end;
case EffectiveAlignment of
taLeftJustify: Result := Result or DT_LEFT;
taCenter: Result := Result or DT_CENTER;
taRightJustify: Result := Result or DT_RIGHT;
end;
end;
var
ARect: TRect;
Details: TThemedElementDetails;
begin
ARect := ClientRect;
if Color = clInfoBk then // draw using themes
begin
Details := ThemeServices.GetElementDetails(tttStandardLink);
ThemeServices.DrawElement(Canvas.Handle, Details, ARect);
end
else
begin
Canvas.Brush.Color := Color;
Canvas.Pen.Width := 1;
Canvas.FillRect(ARect);
DrawEdge(Canvas.Handle, ARect, BDR_RAISEDOUTER, BF_RECT);
end;
InflateRect(ARect, - 4, - 4);
Canvas.TextOut(ARect.Left, ARect.Top, Caption);
end;
end.

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff