Delphi/pascalscript
Delphi/pascalscript
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge branch 'master' of github.com:remobjects/pascalscript

Browse Source
This commit is contained in:
evgenyk 2014-06-26 16:47:55 +03:00
commit d30f5e9e4d
10 changed files with 122 additions and 33 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
.gitignore vendored
View File

@ -1 +1,2 @@
*.dcu
*.dcu
__history

14
Source/PascalScriptFCL.lpk
View File

@ -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)"/>

9
Source/PascalScriptFPC.inc
View File

@ -1,7 +1,9 @@
{$DEFINE PS_HAVEVARIANT}
{$DEFINE PS_DYNARRAY}
{$DEFINE PS_NOIDISPATCH}
{$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}

4
Source/PascalScript_Core_Reg.pas
View File

@ -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,

2
Source/pascalscript.pas
View File

@ -15,7 +15,7 @@ uses
uPSDisassembly, uPSPreProcessor, uPSR_buttons, uPSR_classes, uPSR_controls,
uPSR_dateutils, uPSR_DB, uPSR_dll, uPSR_extctrls, uPSR_forms,
uPSR_graphics, uPSR_menus, uPSR_std, uPSR_stdctrls, uPSUtils,
LazarusPackageIntf;
uPSComponent_COM, uPSC_comobj, uPSR_comobj, LazarusPackageIntf;
implementation

14
Source/uPSC_comobj.pas
View File

@ -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.

52
Source/uPSCompiler.pas
View File

@ -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
@ -1804,7 +1806,6 @@ const
RPS_AbstractClass = 'Abstract Class Construction';
RPS_UnknownWarning = 'Unknown warning';
{$IFDEF DEBUG }
RPS_UnableToRegister = 'Unable to register %s';
{$ENDIF}
@ -2383,6 +2384,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 +2912,8 @@ end;
function TPSPascalCompiler.GetUnicodeString(Src: PIfRVariant; var s: Boolean): tbtunicodestring;
begin
case Src.FType.BaseType of
btChar: Result := Src^.tchar;
btString: Result := 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 +3568,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 +6039,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 +6059,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 +6156,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));
@ -12259,6 +12275,7 @@ begin
FParser.OnParserError := ParserError;
FAutoFreeList := TPSList.Create;
FOutput := '';
FAllowDuplicateRegister := true;
{$IFDEF PS_USESSUPPORT}
FAllowUnit := true;
{$ENDIF}
@ -12407,6 +12424,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 +13389,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 +13500,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 +13536,9 @@ 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

23
Source/uPSR_comobj.pas
View File

@ -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.

30
Source/uPSRuntime.pas
View File

@ -1101,7 +1101,7 @@ function IDispatchInvoke(Self: IDispatch; PropertySet: Boolean; const Name: tbtS
implementation
uses
TypInfo {$IFDEF DELPHI3UP}{$IFNDEF FPC}{$IFNDEF KYLIX} , ComObj {$ENDIF}{$ENDIF}{$ENDIF};
TypInfo {$IFDEF DELPHI3UP}{$IFNDEF FPC}{$IFNDEF KYLIX} , ComObj {$ENDIF}{$ENDIF}{$ENDIF}{$IFDEF PS_FPC_HAS_COM}, ComObj{$ENDIF};
{$IFDEF DELPHI3UP }
resourceString
@ -1822,15 +1822,15 @@ const
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;
{$ifdef FPC}
high: sizeint;
function length: sizeint; inline;
{$else}
/// length in element count
// - size in bytes = length*ElemSize
length: NativeInt;
@ -3585,10 +3585,10 @@ begin
case aType.BaseType of
btU8: Result := chr(tbtu8(src^));
btU16: Result := widechar(src^);
btChar: Result := tbtchar(Src^);
btPchar: Result := pansichar(src^);
btChar: Result := tbtunicodestring(tbtchar(Src^));
btPchar: Result := tbtunicodestring(pansichar(src^));
btWideChar: Result := tbtwidechar(Src^);
btString: Result := tbtstring(src^);
btString: Result := tbtunicodestring(tbtstring(src^));
btWideString: Result := tbtwidestring(src^);
btVariant: Result := Variant(src^);
btUnicodeString: result := tbtUnicodeString(src^);
@ -4231,7 +4231,6 @@ begin
{$ENDIF CPUX64}
darr^.header.refCnt:=1;
{$IFDEF FPC}
darr^.header.length := nil;
darr^.header.high := NewLength - 1;
{$ELSE}
darr^.header.length := NewLength;
@ -9077,12 +9076,15 @@ 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;
Stack.SetInt(-1, PSDynArrayGetLength(Pointer(arr.Dta^), arr.aType));
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;
@ -9379,7 +9381,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}
@ -12655,7 +12659,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;

4
Source/x64.inc
View File

@ -610,6 +610,7 @@ begin
{$ENDIF}
btInterface, btArray, btVariant, btStaticArray:
GetPtr(res);
btRecord,
btSet:
begin
if res.aType.RealSize > PointerSize then GetPtr(res);
@ -629,6 +630,7 @@ begin
{$ENDIF}
btInterface, btArray, btVariant, btStaticArray:
GetPtr(res);
btRecord,
btSet:
begin
if res.aType.RealSize > PointerSize then GetPtr(res);
@ -666,7 +668,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}