mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-04-09 04:07:57 +02:00
PascalScript: Update to origin GIT: 97eefc260b41ba51328d95b4ed43669f38655720
git-svn-id: trunk@47304 -
This commit is contained in:
martin
parent
0fa2f8522f
commit
0cbf0e3443
@ -1,7 +1,9 @@
|
||||
|
||||
{$DEFINE PS_HAVEVARIANT}
|
||||
{$DEFINE PS_DYNARRAY}
|
||||
{$ifndef mswindows}
|
||||
{$DEFINE PS_NOIDISPATCH}
|
||||
{$endif}
|
||||
{.$if (fpc_version=2) and (fpc_release>=3) and (fpc_patch>=1)}
|
||||
{$if (fpc_version=2) and ((fpc_release=2) and (fpc_patch>=4)) or (fpc_release>2)}
|
||||
{$UNDEF FPC_OLD_FIX}
|
||||
@ -9,6 +11,11 @@
|
||||
{$UNDEF PS_FPCSTRINGWORKAROUND}
|
||||
{$DEFINE PS_RESBEFOREPARAMETERS}
|
||||
{$DEFINE x64_string_result_as_varparameter}
|
||||
{$ifdef mswindows}
|
||||
{$if (fpc_version=2) and (fpc_release>5)}
|
||||
{$DEFINE PS_FPC_HAS_COM}
|
||||
{$endif}
|
||||
{$endif}
|
||||
{FreePascal 2.3.1 and above has much Delphi compatibility bugs fixed}
|
||||
{$else}
|
||||
{$DEFINE FPC_OLD_FIX}
|
||||
|
||||
@ -30,9 +30,7 @@ uses
|
||||
uPSComponent,
|
||||
uPSDebugger,
|
||||
uPSComponent_Default,
|
||||
{$IFNDEF FPC}
|
||||
uPSComponent_COM,
|
||||
{$ENDIF}
|
||||
uPSComponent_DB,
|
||||
uPSComponent_Forms,
|
||||
uPSComponent_Controls,
|
||||
@ -45,9 +43,7 @@ begin
|
||||
TPSDllPlugin,
|
||||
TPSImport_Classes,
|
||||
TPSImport_DateUtils,
|
||||
{$IFNDEF FPC}
|
||||
TPSImport_ComObj,
|
||||
{$ENDIF}
|
||||
TPSImport_DB,
|
||||
TPSImport_Forms,
|
||||
TPSImport_Controls,
|
||||
|
||||
@ -51,7 +51,7 @@ Carlo Kok
|
||||
RemObjects Software
|
||||
"/>
|
||||
<Version Build="1"/>
|
||||
<Files Count="25">
|
||||
<Files Count="28">
|
||||
<Item1>
|
||||
<Filename Value="uPSRuntime.pas"/>
|
||||
<UnitName Value="uPSRuntime"/>
|
||||
@ -152,6 +152,18 @@ RemObjects Software
|
||||
<Filename Value="x86.inc"/>
|
||||
<Type Value="Include"/>
|
||||
</Item25>
|
||||
<Item26>
|
||||
<Filename Value="uPSComponent_COM.pas"/>
|
||||
<UnitName Value="uPSComponent_COM"/>
|
||||
</Item26>
|
||||
<Item27>
|
||||
<Filename Value="uPSC_comobj.pas"/>
|
||||
<UnitName Value="uPSC_comobj"/>
|
||||
</Item27>
|
||||
<Item28>
|
||||
<Filename Value="uPSR_comobj.pas"/>
|
||||
<UnitName Value="uPSR_comobj"/>
|
||||
</Item28>
|
||||
</Files>
|
||||
<UsageOptions>
|
||||
<UnitPath Value="$(PkgOutDir)"/>
|
||||
|
||||
@ -27,6 +27,7 @@ procedure SIRegisterTHANDLESTREAM(Cl: TPSPascalCompiler);
|
||||
procedure SIRegisterTMEMORYSTREAM(Cl: TPSPascalCompiler);
|
||||
{$ENDIF}
|
||||
procedure SIRegisterTFILESTREAM(Cl: TPSPascalCompiler);
|
||||
procedure SIRegisterTSTRINGSTREAM(Cl: TPSPascalCompiler);
|
||||
{$IFNDEF PS_MINIVCL}
|
||||
procedure SIRegisterTCUSTOMMEMORYSTREAM(Cl: TPSPascalCompiler);
|
||||
procedure SIRegisterTRESOURCESTREAM(Cl: TPSPascalCompiler);
|
||||
@ -83,6 +84,7 @@ begin
|
||||
RegisterMethod('procedure SetText(Text: PChar); ');
|
||||
RegisterProperty('Names', 'String Integer', iptr);
|
||||
RegisterProperty('Values', 'String String', iptRW);
|
||||
RegisterProperty('ValueFromIndex', 'String Integer', iptRW);
|
||||
RegisterMethod('function AddObject(S:String;AObject:TObject):integer');
|
||||
RegisterMethod('function GetText:PChar');
|
||||
RegisterMethod('function IndexofObject(AObject:tObject):Integer');
|
||||
@ -171,6 +173,14 @@ begin
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure SIRegisterTSTRINGSTREAM(Cl: TPSPascalCompiler);
|
||||
begin
|
||||
with Cl.AddClassN(cl.FindClass('TSTREAM'), 'TSTRINGSTREAM') do
|
||||
begin
|
||||
RegisterMethod('constructor CREATE(ASTRING:STRING)');
|
||||
end;
|
||||
end;
|
||||
|
||||
{$IFNDEF PS_MINIVCL}
|
||||
procedure SIRegisterTCUSTOMMEMORYSTREAM(Cl: TPSPascalCompiler);
|
||||
begin
|
||||
@ -306,6 +316,7 @@ begin
|
||||
begin
|
||||
SIRegisterTHANDLESTREAM(Cl);
|
||||
SIRegisterTFILESTREAM(Cl);
|
||||
SIRegisterTSTRINGSTREAM(Cl);
|
||||
{$IFNDEF PS_MINIVCL}
|
||||
SIRegisterTCUSTOMMEMORYSTREAM(Cl);
|
||||
SIRegisterTMEMORYSTREAM(Cl);
|
||||
|
||||
@ -21,6 +21,19 @@ implementation
|
||||
|
||||
procedure SIRegister_ComObj(cl: TPSPascalCompiler);
|
||||
begin
|
||||
{$IFDEF FPC}
|
||||
{$IFDEF PS_FPC_HAS_COM}
|
||||
cl.AddTypeS('HResult', 'LongInt');
|
||||
cl.AddTypeS('TGUID', 'record D1: LongWord; D2: Word; D3: Word; D4: array[0..7] of Byte; end;');
|
||||
cl.AddTypeS('TCLSID', 'TGUID');
|
||||
cl.AddTypeS('TIID', 'TGUID');
|
||||
cl.AddDelphiFunction('procedure OleCheck(Result: HResult);');
|
||||
cl.AddDelphiFunction('function StringToGUID(const S: string): TGUID;');
|
||||
cl.AddDelphiFunction('function CreateComObject(const ClassID: TGUID): IUnknown;');
|
||||
cl.AddDelphiFunction('function CreateOleObject(const ClassName: String): IDispatch;');
|
||||
cl.AddDelphiFunction('function GetActiveOleObject(const ClassName: String): IDispatch;');
|
||||
{$ENDIF}
|
||||
{$ELSE}
|
||||
cl.AddTypeS('HResult', 'LongInt');
|
||||
cl.AddTypeS('TGUID', 'record D1: LongWord; D2: Word; D3: Word; D4: array[0..7] of Byte; end;');
|
||||
cl.AddTypeS('TCLSID', 'TGUID');
|
||||
@ -34,6 +47,7 @@ begin
|
||||
{$ENDIF}
|
||||
cl.AddDelphiFunction('function CreateOleObject(const ClassName: String): IDispatch;');
|
||||
cl.AddDelphiFunction('function GetActiveOleObject(const ClassName: String): IDispatch;');
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
end.
|
||||
|
||||
@ -923,6 +923,7 @@ type
|
||||
FAllowNoBegin: Boolean;
|
||||
FAllowNoEnd: Boolean;
|
||||
FAllowUnit: Boolean;
|
||||
FAllowDuplicateRegister : Boolean;
|
||||
FBooleanShortCircuit: Boolean;
|
||||
FDebugOutput: tbtString;
|
||||
FOnExternalProc: TPSOnExternalProc;
|
||||
@ -1177,6 +1178,7 @@ type
|
||||
|
||||
property AllowNoEnd: Boolean read FAllowNoEnd write FAllowNoEnd;
|
||||
|
||||
property AllowDuplicateRegister : Boolean read FAllowDuplicateRegister write FAllowDuplicateRegister;
|
||||
|
||||
property BooleanShortCircuit: Boolean read FBooleanShortCircuit write FBooleanShortCircuit;
|
||||
|
||||
@ -1724,7 +1726,7 @@ procedure DisposeVariant(p: PIfRVariant);
|
||||
|
||||
implementation
|
||||
|
||||
uses {$IFDEF DELPHI5}ComObj, {$ENDIF}Classes, typInfo;
|
||||
uses {$IFDEF DELPHI5}ComObj, {$ENDIF}{$IFDEF PS_FPC_HAS_COM}ComObj, {$ENDIF}Classes, typInfo;
|
||||
|
||||
{$IFDEF DELPHI3UP}
|
||||
resourceString
|
||||
@ -2383,6 +2385,9 @@ begin
|
||||
raise EPSCompilerException.Create(RPS_OnUseEventOnly);
|
||||
end;
|
||||
|
||||
if not(AllowDuplicateRegister) and IsDuplicate(FastUpperCase(Name),[dcTypes, dcProcs, dcVars]) then
|
||||
Raise EPSCompilerException.CreateFmt(RPS_DuplicateIdent, [Name]);
|
||||
|
||||
case BaseType of
|
||||
btProcPtr: Result := TPSProceduralType.Create;
|
||||
BtTypeCopy: Result := TPSTypeLink.Create;
|
||||
@ -2908,8 +2913,8 @@ end;
|
||||
function TPSPascalCompiler.GetUnicodeString(Src: PIfRVariant; var s: Boolean): tbtunicodestring;
|
||||
begin
|
||||
case Src.FType.BaseType of
|
||||
btChar: Result := tbtWidestring(Src^.tchar);
|
||||
btString: Result := tbtWidestring(tbtstring(src^.tstring));
|
||||
btChar: Result := tbtunicodestring(Src^.tchar);
|
||||
btString: Result := tbtunicodestring(tbtstring(src^.tstring));
|
||||
btWideChar: Result := src^.twidechar;
|
||||
btWideString: Result := tbtWideString(src^.twidestring);
|
||||
btUnicodeString: result := tbtUnicodeString(src^.tunistring);
|
||||
@ -3564,12 +3569,12 @@ var
|
||||
h, l: Longint;
|
||||
x: TPSProcedure;
|
||||
begin
|
||||
h := MakeHash(s);
|
||||
if (s = 'RESULT') then
|
||||
begin
|
||||
Result := True;
|
||||
exit;
|
||||
end;
|
||||
h := MakeHash(s);
|
||||
if dcTypes in Check then
|
||||
for l := FTypes.Count - 1 downto 0 do
|
||||
begin
|
||||
@ -6035,7 +6040,7 @@ function TPSPascalCompiler.ProcessSub(BlockInfo: TPSBlockInfo): Boolean;
|
||||
for i := 0 to arr.count -1 do
|
||||
begin
|
||||
mType := GetTypeNo(BlockInfo, arr.Item[i]);
|
||||
if mType <> SetType.SetType then
|
||||
if (mType <> SetType.SetType) and not (IsIntType(mType.FBaseType) and IsIntType(SetType.SetType.BaseType)) then
|
||||
begin
|
||||
with MakeError('', ecTypeMismatch, '') do
|
||||
begin
|
||||
@ -6055,6 +6060,18 @@ function TPSPascalCompiler.ProcessSub(BlockInfo: TPSBlockInfo): Boolean;
|
||||
dataval.Free;
|
||||
exit;
|
||||
end;
|
||||
if (c < Low(Byte)) or (c > High(Byte)) then
|
||||
begin
|
||||
with MakeError('', ecTypeMismatch, '') do
|
||||
begin
|
||||
FCol := arr.item[i].Col;
|
||||
FRow := arr.item[i].Row;
|
||||
FPosition := arr.item[i].Pos;
|
||||
end;
|
||||
DataVal.Free;
|
||||
Result := False;
|
||||
exit;
|
||||
end;
|
||||
Set_MakeMember(c, dataval.Data.tstring);
|
||||
end else
|
||||
begin
|
||||
@ -6140,9 +6157,9 @@ function TPSPascalCompiler.ProcessSub(BlockInfo: TPSBlockInfo): Boolean;
|
||||
exit;
|
||||
end;
|
||||
if TPSType(FarrType).BaseType = btVariant then
|
||||
FArrType := FindAndAddType(self, '', 'array of variant');
|
||||
FArrType := at2ut(FindAndAddType(self, '!OPENARRAYOFVARIANT', 'array of variant'));
|
||||
if TPSType(FarrType).BaseType <> btArray then
|
||||
FArrType := FindAndAddType(self, '', 'array of variant');
|
||||
FArrType := at2ut(FindAndAddType(self, '!OPENARRAYOFVARIANT', 'array of variant'));
|
||||
|
||||
tmpp := AllocStackReg(FArrType);
|
||||
tmpc := AllocStackReg(FindBaseType(bts32));
|
||||
@ -8204,7 +8221,7 @@ function TPSPascalCompiler.ProcessSub(BlockInfo: TPSBlockInfo): Boolean;
|
||||
{$IFNDEF PS_NOWIDESTRING}
|
||||
else if ((t1.BaseType = btString) or (t1.BaseType = btChar) or (t1.BaseType = btPchar)or (t1.BaseType = btWideString) or (t1.BaseType = btWideChar) or (t1.BaseType = btUnicodeString)) and
|
||||
((t2.BaseType = btString) or (t2.BaseType = btChar) or (t2.BaseType = btPchar) or (t2.BaseType = btWideString) or (t2.BaseType = btWideChar) or (t2.BaseType = btUnicodeString)) then
|
||||
Result := at2ut(FindBaseType(btWideString))
|
||||
Result := at2ut(FindBaseType(btUnicodeString))
|
||||
{$ENDIF}
|
||||
else
|
||||
Result := nil;
|
||||
@ -8293,20 +8310,20 @@ function TPSPascalCompiler.ProcessSub(BlockInfo: TPSBlockInfo): Boolean;
|
||||
if (TPSValueData(p2).Data.tu8 <> 0) then
|
||||
begin
|
||||
with MakeWarning('', ewIsNotNeeded, '"and True"') do
|
||||
if p1.Pos>0 then
|
||||
if p2.Pos>0 then
|
||||
begin
|
||||
FRow := p1.Row;
|
||||
FCol := p1.Col;
|
||||
FPosition := p1.Pos;
|
||||
FRow := p2.Row;
|
||||
FCol := p2.Col;
|
||||
FPosition := p2.Pos;
|
||||
end;
|
||||
end
|
||||
else
|
||||
begin
|
||||
with MakeWarning('', ewCalculationAlwaysEvaluatesTo, 'False') do
|
||||
begin
|
||||
FRow := p1.Row;
|
||||
FCol := p1.Col;
|
||||
FPosition := p1.Pos;
|
||||
FRow := p2.Row;
|
||||
FCol := p2.Col;
|
||||
FPosition := p2.Pos;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
@ -8337,8 +8354,8 @@ function TPSPascalCompiler.ProcessSub(BlockInfo: TPSBlockInfo): Boolean;
|
||||
begin
|
||||
with MakeWarning('', ewCalculationAlwaysEvaluatesTo, 'True') do
|
||||
begin
|
||||
FRow := p1.Row;
|
||||
FCol := p1.Col;
|
||||
FRow := p2.Row;
|
||||
FCol := p2.Col;
|
||||
FPosition := p1.Pos;
|
||||
end;
|
||||
end
|
||||
@ -8346,9 +8363,9 @@ function TPSPascalCompiler.ProcessSub(BlockInfo: TPSBlockInfo): Boolean;
|
||||
begin
|
||||
with MakeWarning('', ewIsNotNeeded, '"or False"') do
|
||||
begin
|
||||
FRow := p1.Row;
|
||||
FCol := p1.Col;
|
||||
FPosition := p1.Pos;
|
||||
FRow := p2.Row;
|
||||
FCol := p2.Col;
|
||||
FPosition := p2.Pos;
|
||||
end;
|
||||
end
|
||||
end;
|
||||
@ -12259,6 +12276,7 @@ begin
|
||||
FParser.OnParserError := ParserError;
|
||||
FAutoFreeList := TPSList.Create;
|
||||
FOutput := '';
|
||||
FAllowDuplicateRegister := true;
|
||||
{$IFDEF PS_USESSUPPORT}
|
||||
FAllowUnit := true;
|
||||
{$ENDIF}
|
||||
@ -12407,6 +12425,10 @@ begin
|
||||
FType := GetTypeCopyLink(FType);
|
||||
if FType = nil then
|
||||
Raise EPSCompilerException.CreateFmt(RPS_UnableToRegisterConst, [name]);
|
||||
|
||||
if not(AllowDuplicateRegister) and IsDuplicate(FastUpperCase(Name),[dcProcs, dcVars, dcConsts]) then
|
||||
Raise EPSCompilerException.CreateFmt(RPS_DuplicateIdent, [Name]);
|
||||
|
||||
pc := TPSConstant.Create;
|
||||
pc.OrgName := name;
|
||||
pc.Name := FastUppercase(name);
|
||||
@ -13368,6 +13390,10 @@ begin
|
||||
if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly);
|
||||
Parser := TPSPascalParser.Create;
|
||||
Parser.SetText(Decl);
|
||||
|
||||
if not(AllowDuplicateRegister) and (FindType(Name)<>nil) then
|
||||
Raise EPSCompilerException.CreateFmt(RPS_DuplicateIdent, [Name]);
|
||||
|
||||
Result := ReadType(Name, Parser);
|
||||
if Result<>nil then
|
||||
begin
|
||||
@ -13475,6 +13501,9 @@ begin
|
||||
if not ParseMethod(Self, '', Decl, DOrgName, pDecl, FT) then
|
||||
Raise EPSCompilerException.CreateFmt(RPS_UnableToRegisterFunction, [Decl]);
|
||||
|
||||
if (FindProc(DOrgName)<>InvalidVal) and not(FAllowDuplicateRegister) then
|
||||
Raise EPSCompilerException.CreateFmt(RPS_DuplicateIdent, [Decl]);
|
||||
|
||||
p := TPSRegProc.Create;
|
||||
P.Name := FastUppercase(DOrgName);
|
||||
p.OrgName := DOrgName;
|
||||
@ -13508,6 +13537,8 @@ var
|
||||
begin
|
||||
if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly);
|
||||
f := FindType(Name);
|
||||
if (f<>nil) and not(FAllowDuplicateRegister) then
|
||||
Raise EPSCompilerException.CreateFmt(RPS_DuplicateIdent, [Name]);
|
||||
if (f <> nil) and (f is TPSInterfaceType) then
|
||||
begin
|
||||
result := TPSInterfaceType(f).Intf;
|
||||
@ -13544,7 +13575,8 @@ var
|
||||
begin
|
||||
if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly);
|
||||
Result := FindClass(tbtstring(aClass.ClassName));
|
||||
if Result <> nil then exit;
|
||||
if (Result<>nil) and not(FAllowDuplicateRegister) then
|
||||
Raise EPSCompilerException.CreateFmt(RPS_DuplicateIdent, [aClass.ClassName]);
|
||||
f := AddType(tbtstring(aClass.ClassName), btClass);
|
||||
Result := TPSCompileTimeClass.CreateC(aClass, Self, f);
|
||||
Result.FInheritsFrom := InheritsFrom;
|
||||
@ -13559,6 +13591,8 @@ var
|
||||
begin
|
||||
if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly);
|
||||
Result := FindClass(aClass);
|
||||
if (Result<>nil) and (Result.FInheritsFrom<>nil) and not(FAllowDuplicateRegister) then
|
||||
Raise EPSCompilerException.CreateFmt(RPS_DuplicateIdent, [aClass]);
|
||||
if Result <> nil then
|
||||
begin
|
||||
if InheritsFrom <> nil then
|
||||
@ -14107,7 +14141,7 @@ begin
|
||||
{$IFDEF PS_USESSUPPORT}
|
||||
ecNotAllowed : Result:=tbtstring(Format(RPS_NotAllowed,[Param]));
|
||||
ecUnitNotFoundOrContainsErrors: Result:=tbtstring(Format(RPS_UnitNotFound,[Param]));
|
||||
ecCrossReference: Result:=Format(RPS_CrossReference,[Param]);
|
||||
ecCrossReference: Result:=tbtstring(Format(RPS_CrossReference,[Param]));
|
||||
{$ENDIF}
|
||||
else
|
||||
Result := tbtstring(RPS_UnknownError);
|
||||
|
||||
@ -15,6 +15,7 @@ procedure RIRegisterTBITS(Cl: TPSRuntimeClassImporter);
|
||||
procedure RIRegisterTSTREAM(Cl: TPSRuntimeClassImporter);
|
||||
procedure RIRegisterTHANDLESTREAM(Cl: TPSRuntimeClassImporter);
|
||||
procedure RIRegisterTFILESTREAM(Cl: TPSRuntimeClassImporter);
|
||||
procedure RIRegisterTSTRINGSTREAM(Cl: TPSRuntimeClassImporter);
|
||||
{$IFNDEF PS_MINIVCL}
|
||||
procedure RIRegisterTCUSTOMMEMORYSTREAM(Cl: TPSRuntimeClassImporter);
|
||||
procedure RIRegisterTMEMORYSTREAM(Cl: TPSRuntimeClassImporter);
|
||||
@ -72,6 +73,15 @@ begin
|
||||
Self.Values[I]:= T;
|
||||
end;
|
||||
|
||||
procedure TStringsValueFromIndexR(Self: TStrings; var T: string; const I: Longint);
|
||||
begin
|
||||
T := Self.ValueFromIndex[I];
|
||||
end;
|
||||
procedure TStringsValueFromIndexW(Self: TStrings; Const T: String; I: Longint);
|
||||
begin
|
||||
Self.ValueFromIndex[I]:= T;
|
||||
end;
|
||||
|
||||
procedure RIRegisterTStrings(cl: TPSRuntimeClassImporter; Streams: Boolean); // requires TPersistent
|
||||
begin
|
||||
with Cl.Add(TStrings) do
|
||||
@ -112,6 +122,7 @@ begin
|
||||
RegisterVirtualMethod(@TStrings.SetText, 'SETTEXT');
|
||||
RegisterPropertyHelper(@TStringsNamesR, nil, 'NAMES');
|
||||
RegisterPropertyHelper(@TStringsValuesR, @TStringsValuesW, 'VALUES');
|
||||
RegisterPropertyHelper(@TStringsValueFromIndexR, @TStringsValueFromIndexW, 'VALUEFROMINDEX');
|
||||
RegisterVirtualMethod(@TSTRINGS.ADDOBJECT, 'ADDOBJECT');
|
||||
RegisterVirtualMethod(@TSTRINGS.GETTEXT, 'GETTEXT');
|
||||
RegisterMethod(@TSTRINGS.INDEXOFOBJECT, 'INDEXOFOBJECT');
|
||||
@ -224,6 +235,14 @@ begin
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure RIRegisterTSTRINGSTREAM(Cl: TPSRuntimeClassImporter);
|
||||
begin
|
||||
with Cl.Add(TSTRINGSTREAM) do
|
||||
begin
|
||||
RegisterConstructor(@TSTRINGSTREAM.CREATE, 'CREATE');
|
||||
end;
|
||||
end;
|
||||
|
||||
{$IFNDEF PS_MINIVCL}
|
||||
procedure RIRegisterTCUSTOMMEMORYSTREAM(Cl: TPSRuntimeClassImporter);
|
||||
begin
|
||||
@ -375,6 +394,7 @@ begin
|
||||
begin
|
||||
RIRegisterTHANDLESTREAM(Cl);
|
||||
RIRegisterTFILESTREAM(Cl);
|
||||
RIRegisterTSTRINGSTREAM(Cl);
|
||||
{$IFNDEF PS_MINIVCL}
|
||||
RIRegisterTCUSTOMMEMORYSTREAM(Cl);
|
||||
RIRegisterTMEMORYSTREAM(Cl);
|
||||
|
||||
@ -11,11 +11,16 @@ uses
|
||||
procedure RIRegister_ComObj(cl: TPSExec);
|
||||
|
||||
implementation
|
||||
uses
|
||||
{$IFDEF DELPHI3UP}
|
||||
ComObj;
|
||||
{$IFDEF FPC}
|
||||
{$IFDEF PS_FPC_HAS_COM}
|
||||
uses SysUtils, ComObj;
|
||||
{$ENDIF}
|
||||
{$ELSE}
|
||||
SysUtils, Ole2;
|
||||
{$IFDEF DELPHI3UP}
|
||||
uses ComObj;
|
||||
{$ELSE}
|
||||
uses SysUtils, Ole2;
|
||||
{$ENDIF}
|
||||
{$ENDIF}
|
||||
{$IFNDEF DELPHI3UP}
|
||||
|
||||
@ -89,6 +94,15 @@ end;
|
||||
|
||||
procedure RIRegister_ComObj(cl: TPSExec);
|
||||
begin
|
||||
{$IFDEF FPC}
|
||||
{$IFDEF PS_FPC_HAS_COM}
|
||||
cl.RegisterDelphiFunction(@OleCheck, 'OleCheck', cdRegister);
|
||||
cl.RegisterDelphiFunction(@StringToGUID, 'StringToGUID', cdRegister);
|
||||
cl.RegisterDelphiFunction(@CreateComObject, 'CreateComObject', cdRegister);
|
||||
cl.RegisterDelphiFunction(@CreateOleObject, 'CREATEOLEOBJECT', cdRegister);
|
||||
cl.RegisterDelphiFunction(@GetActiveOleObject, 'GETACTIVEOLEOBJECT', cdRegister);
|
||||
{$ENDIF}
|
||||
{$ELSE}
|
||||
cl.RegisterDelphiFunction(@OleCheck, 'OleCheck', cdRegister);
|
||||
{$IFNDEF PS_NOINTERFACES}
|
||||
{$IFDEF DELPHI3UP}
|
||||
@ -98,6 +112,7 @@ begin
|
||||
{$ENDIF}
|
||||
cl.RegisterDelphiFunction(@CreateOleObject, 'CREATEOLEOBJECT', cdRegister);
|
||||
cl.RegisterDelphiFunction(@GetActiveOleObject, 'GETACTIVEOLEOBJECT', cdRegister);
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
end.
|
||||
|
||||
@ -9,7 +9,7 @@ Copyright (C) 2000-2009 by Carlo Kok (ck@carlo-kok.com)
|
||||
|
||||
interface
|
||||
uses
|
||||
SysUtils, uPSUtils{$IFDEF DELPHI6UP}, variants{$ENDIF}{$IFNDEF PS_NOIDISPATCH}{$IFDEF DELPHI3UP}, ActiveX, Windows{$ELSE}, Ole2{$ENDIF}{$ENDIF};
|
||||
SysUtils, uPSUtils{$IFDEF DELPHI6UP}, variants{$ENDIF}{$IFDEF MACOS},uPSCMac{$ELSE}{$IFNDEF PS_NOIDISPATCH}{$IFDEF DELPHI3UP}, ActiveX, Windows{$ELSE}, Ole2{$ENDIF}{$ENDIF}{$ENDIF};
|
||||
|
||||
|
||||
type
|
||||
@ -1101,7 +1101,7 @@ function IDispatchInvoke(Self: IDispatch; PropertySet: Boolean; const Name: tbtS
|
||||
|
||||
implementation
|
||||
uses
|
||||
TypInfo {$IFDEF DELPHI3UP}{$IFNDEF FPC} , ComObj {$ENDIF}{$ENDIF};
|
||||
TypInfo {$IFDEF DELPHI3UP}{$IFNDEF FPC}{$IFNDEF KYLIX} , ComObj {$ENDIF}{$ENDIF}{$ENDIF}{$IFDEF PS_FPC_HAS_COM}, ComObj{$ENDIF};
|
||||
|
||||
{$IFDEF DELPHI3UP }
|
||||
resourceString
|
||||
@ -1820,12 +1820,34 @@ procedure DestroyHeapVariant2(v: Pointer; aType: TPSTypeRec); forward;
|
||||
const
|
||||
NeedFinalization = [btStaticArray, btRecord, btArray, btPointer, btVariant {$IFNDEF PS_NOINTERFACES}, btInterface{$ENDIF}, btString {$IFNDEF PS_NOWIDESTRING}, btUnicodestring,btWideString{$ENDIF}];
|
||||
|
||||
type
|
||||
TDynArrayRecHeader = packed record
|
||||
{$ifdef FPC}
|
||||
refCnt : ptrint;
|
||||
high : tdynarrayindex;
|
||||
{$else}
|
||||
{$ifdef CPUX64}
|
||||
_Padding: LongInt; // Delphi XE2+ expects 16 byte align
|
||||
{$endif}
|
||||
/// dynamic array reference count (basic garbage memory mechanism)
|
||||
refCnt: Longint;
|
||||
/// length in element count
|
||||
// - size in bytes = length*ElemSize
|
||||
length: NativeInt;
|
||||
{$endif}
|
||||
end;
|
||||
TDynArrayRec = packed record
|
||||
header : TDynArrayRecHeader;
|
||||
datas : pointer;
|
||||
end;
|
||||
PDynArrayRec = ^TDynArrayRec;
|
||||
|
||||
procedure FinalizeVariant(p: Pointer; aType: TPSTypeRec);
|
||||
var
|
||||
t: TPSTypeRec;
|
||||
elsize: Cardinal;
|
||||
i, l: Longint;
|
||||
darr: Pointer;
|
||||
darr: PDynArrayRec;
|
||||
begin
|
||||
case aType.BaseType of
|
||||
btString: tbtString(p^) := '';
|
||||
@ -1857,15 +1879,18 @@ begin
|
||||
btArray:
|
||||
begin
|
||||
if IPointer(P^) = 0 then exit;
|
||||
darr := Pointer(IPointer(p^) - PointerSize2);
|
||||
if Longint(darr^) < 0 then exit;// refcount < 0 means don't free
|
||||
Dec(Longint(darr^));
|
||||
if Longint(darr^) <> 0 then exit;
|
||||
darr := PDynArrayRec(IPointer(p^) - sizeof(TDynArrayRecHeader));
|
||||
if darr^.header.refCnt < 0 then exit;// refcount < 0 means don't free
|
||||
Dec(darr^.header.refCnt);
|
||||
if darr^.header.refCnt <> 0 then exit;
|
||||
t := TPSTypeRec_Array(aType).ArrayType;
|
||||
elsize := t.RealSize;
|
||||
darr := Pointer(IPointer(darr) + PointerSize);
|
||||
l := Longint(darr^) {$IFDEF FPC}+1{$ENDIF};
|
||||
darr := Pointer(IPointer(darr) + PointerSize);
|
||||
{$IFDEF FPC}
|
||||
l := darr^.header.high + 1;
|
||||
{$ELSE}
|
||||
l := darr^.header.length;
|
||||
{$ENDIF FPC}
|
||||
darr := @darr^.datas;
|
||||
case t.BaseType of
|
||||
btString, {$IFNDEF PS_NOWIDESTRING}
|
||||
btUnicodeString, btWideString, {$ENDIF}{$IFNDEF PS_NOINTERFACES}btInterface, {$ENDIF}btArray, btStaticArray,
|
||||
@ -1878,7 +1903,7 @@ begin
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
FreeMem(Pointer(IPointer(p^) - IPointer(PointerSize2)), IPointer(Cardinal(l) * elsize) + IPointer(PointerSize2));
|
||||
FreeMem(Pointer(IPointer(p^) - SizeOf(TDynArrayRecHeader)), IPointer(Cardinal(l) * elsize) + SizeOf(TDynArrayRecHeader));
|
||||
Pointer(P^) := nil;
|
||||
end;
|
||||
btRecord:
|
||||
@ -3560,10 +3585,10 @@ begin
|
||||
case aType.BaseType of
|
||||
btU8: Result := chr(tbtu8(src^));
|
||||
btU16: Result := widechar(src^);
|
||||
btChar: Result := tbtwidestring(tbtchar(Src^));
|
||||
btPchar: Result := tbtwidestring(pansichar(src^));
|
||||
btChar: Result := tbtunicodestring(tbtchar(Src^));
|
||||
btPchar: Result := tbtunicodestring(pansichar(src^));
|
||||
btWideChar: Result := tbtwidechar(Src^);
|
||||
btString: Result := tbtwidestring(tbtstring(src^));
|
||||
btString: Result := tbtunicodestring(tbtstring(src^));
|
||||
btWideString: Result := tbtwidestring(src^);
|
||||
btVariant: Result := Variant(src^);
|
||||
btUnicodeString: result := tbtUnicodeString(src^);
|
||||
@ -4023,7 +4048,7 @@ begin
|
||||
Pointer(Dest^) := Pointer(Src^);
|
||||
if Pointer(Dest^) <> nil then
|
||||
begin
|
||||
Inc(Longint(Pointer(IPointer(Dest^)-(2*PointerSize))^)); // RefCount
|
||||
Inc(PDynArrayRec(PAnsiChar(Dest^) - SizeOf(TDynArrayRecHeader))^.header.refCnt);
|
||||
end;
|
||||
Dest := Pointer(IPointer(Dest) + PointerSize);
|
||||
Src := Pointer(IPointer(Src) + PointerSize);
|
||||
@ -4152,38 +4177,42 @@ end;
|
||||
function PSDynArrayGetLength(arr: Pointer; aType: TPSTypeRec): Longint;
|
||||
begin
|
||||
if aType.BaseType <> btArray then raise Exception.Create(RPS_InvalidArray);
|
||||
if arr = nil then Result := 0 else Result := Longint(Pointer(IPointer(arr)-PointerSize)^) {$IFDEF FPC} +1 {$ENDIF};
|
||||
if arr = nil then Result := 0 else result:=PDynArrayRec(PAnsiChar(arr) - SizeOf(TDynArrayRecHeader))^.header.{$IFDEF FPC}high + 1{$ELSE}length{$ENDIF FPC};
|
||||
end;
|
||||
|
||||
procedure PSDynArraySetLength(var arr: Pointer; aType: TPSTypeRec; NewLength: Longint);
|
||||
var
|
||||
elSize, i, OldLen: Longint;
|
||||
p: Pointer;
|
||||
darr : PDynArrayRec;
|
||||
begin
|
||||
if aType.BaseType <> btArray then raise Exception.Create(RPS_InvalidArray);
|
||||
OldLen := PSDynArrayGetLength(arr, aType);
|
||||
elSize := TPSTypeRec_Array(aType).ArrayType.RealSize;
|
||||
if NewLength<0 then
|
||||
NewLength:=0;
|
||||
if (OldLen = 0) and (NewLength = 0) then exit; // already are both 0
|
||||
if (OldLen <> 0) and (Longint(Pointer(IPointer(Arr)-PointerSize2)^) = 1) then // unique copy of this dynamic array
|
||||
if (OldLen = NewLength) then exit; // already same size, noop
|
||||
darr := PDynArrayRec(PAnsiChar(Arr) - SizeOf(TDynArrayRecHeader));
|
||||
if (OldLen <> 0) and (darr^.header.refCnt = 1) then // unique copy of this dynamic array
|
||||
begin
|
||||
for i := NewLength to OldLen -1 do
|
||||
begin
|
||||
if TPSTypeRec_Array(aType).ArrayType.BaseType in NeedFinalization then
|
||||
FinalizeVariant(Pointer(IPointer(arr) + Cardinal(elsize * i)), TPSTypeRec_Array(aType).ArrayType);
|
||||
end;
|
||||
arr := Pointer(IPointer(Arr)-PointerSize2);
|
||||
if NewLength <= 0 then
|
||||
begin
|
||||
//FreeMem(arr, NewLength * elsize + PointerSize2);
|
||||
FreeMem(arr, Longint(NewLength * elsize) + Longint(PointerSize2));
|
||||
FreeMem(darr);
|
||||
arr := nil;
|
||||
exit;
|
||||
end;
|
||||
//ReallocMem(arr, NewLength * elSize + PointerSize2);
|
||||
ReallocMem(arr, Longint(NewLength * elSize) + Longint(PointerSize2));
|
||||
arr := Pointer(IPointer(Arr)+PointerSize);
|
||||
Longint(Arr^) := NewLength {$IFDEF FPC} -1 {$ENDIF};
|
||||
arr := Pointer(IPointer(Arr)+PointerSize);
|
||||
ReallocMem(darr, Longint(NewLength * elSize) + SizeOf(TDynArrayRecHeader));
|
||||
{$IFDEF FPC}
|
||||
darr^.header.high := NewLength -1;
|
||||
{$ELSE}
|
||||
darr^.header.length := NewLength;
|
||||
{$ENDIF}
|
||||
arr := @darr^.datas;
|
||||
for i := OldLen to NewLength -1 do
|
||||
begin
|
||||
InitializeVariant(Pointer(IPointer(arr) + Cardinal(elsize * i)), TPSTypeRec_Array(aType).ArrayType);
|
||||
@ -4192,39 +4221,40 @@ begin
|
||||
begin
|
||||
if NewLength = 0 then
|
||||
begin
|
||||
if Longint(Pointer(IPointer(Arr)-PointerSize2)^) = 1 then
|
||||
//FreeMem(Pointer(IPointer(Arr)-PointerSize2), OldLen * elSize + PointerSize2)
|
||||
FreeMem(Pointer(IPointer(Arr)-PointerSize2), Longint(OldLen * elSize) + Longint(PointerSize2))
|
||||
else if Longint(Pointer(IPointer(Arr)-PointerSize2)^) > 0 then
|
||||
Dec(Longint(Pointer(IPointer(Arr)-PointerSize2)^));
|
||||
FinalizeVariant(@arr, aType);
|
||||
arr := nil;
|
||||
exit;
|
||||
end;
|
||||
//GetMem(p, NewLength * elSize + PointerSize2);
|
||||
GetMem(p, Longint(NewLength * elSize) + Longint(PointerSize2));
|
||||
Longint(p^) := 1;
|
||||
p:= Pointer(IPointer(p)+PointerSize);
|
||||
Longint(p^) := NewLength {$IFDEF FPC} -1 {$ENDIF};
|
||||
p := Pointer(IPointer(p)+PointerSize);
|
||||
GetMem(darr, Longint(NewLength * elSize) + SizeOf(TDynArrayRecHeader));
|
||||
{$IFDEF CPUX64}
|
||||
darr^.header._Padding:=0;
|
||||
{$ENDIF CPUX64}
|
||||
darr^.header.refCnt:=1;
|
||||
{$IFDEF FPC}
|
||||
darr^.header.high := NewLength - 1;
|
||||
{$ELSE}
|
||||
darr^.header.length := NewLength;
|
||||
{$ENDIF FPC}
|
||||
for i := 0 to NewLength -1 do
|
||||
begin
|
||||
InitializeVariant(Pointer(IPointer(@darr^.datas) + Cardinal(elsize * i)), TPSTypeRec_Array(aType).ArrayType);
|
||||
end;
|
||||
if OldLen <> 0 then
|
||||
begin
|
||||
if OldLen > NewLength then
|
||||
CopyArrayContents(p, arr, NewLength, TPSTypeRec_Array(aType).ArrayType)
|
||||
CopyArrayContents(@darr^.datas, arr, NewLength, TPSTypeRec_Array(aType).ArrayType)
|
||||
else
|
||||
CopyArrayContents(p, arr, OldLen, TPSTypeRec_Array(aType).ArrayType);
|
||||
CopyArrayContents(@darr^.datas, arr, OldLen, TPSTypeRec_Array(aType).ArrayType);
|
||||
FinalizeVariant(@arr, aType);
|
||||
end;
|
||||
arr := p;
|
||||
for i := OldLen to NewLength -1 do
|
||||
begin
|
||||
InitializeVariant(Pointer(IPointer(arr) + Cardinal(elsize * i)), TPSTypeRec_Array(aType).ArrayType);
|
||||
end;
|
||||
arr := @darr^.datas;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
|
||||
{$IFDEF FPC}
|
||||
|
||||
function OleErrorMessage(ErrorCode: HResult): tbtString;
|
||||
begin
|
||||
Result := SysErrorMessage(ErrorCode);
|
||||
@ -9041,11 +9071,14 @@ var
|
||||
arr: TPSVariantIFC;
|
||||
begin
|
||||
Arr := NewTPSVariantIFC(Stack[Stack.Count-2], True);
|
||||
if (arr.Dta = nil) or (arr.aType.BaseType <> btArray) then
|
||||
if (arr.aType.BaseType <> btStaticArray) and ((arr.Dta = nil) or (arr.aType.BaseType <> btArray)) then
|
||||
begin
|
||||
Result := false;
|
||||
exit;
|
||||
end;
|
||||
if arr.aType.BaseType = btStaticArray then
|
||||
Stack.SetInt(-1, TPSTypeRec_StaticArray(arr.aType).Size)
|
||||
else
|
||||
Stack.SetInt(-1, PSDynArrayGetLength(Pointer(arr.Dta^), arr.aType));
|
||||
Result := True;
|
||||
end;
|
||||
@ -9343,7 +9376,9 @@ begin
|
||||
RegisterDelphiFunction(@VarIsEmpty, 'VARISEMPTY', cdRegister);
|
||||
RegisterDelphiFunction(@Null, 'NULL', cdRegister);
|
||||
RegisterDelphiFunction(@VarIsNull, 'VARISNULL', cdRegister);
|
||||
{$IFNDEF FPC}
|
||||
RegisterDelphiFunction(@VarType, 'VARTYPE', cdRegister);
|
||||
{$ENDIF}
|
||||
{$IFNDEF PS_NOIDISPATCH}
|
||||
RegisterDelphiFunction(@IDispatchInvoke, 'IDISPATCHINVOKE', cdregister);
|
||||
{$ENDIF}
|
||||
@ -9575,7 +9610,7 @@ begin
|
||||
{$IFDEF DELPHI2009UP}
|
||||
btUnicodeString: begin
|
||||
tvarrec(p^).VType := vtUnicodeString;
|
||||
tbtunicodestring(TVarRec(p^).VWideString) := tbtunicodestring(cp^);
|
||||
tbtunicodestring(TVarRec(p^).VUnicodeString) := tbtunicodestring(cp^);
|
||||
end;
|
||||
{$ELSE}
|
||||
btUnicodeString,
|
||||
@ -12107,8 +12142,8 @@ var
|
||||
MyLen: Longint;
|
||||
begin
|
||||
MyLen := ((FLength shr 12) + 1) shl 12;
|
||||
|
||||
SetCapacity(MyLen);
|
||||
if fCapacity < MyLen then
|
||||
SetCapacity(((MyLen + MemDelta) div MemDelta) * MemDelta);
|
||||
end;
|
||||
|
||||
procedure TPSStack.Clear;
|
||||
@ -12626,7 +12661,11 @@ begin
|
||||
if not Succeeded(i) then
|
||||
begin
|
||||
if i = DISP_E_EXCEPTION then
|
||||
{$IFDEF FPC}
|
||||
raise Exception.Create(ExceptInfo.Source+': '+ExceptInfo.Description)
|
||||
{$ELSE}
|
||||
raise Exception.Create(ExceptInfo.bstrSource+': '+ExceptInfo.bstrDescription)
|
||||
{$ENDIF}
|
||||
else
|
||||
raise Exception.Create(SysErrorMessage(i));
|
||||
end;
|
||||
|
||||
@ -605,6 +605,7 @@ begin
|
||||
{$ENDIF}
|
||||
btInterface, btArray, btVariant, btStaticArray:
|
||||
GetPtr(res);
|
||||
btRecord,
|
||||
btSet:
|
||||
begin
|
||||
if res.aType.RealSize > PointerSize then GetPtr(res);
|
||||
@ -624,6 +625,7 @@ begin
|
||||
{$ENDIF}
|
||||
btInterface, btArray, btVariant, btStaticArray:
|
||||
GetPtr(res);
|
||||
btRecord,
|
||||
btSet:
|
||||
begin
|
||||
if res.aType.RealSize > PointerSize then GetPtr(res);
|
||||
@ -661,7 +663,7 @@ begin
|
||||
btu32,bts32: tbtu32(res.dta^) := _RAX;
|
||||
btPChar: pansichar(res.dta^) := Pansichar(_RAX);
|
||||
bts64: tbts64(res.dta^) := Int64(_RAX);
|
||||
btCurrency: tbtCurrency(res.Dta^) := Int64(_RAX);
|
||||
btCurrency: tbts64(res.Dta^) := Int64(_RAX);
|
||||
btInterface,
|
||||
btVariant,
|
||||
{$IFDEF x64_string_result_as_varparameter}
|
||||
|
||||
@ -246,7 +246,7 @@ const
|
||||
|
||||
function TPSExec.InnerfuseCall(_Self, Address: Pointer; CallingConv: TPSCallingConvention; Params: TPSList; res: PPSVariantIFC): Boolean;
|
||||
var
|
||||
a, Stack: ansistring;
|
||||
Stack: ansistring;
|
||||
I: Longint;
|
||||
RegUsage: Byte;
|
||||
CallData: TPSList;
|
||||
|
||||
Loading…
Reference in New Issue
Block a user