mirror of
https://github.com/moparisthebest/Simba
synced 2024-11-25 10:42:20 -05:00
Oh right, forgot the other files :)
This commit is contained in:
Niels
parent
70599f5a92
commit
6cf764e3f4
2882
Projects/SAMufasaGUI/CastaliaPasLex.pas
Normal file
2882
Projects/SAMufasaGUI/CastaliaPasLex.pas
Normal file
File diff suppressed because it is too large
Load Diff
322
Projects/SAMufasaGUI/CastaliaPasLexTypes.pas
Normal file
322
Projects/SAMufasaGUI/CastaliaPasLexTypes.pas
Normal 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.
|
||||||
|
|
||||||
5955
Projects/SAMufasaGUI/CastaliaSimplePasPar.pas
Normal file
5955
Projects/SAMufasaGUI/CastaliaSimplePasPar.pas
Normal file
File diff suppressed because it is too large
Load Diff
330
Projects/SAMufasaGUI/CastaliaSimplePasParTypes.pas
Normal file
330
Projects/SAMufasaGUI/CastaliaSimplePasParTypes.pas
Normal 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.
|
||||||
|
|
||||||
343
Projects/SAMufasaGUI/PSDump.pas
Normal file
343
Projects/SAMufasaGUI/PSDump.pas
Normal 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.
|
||||||
11
Projects/SAMufasaGUI/ValistusDefines.inc
Normal file
11
Projects/SAMufasaGUI/ValistusDefines.inc
Normal 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}
|
||||||
18
Projects/SAMufasaGUI/v_Constants.pas
Normal file
18
Projects/SAMufasaGUI/v_Constants.pas
Normal 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.
|
||||||
145
Projects/SAMufasaGUI/v_MiscFunctions.pas
Normal file
145
Projects/SAMufasaGUI/v_MiscFunctions.pas
Normal 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.
|
||||||
585
Projects/SAMufasaGUI/v_autocompleteform.pas
Normal file
585
Projects/SAMufasaGUI/v_autocompleteform.pas
Normal 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.
|
||||||
|
|
||||||
1259
Projects/SAMufasaGUI/v_ideCodeInsight.pas
Normal file
1259
Projects/SAMufasaGUI/v_ideCodeInsight.pas
Normal file
File diff suppressed because it is too large
Load Diff
1675
Projects/SAMufasaGUI/v_ideCodeParser.pas
Normal file
1675
Projects/SAMufasaGUI/v_ideCodeParser.pas
Normal file
File diff suppressed because it is too large
Load Diff
Loading…
Reference in New Issue
Block a user