Merge pull request #80 from pchev/master

Comobj support for FPC

Source/PascalScriptFCL.lpk

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

Source/PascalScriptFPC.inc

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

Source/PascalScript_Core_Reg.pas

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

Source/pascalscript.pas

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

Source/uPSC_comobj.pas

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

Source/uPSCompiler.pas

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

Source/uPSR_comobj.pas

@@ -11,11 +11,16 @@ uses
 procedure RIRegister_ComObj(cl: TPSExec);
 
 implementation
-uses
+{$IFDEF FPC}
-{$IFDEF DELPHI3UP}
+  {$IFDEF PS_FPC_HAS_COM}
-  ComObj;
+   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.

Source/uPSRuntime.pas

@@ -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
@@ -9378,7 +9378,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}
@@ -12654,7 +12656,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;