1
0
mirror of https://github.com/moparisthebest/Simba synced 2024-11-22 17:22:21 -05:00

Merge branch 'master' of ssh://villavu.com:54367/simba

Conflicts:
	Projects/SAMufasaGUI/ValistusDefines.inc
	Projects/SAMufasaGUI/v_autocompleteform.pas
This commit is contained in:
Merlijn Wajer 2010-03-26 23:15:03 +01:00
commit edb2b2194d
7 changed files with 9840 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

@ -5,3 +5,7 @@
{$DEFINE D10_NEWER} {$DEFINE D10_NEWER}
{.$DEFINE D11_NEWER} {.$DEFINE D11_NEWER}
{.$DEFINE D12_NEWER} {.$DEFINE D12_NEWER}
{$IFDEF FPC}
{$H+}
{$ENDIF}

View File

@ -2,6 +2,10 @@ unit v_AutoCompleteForm;
interface interface
{$IFDEF FPC}
{$mode objfpc}{$H+}
{$ENDIF}
uses uses
Classes, SysUtils, Forms, Controls, Graphics, Dialogs, Classes, SysUtils, Forms, Controls, Graphics, Dialogs,
StdCtrls, ExtCtrls, StdCtrls, ExtCtrls,